From 8ebf2d5b9d368338b2be1fa53042c84a6f8ef682 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 11 Jan 2020 02:53:52 -0400 Subject: Re-located code related to Lux's compilation across the different phases. --- stdlib/source/lux/control/parser/analysis.lux | 4 +- stdlib/source/lux/control/parser/synthesis.lux | 6 +- stdlib/source/lux/tool/compiler/analysis.lux | 395 ---- .../lux/tool/compiler/analysis/evaluation.lux | 41 - stdlib/source/lux/tool/compiler/analysis/macro.lux | 54 - stdlib/source/lux/tool/compiler/arity.lux | 1 + stdlib/source/lux/tool/compiler/default/init.lux | 36 +- .../source/lux/tool/compiler/default/platform.lux | 21 +- stdlib/source/lux/tool/compiler/directive.lux | 70 - stdlib/source/lux/tool/compiler/generation.lux | 298 --- .../lux/tool/compiler/language/lux/analysis.lux | 397 ++++ .../compiler/language/lux/analysis/evaluation.lux | 43 + .../tool/compiler/language/lux/analysis/macro.lux | 54 + .../lux/tool/compiler/language/lux/directive.lux | 72 + .../lux/tool/compiler/language/lux/generation.lux | 300 +++ .../tool/compiler/language/lux/phase/analysis.lux | 133 ++ .../compiler/language/lux/phase/analysis/case.lux | 321 ++++ .../language/lux/phase/analysis/case/coverage.lux | 371 ++++ .../language/lux/phase/analysis/function.lux | 108 ++ .../language/lux/phase/analysis/inference.lux | 297 +++ .../language/lux/phase/analysis/module.lux | 263 +++ .../language/lux/phase/analysis/primitive.lux | 32 + .../language/lux/phase/analysis/reference.lux | 84 + .../compiler/language/lux/phase/analysis/scope.lux | 207 ++ .../language/lux/phase/analysis/structure.lux | 364 ++++ .../compiler/language/lux/phase/analysis/type.lux | 55 + .../tool/compiler/language/lux/phase/directive.lux | 77 + .../tool/compiler/language/lux/phase/extension.lux | 146 ++ .../language/lux/phase/extension/analysis.lux | 15 + .../language/lux/phase/extension/analysis/js.lux | 198 ++ .../language/lux/phase/extension/analysis/jvm.lux | 1997 ++++++++++++++++++++ .../language/lux/phase/extension/analysis/lux.lux | 289 +++ .../language/lux/phase/extension/bundle.lux | 28 + .../language/lux/phase/extension/directive/jvm.lux | 303 +++ .../language/lux/phase/extension/directive/lux.lux | 357 ++++ .../lux/phase/extension/generation/jvm.lux | 19 + .../lux/phase/extension/generation/jvm/common.lux | 450 +++++ .../lux/phase/extension/generation/jvm/host.lux | 1088 +++++++++++ .../language/lux/phase/extension/synthesis.lux | 10 + .../language/lux/phase/generation/common-lisp.lux | 61 + .../lux/phase/generation/common-lisp/case.lux | 209 ++ .../lux/phase/generation/common-lisp/extension.lux | 13 + .../generation/common-lisp/extension/common.lux | 156 ++ .../lux/phase/generation/common-lisp/function.lux | 93 + .../lux/phase/generation/common-lisp/loop.lux | 42 + .../lux/phase/generation/common-lisp/primitive.lux | 27 + .../lux/phase/generation/common-lisp/reference.lux | 10 + .../lux/phase/generation/common-lisp/runtime.lux | 283 +++ .../lux/phase/generation/common-lisp/structure.lux | 36 + .../language/lux/phase/generation/extension.lux | 63 + .../compiler/language/lux/phase/generation/js.lux | 61 + .../language/lux/phase/generation/js/case.lux | 244 +++ .../language/lux/phase/generation/js/extension.lux | 15 + .../lux/phase/generation/js/extension/common.lux | 227 +++ .../lux/phase/generation/js/extension/host.lux | 133 ++ .../language/lux/phase/generation/js/function.lux | 107 ++ .../language/lux/phase/generation/js/loop.lux | 42 + .../language/lux/phase/generation/js/primitive.lux | 17 + .../language/lux/phase/generation/js/reference.lux | 11 + .../language/lux/phase/generation/js/runtime.lux | 743 ++++++++ .../language/lux/phase/generation/js/structure.lux | 38 + .../compiler/language/lux/phase/generation/jvm.lux | 70 + .../language/lux/phase/generation/jvm/case.lux | 267 +++ .../language/lux/phase/generation/jvm/debug.lux | 32 + .../language/lux/phase/generation/jvm/function.lux | 128 ++ .../lux/phase/generation/jvm/function/abstract.lux | 16 + .../generation/jvm/function/field/constant.lux | 25 + .../jvm/function/field/constant/arity.lux | 21 + .../generation/jvm/function/field/variable.lux | 54 + .../jvm/function/field/variable/foreign.lux | 37 + .../jvm/function/field/variable/partial.lux | 57 + .../jvm/function/field/variable/partial/count.lux | 30 + .../lux/phase/generation/jvm/function/method.lux | 13 + .../phase/generation/jvm/function/method/apply.lux | 154 ++ .../jvm/function/method/implementation.lux | 41 + .../phase/generation/jvm/function/method/init.lux | 95 + .../phase/generation/jvm/function/method/new.lux | 76 + .../phase/generation/jvm/function/method/reset.lux | 48 + .../language/lux/phase/generation/jvm/host.lux | 159 ++ .../language/lux/phase/generation/jvm/loop.lux | 88 + .../language/lux/phase/generation/jvm/packager.lux | 110 ++ .../lux/phase/generation/jvm/primitive.lux | 33 + .../language/lux/phase/generation/jvm/program.lux | 143 ++ .../lux/phase/generation/jvm/reference.lux | 61 + .../language/lux/phase/generation/jvm/runtime.lux | 589 ++++++ .../lux/phase/generation/jvm/structure.lux | 72 + .../language/lux/phase/generation/jvm/type.lux | 22 + .../language/lux/phase/generation/jvm/value.lux | 48 + .../compiler/language/lux/phase/generation/lua.lux | 61 + .../language/lux/phase/generation/lua/case.lux | 210 ++ .../lux/phase/generation/lua/extension.lux | 13 + .../lux/phase/generation/lua/extension/common.lux | 148 ++ .../language/lux/phase/generation/lua/function.lux | 105 + .../language/lux/phase/generation/lua/loop.lux | 42 + .../lux/phase/generation/lua/primitive.lux | 27 + .../lux/phase/generation/lua/reference.lux | 10 + .../language/lux/phase/generation/lua/runtime.lux | 363 ++++ .../lux/phase/generation/lua/structure.lux | 36 + .../compiler/language/lux/phase/generation/php.lux | 61 + .../language/lux/phase/generation/php/case.lux | 248 +++ .../lux/phase/generation/php/extension.lux | 13 + .../lux/phase/generation/php/extension/common.lux | 129 ++ .../language/lux/phase/generation/php/function.lux | 104 + .../language/lux/phase/generation/php/loop.lux | 49 + .../lux/phase/generation/php/primitive.lux | 27 + .../lux/phase/generation/php/reference.lux | 11 + .../language/lux/phase/generation/php/runtime.lux | 306 +++ .../lux/phase/generation/php/structure.lux | 36 + .../language/lux/phase/generation/python.lux | 61 + .../language/lux/phase/generation/python/case.lux | 237 +++ .../lux/phase/generation/python/extension.lux | 13 + .../phase/generation/python/extension/common.lux | 130 ++ .../lux/phase/generation/python/function.lux | 106 ++ .../language/lux/phase/generation/python/loop.lux | 42 + .../lux/phase/generation/python/primitive.lux | 27 + .../lux/phase/generation/python/reference.lux | 10 + .../lux/phase/generation/python/runtime.lux | 340 ++++ .../lux/phase/generation/python/structure.lux | 36 + .../language/lux/phase/generation/reference.lux | 81 + .../language/lux/phase/generation/ruby.lux | 61 + .../language/lux/phase/generation/ruby/case.lux | 221 +++ .../lux/phase/generation/ruby/extension.lux | 13 + .../lux/phase/generation/ruby/extension/common.lux | 162 ++ .../lux/phase/generation/ruby/function.lux | 99 + .../language/lux/phase/generation/ruby/loop.lux | 42 + .../lux/phase/generation/ruby/primitive.lux | 27 + .../lux/phase/generation/ruby/reference.lux | 10 + .../language/lux/phase/generation/ruby/runtime.lux | 295 +++ .../lux/phase/generation/ruby/structure.lux | 36 + .../language/lux/phase/generation/scheme.lux | 61 + .../language/lux/phase/generation/scheme/case.lux | 171 ++ .../lux/phase/generation/scheme/extension.lux | 13 + .../phase/generation/scheme/extension/common.lux | 240 +++ .../lux/phase/generation/scheme/function.lux | 98 + .../language/lux/phase/generation/scheme/loop.lux | 42 + .../lux/phase/generation/scheme/primitive.lux | 15 + .../lux/phase/generation/scheme/reference.lux | 10 + .../lux/phase/generation/scheme/runtime.lux | 267 +++ .../lux/phase/generation/scheme/structure.lux | 37 + .../tool/compiler/language/lux/phase/synthesis.lux | 90 + .../compiler/language/lux/phase/synthesis/case.lux | 270 +++ .../language/lux/phase/synthesis/function.lux | 215 +++ .../compiler/language/lux/phase/synthesis/loop.lux | 296 +++ .../lux/tool/compiler/language/lux/synthesis.lux | 496 +++++ stdlib/source/lux/tool/compiler/phase/analysis.lux | 131 -- .../lux/tool/compiler/phase/analysis/case.lux | 319 ---- .../tool/compiler/phase/analysis/case/coverage.lux | 369 ---- .../lux/tool/compiler/phase/analysis/function.lux | 106 -- .../lux/tool/compiler/phase/analysis/inference.lux | 295 --- .../lux/tool/compiler/phase/analysis/module.lux | 261 --- .../lux/tool/compiler/phase/analysis/primitive.lux | 30 - .../lux/tool/compiler/phase/analysis/reference.lux | 82 - .../lux/tool/compiler/phase/analysis/scope.lux | 206 -- .../lux/tool/compiler/phase/analysis/structure.lux | 362 ---- .../lux/tool/compiler/phase/analysis/type.lux | 53 - .../source/lux/tool/compiler/phase/directive.lux | 75 - .../source/lux/tool/compiler/phase/extension.lux | 145 -- .../lux/tool/compiler/phase/extension/analysis.lux | 15 - .../tool/compiler/phase/extension/analysis/js.lux | 198 -- .../tool/compiler/phase/extension/analysis/jvm.lux | 1995 ------------------- .../tool/compiler/phase/extension/analysis/lux.lux | 287 --- .../lux/tool/compiler/phase/extension/bundle.lux | 28 - .../compiler/phase/extension/directive/jvm.lux | 303 --- .../compiler/phase/extension/directive/lux.lux | 355 ---- .../compiler/phase/extension/generation/jvm.lux | 19 - .../phase/extension/generation/jvm/common.lux | 450 ----- .../phase/extension/generation/jvm/host.lux | 1088 ----------- .../tool/compiler/phase/extension/synthesis.lux | 10 - .../tool/compiler/phase/generation/common-lisp.lux | 61 - .../compiler/phase/generation/common-lisp/case.lux | 209 -- .../phase/generation/common-lisp/extension.lux | 13 - .../generation/common-lisp/extension/common.lux | 156 -- .../phase/generation/common-lisp/function.lux | 93 - .../compiler/phase/generation/common-lisp/loop.lux | 42 - .../phase/generation/common-lisp/primitive.lux | 27 - .../phase/generation/common-lisp/reference.lux | 10 - .../phase/generation/common-lisp/runtime.lux | 283 --- .../phase/generation/common-lisp/structure.lux | 36 - .../tool/compiler/phase/generation/extension.lux | 61 - .../lux/tool/compiler/phase/generation/js.lux | 61 - .../lux/tool/compiler/phase/generation/js/case.lux | 244 --- .../compiler/phase/generation/js/extension.lux | 15 - .../phase/generation/js/extension/common.lux | 227 --- .../phase/generation/js/extension/host.lux | 133 -- .../tool/compiler/phase/generation/js/function.lux | 107 -- .../lux/tool/compiler/phase/generation/js/loop.lux | 42 - .../compiler/phase/generation/js/primitive.lux | 17 - .../compiler/phase/generation/js/reference.lux | 11 - .../tool/compiler/phase/generation/js/runtime.lux | 743 -------- .../compiler/phase/generation/js/structure.lux | 38 - .../lux/tool/compiler/phase/generation/jvm.lux | 68 - .../tool/compiler/phase/generation/jvm/case.lux | 266 --- .../tool/compiler/phase/generation/jvm/debug.lux | 32 - .../compiler/phase/generation/jvm/function.lux | 127 -- .../phase/generation/jvm/function/abstract.lux | 16 - .../generation/jvm/function/field/constant.lux | 25 - .../jvm/function/field/constant/arity.lux | 21 - .../generation/jvm/function/field/variable.lux | 54 - .../jvm/function/field/variable/foreign.lux | 36 - .../jvm/function/field/variable/partial.lux | 57 - .../jvm/function/field/variable/partial/count.lux | 30 - .../phase/generation/jvm/function/method.lux | 13 - .../phase/generation/jvm/function/method/apply.lux | 153 -- .../jvm/function/method/implementation.lux | 41 - .../phase/generation/jvm/function/method/init.lux | 94 - .../phase/generation/jvm/function/method/new.lux | 75 - .../phase/generation/jvm/function/method/reset.lux | 47 - .../tool/compiler/phase/generation/jvm/host.lux | 159 -- .../tool/compiler/phase/generation/jvm/loop.lux | 87 - .../compiler/phase/generation/jvm/packager.lux | 109 -- .../compiler/phase/generation/jvm/primitive.lux | 33 - .../tool/compiler/phase/generation/jvm/program.lux | 143 -- .../compiler/phase/generation/jvm/reference.lux | 59 - .../tool/compiler/phase/generation/jvm/runtime.lux | 587 ------ .../compiler/phase/generation/jvm/structure.lux | 71 - .../tool/compiler/phase/generation/jvm/type.lux | 22 - .../tool/compiler/phase/generation/jvm/value.lux | 48 - .../lux/tool/compiler/phase/generation/lua.lux | 61 - .../tool/compiler/phase/generation/lua/case.lux | 210 -- .../compiler/phase/generation/lua/extension.lux | 13 - .../phase/generation/lua/extension/common.lux | 148 -- .../compiler/phase/generation/lua/function.lux | 105 - .../tool/compiler/phase/generation/lua/loop.lux | 42 - .../compiler/phase/generation/lua/primitive.lux | 27 - .../compiler/phase/generation/lua/reference.lux | 10 - .../tool/compiler/phase/generation/lua/runtime.lux | 363 ---- .../compiler/phase/generation/lua/structure.lux | 36 - .../lux/tool/compiler/phase/generation/php.lux | 61 - .../tool/compiler/phase/generation/php/case.lux | 248 --- .../compiler/phase/generation/php/extension.lux | 13 - .../phase/generation/php/extension/common.lux | 129 -- .../compiler/phase/generation/php/function.lux | 104 - .../tool/compiler/phase/generation/php/loop.lux | 49 - .../compiler/phase/generation/php/primitive.lux | 27 - .../compiler/phase/generation/php/reference.lux | 11 - .../tool/compiler/phase/generation/php/runtime.lux | 306 --- .../compiler/phase/generation/php/structure.lux | 36 - .../lux/tool/compiler/phase/generation/python.lux | 61 - .../tool/compiler/phase/generation/python/case.lux | 237 --- .../compiler/phase/generation/python/extension.lux | 13 - .../phase/generation/python/extension/common.lux | 130 -- .../compiler/phase/generation/python/function.lux | 106 -- .../tool/compiler/phase/generation/python/loop.lux | 42 - .../compiler/phase/generation/python/primitive.lux | 27 - .../compiler/phase/generation/python/reference.lux | 10 - .../compiler/phase/generation/python/runtime.lux | 340 ---- .../compiler/phase/generation/python/structure.lux | 36 - .../tool/compiler/phase/generation/reference.lux | 81 - .../lux/tool/compiler/phase/generation/ruby.lux | 61 - .../tool/compiler/phase/generation/ruby/case.lux | 221 --- .../compiler/phase/generation/ruby/extension.lux | 13 - .../phase/generation/ruby/extension/common.lux | 162 -- .../compiler/phase/generation/ruby/function.lux | 99 - .../tool/compiler/phase/generation/ruby/loop.lux | 42 - .../compiler/phase/generation/ruby/primitive.lux | 27 - .../compiler/phase/generation/ruby/reference.lux | 10 - .../compiler/phase/generation/ruby/runtime.lux | 295 --- .../compiler/phase/generation/ruby/structure.lux | 36 - .../lux/tool/compiler/phase/generation/scheme.lux | 61 - .../tool/compiler/phase/generation/scheme/case.lux | 171 -- .../compiler/phase/generation/scheme/extension.lux | 13 - .../phase/generation/scheme/extension/common.lux | 240 --- .../compiler/phase/generation/scheme/function.lux | 98 - .../tool/compiler/phase/generation/scheme/loop.lux | 42 - .../compiler/phase/generation/scheme/primitive.lux | 15 - .../compiler/phase/generation/scheme/reference.lux | 10 - .../compiler/phase/generation/scheme/runtime.lux | 267 --- .../compiler/phase/generation/scheme/structure.lux | 37 - .../source/lux/tool/compiler/phase/synthesis.lux | 88 - .../lux/tool/compiler/phase/synthesis/case.lux | 268 --- .../lux/tool/compiler/phase/synthesis/function.lux | 214 --- .../lux/tool/compiler/phase/synthesis/loop.lux | 295 --- stdlib/source/lux/tool/compiler/synthesis.lux | 494 ----- stdlib/source/program/compositor.lux | 15 +- 274 files changed, 19613 insertions(+), 19540 deletions(-) delete mode 100644 stdlib/source/lux/tool/compiler/analysis.lux delete mode 100644 stdlib/source/lux/tool/compiler/analysis/evaluation.lux delete mode 100644 stdlib/source/lux/tool/compiler/analysis/macro.lux delete mode 100644 stdlib/source/lux/tool/compiler/directive.lux delete mode 100644 stdlib/source/lux/tool/compiler/generation.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/analysis.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/analysis/macro.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/directive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/generation.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/analysis/function.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/analysis/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/analysis/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/directive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/synthesis.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/case.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/extension/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/function.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/runtime.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/structure.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension/host.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/packager.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/extension/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/php.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/extension/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/structure.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/extension/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/synthesis.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/analysis.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/inference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/module.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/scope.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/structure.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/type.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/directive.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis/js.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis/lux.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/bundle.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/directive/jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/directive/lux.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/generation/jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/generation/jvm/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/generation/jvm/host.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/synthesis.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/common-lisp.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/common-lisp/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/common-lisp/extension/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/common-lisp/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/common-lisp/loop.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/common-lisp/primitive.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/common-lisp/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/common-lisp/runtime.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/common-lisp/structure.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/loop.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/primitive.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/structure.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/debug.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant/arity.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/foreign.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/new.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/reset.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/host.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/packager.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/program.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/type.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/lua.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/lua/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/lua/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/lua/extension/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/lua/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/lua/loop.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/lua/primitive.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/lua/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/lua/runtime.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/lua/structure.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/php.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/php/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/php/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/php/extension/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/php/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/php/loop.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/php/primitive.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/php/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/php/runtime.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/php/structure.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/python.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/python/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/python/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/python/extension/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/python/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/python/loop.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/python/primitive.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/python/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/python/structure.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/ruby.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/ruby/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/ruby/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/ruby/extension/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/ruby/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/ruby/loop.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/ruby/primitive.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/ruby/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/ruby/runtime.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/ruby/structure.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/synthesis.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/synthesis/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/synthesis/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/synthesis/loop.lux delete mode 100644 stdlib/source/lux/tool/compiler/synthesis.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/control/parser/analysis.lux b/stdlib/source/lux/control/parser/analysis.lux index 0cef19fd9..fe8b4c4f0 100644 --- a/stdlib/source/lux/control/parser/analysis.lux +++ b/stdlib/source/lux/control/parser/analysis.lux @@ -22,7 +22,9 @@ [compiler [reference (#+)] [arity (#+ Arity)] - ["/" analysis (#+ Variant Tuple Environment Analysis)]]]] + [language + [lux + ["/" analysis (#+ Variant Tuple Environment Analysis)]]]]]] ["." //]) (def: (remaining-inputs asts) diff --git a/stdlib/source/lux/control/parser/synthesis.lux b/stdlib/source/lux/control/parser/synthesis.lux index 0c52b878c..5e3b1dadb 100644 --- a/stdlib/source/lux/control/parser/synthesis.lux +++ b/stdlib/source/lux/control/parser/synthesis.lux @@ -20,8 +20,10 @@ [compiler [reference (#+)] [arity (#+ Arity)] - [analysis (#+ Variant Tuple Environment)] - ["/" synthesis (#+ Synthesis Abstraction)]]]] + [language + [lux + [analysis (#+ Variant Tuple Environment)] + ["/" synthesis (#+ Synthesis Abstraction)]]]]]] ["." //]) (def: (remaining-inputs asts) diff --git a/stdlib/source/lux/tool/compiler/analysis.lux b/stdlib/source/lux/tool/compiler/analysis.lux deleted file mode 100644 index 5d9d899ab..000000000 --- a/stdlib/source/lux/tool/compiler/analysis.lux +++ /dev/null @@ -1,395 +0,0 @@ -(.module: - [lux (#- nat int rev) - [abstract - [monad (#+ do)]] - [control - ["." function] - ["." try] - ["." exception (#+ Exception)]] - [data - ["." product] - ["." maybe] - [number - ["n" nat]] - ["." text ("#@." equivalence) - ["%" format (#+ Format format)]] - [collection - ["." list ("#@." functor fold)]]]] - [// - [arity (#+ Arity)] - ["." reference (#+ Register Variable Reference)] - ["." phase - ["." extension (#+ Extension)]]]) - -(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}) - -(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 - (List Variable)) - -(type: #export #rec Analysis - (#Primitive Primitive) - (#Structure (Composite Analysis)) - (#Reference Reference) - (#Case Analysis (Match' Analysis)) - (#Function Environment Analysis) - (#Apply Analysis Analysis) - (#Extension (Extension Analysis))) - -(type: #export Branch - (Branch' Analysis)) - -(type: #export Match - (Match' Analysis)) - -(template [ ] - [(template: #export ( content) - ( content))] - - [control/case #..Case] - ) - -(template [ ] - [(template: #export ( value) - (#..Primitive ( value)))] - - [bit Bit #..Bit] - [nat Nat #..Nat] - [int Int #..Int] - [rev Rev #..Rev] - [frac Frac #..Frac] - [text Text #..Text] - ) - -(type: #export (Abstraction c) [Environment 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 #reference.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 [ ] - [(template: #export ( content) - (.<| #..Reference - - content))] - - [variable #reference.Variable] - [constant #reference.Constant] - - [variable/local reference.local] - [variable/foreign reference.foreign] - ) - -(template [ ] - [(template: #export ( content) - (.<| #..Complex - - content))] - - [pattern/variant #..Variant] - [pattern/tuple #..Tuple] - ) - -(template [ ] - [(template: #export ( content) - (.<| #..Structure - - content))] - - [variant #..Variant] - [tuple #..Tuple] - ) - -(template: #export (pattern/unit) - (#..Simple #..Unit)) - -(template [ ] - [(template: #export ( content) - (#..Simple ( 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 [ ] - ( value) - ( 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) - (case reference - (#reference.Variable variable) - (reference.%variable variable) - - (#reference.Constant constant) - (%.name constant)) - - (#Case analysis match) - "{?}" - - (#Function environment body) - (|> (%analysis body) - (format " ") - (format (|> environment - (list@map reference.%variable) - (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 [ ] - [(type: #export - ( .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-cursor cursor action) - (All [a] (-> Cursor (Operation a) (Operation a))) - (if (text@= "" (product.left cursor)) - action - (function (_ [bundle state]) - (let [old-cursor (get@ #.cursor state)] - (case (action [bundle (set@ #.cursor cursor state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set@ #.cursor old-cursor state')] - output]) - - (#try.Failure error) - (#try.Failure error)))))) - -(def: (locate-error cursor error) - (-> Cursor Text Text) - (format "@ " (%.cursor cursor) text.new-line - error)) - -(def: #export (fail error) - (-> Text Operation) - (function (_ [bundle state]) - (#try.Failure (locate-error (get@ #.cursor 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@ #.cursor 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 (action bundle,state) - (#try.Success output) - (#try.Success output) - - (#try.Failure error) - (let [[bundle state] bundle,state] - (#try.Failure (<| (locate-error (get@ #.cursor state)) - (exception.decorate (exception.construct exception message)) - error)))))) - -(template [ ] - [(def: #export ( value) - (-> (Operation Any)) - (extension.update (set@ )))] - - [set-source-code Source #.source value] - [set-current-module Text #.current-module (#.Some value)] - [set-cursor Cursor #.cursor value] - ) - -(def: #export (cursor file) - (-> Text Cursor) - [file 1 0]) - -(def: #export (source file code) - (-> Text Text Source) - [(cursor file) 0 code]) - -(def: dummy-source - Source - [.dummy-cursor 0 ""]) - -(def: type-context - Type-Context - {#.ex-counter 0 - #.var-counter 0 - #.var-bindings (list)}) - -(def: #export (state info host) - (-> Info Any Lux) - {#.info info - #.source ..dummy-source - #.cursor .dummy-cursor - #.current-module #.None - #.modules (list) - #.scopes (list) - #.type-context ..type-context - #.expected #.None - #.seed 0 - #.scope-type-vars (list) - #.extensions [] - #.host host}) diff --git a/stdlib/source/lux/tool/compiler/analysis/evaluation.lux b/stdlib/source/lux/tool/compiler/analysis/evaluation.lux deleted file mode 100644 index 08a57bf20..000000000 --- a/stdlib/source/lux/tool/compiler/analysis/evaluation.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." try]] - [data - [text - ["%" format (#+ format)]]]] - [// (#+ Operation) - [macro (#+ Expander)] - [// - ["." phase - [".P" analysis - ["." type]] - [".P" synthesis] - [// - ["." synthesis] - ["." generation]]]]]) - -(type: #export Eval - (-> Nat Type Code (Operation Any))) - -(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 count type exprC) - (do phase.monad - [exprA (type.with-type type - (analyze exprC))] - (phase.lift (do try.monad - [exprS (|> exprA synthesisP.phase (phase.run synthesis-state))] - (phase.run generation-state - (do phase.monad - [exprO (generate exprS)] - (generation.evaluate! (format "eval" (%.nat count)) exprO))))))))) diff --git a/stdlib/source/lux/tool/compiler/analysis/macro.lux b/stdlib/source/lux/tool/compiler/analysis/macro.lux deleted file mode 100644 index 9e191e514..000000000 --- a/stdlib/source/lux/tool/compiler/analysis/macro.lux +++ /dev/null @@ -1,54 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - [array (#+ Array)] - ["." list ("#@." functor)]]] - ["." macro]] - [/// - ["." 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) - ((phase.throw ..expansion-failed [name inputs error]) state))))) - -(def: #export (expand-one expander name macro inputs) - (-> Expander Name Macro (List Code) (Meta Code)) - (do macro.monad - [expansion (expand expander name macro inputs)] - (case expansion - (^ (list single)) - (wrap single) - - _ - (phase.throw ..must-have-single-expansion [name inputs expansion])))) diff --git a/stdlib/source/lux/tool/compiler/arity.lux b/stdlib/source/lux/tool/compiler/arity.lux index 54b50cab2..84c2b8e9e 100644 --- a/stdlib/source/lux/tool/compiler/arity.lux +++ b/stdlib/source/lux/tool/compiler/arity.lux @@ -9,6 +9,7 @@ (template [ ] [(def: #export (-> Arity Bit) ( 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 index 370894d26..14d04a226 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -19,23 +19,25 @@ ["/#" // (#+ Instancer) [language [lux - ["." syntax (#+ Aliases)]]] - ["#." analysis - [macro (#+ Expander)] - ["#/." evaluation]] - ["#." synthesis] - ["#." directive (#+ Requirements)] - ["#." generation] - ["#." phase - [".P" analysis - ["." module]] - [".P" synthesis] - [".P" directive] - ["." extension (#+ Extender) - [".E" analysis] - [".E" synthesis] - [directive - [".D" lux]]]] + ["." syntax (#+ Aliases)] + ["#." analysis + [macro (#+ Expander)] + ["#/." evaluation]] + ["#." synthesis] + ["#." directive (#+ Requirements)] + ["#." generation] + [phase + [".P" analysis + ["." module]] + [".P" synthesis] + [".P" directive] + ["." extension (#+ Extender) + [".E" analysis] + [".E" synthesis] + [directive + [".D" lux]]]] + [/// + ["#." phase]]]] [meta [archive ["." signature] diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index c6df2955e..36fc26363 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -19,18 +19,19 @@ ["." // #_ ["#." init] ["/#" // + ["#." phase] [language [lux - ["." syntax]]] - ["#." analysis - [macro (#+ Expander)]] - ["#." generation (#+ Buffer)] - ["#." directive] - ["#." phase - ## TODO: Get rid of this import ASAP - ["." extension (#+ Extender)] - [analysis - ["." module]]] + ["." syntax] + ["#." analysis + [macro (#+ Expander)]] + ["#." generation (#+ Buffer)] + ["#." directive] + [phase + ## TODO: Get rid of this import ASAP + ["." extension (#+ Extender)] + [analysis + ["." module]]]]] [meta ["." archive (#+ Archive) [descriptor (#+ Module)]] diff --git a/stdlib/source/lux/tool/compiler/directive.lux b/stdlib/source/lux/tool/compiler/directive.lux deleted file mode 100644 index 31edabddb..000000000 --- a/stdlib/source/lux/tool/compiler/directive.lux +++ /dev/null @@ -1,70 +0,0 @@ -(.module: - [lux (#- Module) - [data - [collection - ["." list ("#;." monoid)]]]] - [// - [meta - [archive - [descriptor (#+ Module)]]] - ["." analysis] - ["." synthesis] - ["." generation] - ["." phase - ["." extension]]]) - -(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 [ ] - [(type: #export ( anchor expression directive) - ( (..State anchor expression directive) Code Requirements))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(template [ ] - [(def: #export ( operation) - (All [anchor expression directive output] - (-> ( output) - (Operation anchor expression directive output))) - (extension.lift - (phase.sub [(get@ [ #..state]) - (set@ [ #..state])] - operation)))] - - [lift-analysis #..analysis analysis.Operation] - [lift-synthesis #..synthesis synthesis.Operation] - [lift-generation #..generation (generation.Operation anchor expression directive)] - ) diff --git a/stdlib/source/lux/tool/compiler/generation.lux b/stdlib/source/lux/tool/compiler/generation.lux deleted file mode 100644 index e29036dd9..000000000 --- a/stdlib/source/lux/tool/compiler/generation.lux +++ /dev/null @@ -1,298 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." name ("#@." equivalence)] - ["." text - ["%" format (#+ format)]] - [collection - ["." row (#+ Row)] - ["." dictionary (#+ Dictionary)] - ["." list ("#@." functor)]]]] - [// - ["." phase - ["." extension]] - [synthesis (#+ Synthesis)] - [meta - [archive - [descriptor (#+ Module)]]]]) - -(type: #export Registry - (Dictionary Name Text)) - -(exception: #export (cannot-interpret {error Text}) - (exception.report - ["Error" error])) - -(exception: #export (unknown-lux-name {name Name} {registry Registry}) - (exception.report - ["Name" (%.name name)] - ["Registry" (|> registry - dictionary.keys - (list.sort (:: name.order <)) - (list@map %.name) - (text.join-with text.new-line))])) - -(exception: #export (cannot-overwrite-lux-name {lux-name Name} - {old-host-name Text} - {new-host-name Text}) - (exception.report - ["Lux Name" (%.name lux-name)] - ["Old Host Name" old-host-name] - ["New Host Name" new-host-name])) - -(template [] - [(exception: #export ( {name Name}) - (exception.report - ["Output" (%.name name)]))] - - [cannot-overwrite-output] - [no-buffer-for-saving-code] - ) - -(type: #export Context - {#scope-name Text - #inner-functions Nat}) - -(signature: #export (Host expression directive) - (: (-> Text expression (Try Any)) - evaluate!) - (: (-> Text directive (Try Any)) - execute!) - (: (-> Name expression (Try [Text Any directive])) - define!)) - -(type: #export (Buffer directive) (Row [Name directive])) -(type: #export (Output directive) (Row [Module (Buffer directive)])) - -(type: #export (State anchor expression directive) - {#context Context - #anchor (Maybe anchor) - #host (Host expression directive) - #buffer (Maybe (Buffer directive)) - #output (Output directive) - #counter Nat - #name-cache Registry}) - -(template [ ] - [(type: #export ( anchor expression directive) - ( (State anchor expression directive) Synthesis expression))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(def: #export (fresh-context scope-name) - (-> Text Context) - {#scope-name scope-name - #inner-functions 0}) - -(def: #export (state host) - (All [anchor expression directive] - (-> (Host expression directive) - (..State anchor expression directive))) - {#context (..fresh-context "") - #anchor #.None - #host host - #buffer #.None - #output row.empty - #counter 0 - #name-cache (dictionary.new name.hash)}) - -(def: #export (with-specific-context specific-scope expr) - (All [anchor expression directive output] - (-> Text - (Operation anchor expression directive output) - (Operation anchor expression directive output))) - (function (_ [bundle state]) - (let [old (get@ #context state)] - (case (expr [bundle (set@ #context (..fresh-context specific-scope) state)]) - (#try.Success [[bundle' state'] - output]) - (#try.Success [[bundle' (set@ #context old state')] - output]) - - (#try.Failure error) - (#try.Failure error))))) - -(def: #export (with-context expr) - (All [anchor expression directive output] - (-> (Operation anchor expression directive output) - (Operation anchor expression directive [Text output]))) - (function (_ [bundle state]) - (let [[old-scope old-inner] (get@ #context state) - new-scope (format old-scope "$c" (%.nat old-inner))] - (case (expr [bundle (set@ #context (..fresh-context new-scope) state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set@ #context {#scope-name old-scope - #inner-functions (inc old-inner)} - state')] - [new-scope output]]) - - (#try.Failure error) - (#try.Failure error))))) - -(def: #export context - (All [anchor expression directive] - (Operation anchor expression directive Text)) - (extension.read (|>> (get@ #context) - (get@ #scope-name)))) - -(def: #export empty-buffer Buffer row.empty) - -(template [ - - ] - [(exception: #export ) - - (def: #export - (All [anchor expression directive output] ) - (function (_ body) - (function (_ [bundle state]) - (case (body [bundle (set@ (#.Some ) state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set@ (get@ state) state')] - output]) - - (#try.Failure error) - (#try.Failure error))))) - - (def: #export - (All [anchor expression directive] - (Operation anchor expression directive )) - (function (_ (^@ stateE [bundle state])) - (case (get@ state) - (#.Some output) - (#try.Success [stateE output]) - - #.None - (exception.throw [])))) - - (def: #export ( value) - (All [anchor expression directive] - (-> (Operation anchor expression directive Any))) - (function (_ [bundle state]) - (#try.Success [[bundle (set@ (#.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 output - (All [anchor expression directive] - (Operation anchor expression directive (Output directive))) - (extension.read (get@ #output))) - -(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)) - -(template [ ] - [(def: #export ( label code) - (All [anchor expression directive] - (-> Text (Operation anchor expression directive Any))) - (function (_ (^@ state+ [bundle state])) - (case (:: (get@ #host state) label code) - (#try.Success output) - (#try.Success [state+ output]) - - (#try.Failure error) - (exception.throw cannot-interpret error))))] - - [evaluate! expression] - [execute! directive] - ) - -(def: #export (define! name code) - (All [anchor expression directive] - (-> Name expression (Operation anchor expression directive [Text Any directive]))) - (function (_ (^@ stateE [bundle state])) - (case (:: (get@ #host state) define! name code) - (#try.Success output) - (#try.Success [stateE output]) - - (#try.Failure error) - (exception.throw cannot-interpret error)))) - -(def: #export (save! execute? name code) - (All [anchor expression directive] - (-> Bit Name directive (Operation anchor expression directive Any))) - (do phase.monad - [label (..gensym "save") - _ (if execute? - (execute! label code) - (wrap [])) - ?buffer (extension.read (get@ #buffer))] - (case ?buffer - (#.Some buffer) - (if (row.any? (|>> product.left (name@= name)) buffer) - (phase.throw ..cannot-overwrite-output name) - (extension.update (set@ #buffer (#.Some (row.add [name code] buffer))))) - - #.None - (phase.throw no-buffer-for-saving-code name)))) - -(def: #export (save-buffer! target) - (All [anchor expression directive] - (-> Module (Operation anchor expression directive (Buffer directive)))) - (do phase.monad - [buffer ..buffer - _ (extension.update (update@ #output (row.add [target buffer])))] - (wrap buffer))) - -(def: #export (remember lux-name) - (All [anchor expression directive] - (-> Name (Operation anchor expression directive Text))) - (function (_ (^@ stateE [_ state])) - (let [cache (get@ #name-cache state)] - (case (dictionary.get lux-name cache) - (#.Some host-name) - (#try.Success [stateE host-name]) - - #.None - (exception.throw unknown-lux-name [lux-name cache]))))) - -(def: #export (learn lux-name host-name) - (All [anchor expression directive] - (-> Name Text (Operation anchor expression directive Any))) - (function (_ [bundle state]) - (let [cache (get@ #name-cache state)] - (case (dictionary.get lux-name cache) - #.None - (#try.Success [[bundle - (update@ #name-cache - (dictionary.put lux-name host-name) - state)] - []]) - - (#.Some old-host-name) - (exception.throw cannot-overwrite-lux-name [lux-name old-host-name host-name]))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux new file mode 100644 index 000000000..6c081620c --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux @@ -0,0 +1,397 @@ +(.module: + [lux (#- nat int rev) + [abstract + [monad (#+ do)]] + [control + ["." function] + ["." try] + ["." exception (#+ Exception)]] + [data + ["." product] + ["." maybe] + [number + ["n" nat]] + ["." text ("#@." equivalence) + ["%" format (#+ Format format)]] + [collection + ["." list ("#@." functor fold)]]]] + [// + [phase + ["." extension (#+ Extension)]] + [/// + [arity (#+ Arity)] + ["." reference (#+ Register Variable Reference)] + ["." phase]]]) + +(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}) + +(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 + (List Variable)) + +(type: #export #rec Analysis + (#Primitive Primitive) + (#Structure (Composite Analysis)) + (#Reference Reference) + (#Case Analysis (Match' Analysis)) + (#Function Environment Analysis) + (#Apply Analysis Analysis) + (#Extension (Extension Analysis))) + +(type: #export Branch + (Branch' Analysis)) + +(type: #export Match + (Match' Analysis)) + +(template [ ] + [(template: #export ( content) + ( content))] + + [control/case #..Case] + ) + +(template [ ] + [(template: #export ( value) + (#..Primitive ( value)))] + + [bit Bit #..Bit] + [nat Nat #..Nat] + [int Int #..Int] + [rev Rev #..Rev] + [frac Frac #..Frac] + [text Text #..Text] + ) + +(type: #export (Abstraction c) [Environment 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 #reference.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 [ ] + [(template: #export ( content) + (.<| #..Reference + + content))] + + [variable #reference.Variable] + [constant #reference.Constant] + + [variable/local reference.local] + [variable/foreign reference.foreign] + ) + +(template [ ] + [(template: #export ( content) + (.<| #..Complex + + content))] + + [pattern/variant #..Variant] + [pattern/tuple #..Tuple] + ) + +(template [ ] + [(template: #export ( content) + (.<| #..Structure + + content))] + + [variant #..Variant] + [tuple #..Tuple] + ) + +(template: #export (pattern/unit) + (#..Simple #..Unit)) + +(template [ ] + [(template: #export ( content) + (#..Simple ( 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 [ ] + ( value) + ( 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) + (case reference + (#reference.Variable variable) + (reference.%variable variable) + + (#reference.Constant constant) + (%.name constant)) + + (#Case analysis match) + "{?}" + + (#Function environment body) + (|> (%analysis body) + (format " ") + (format (|> environment + (list@map reference.%variable) + (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 [ ] + [(type: #export + ( .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-cursor cursor action) + (All [a] (-> Cursor (Operation a) (Operation a))) + (if (text@= "" (product.left cursor)) + action + (function (_ [bundle state]) + (let [old-cursor (get@ #.cursor state)] + (case (action [bundle (set@ #.cursor cursor state)]) + (#try.Success [[bundle' state'] output]) + (#try.Success [[bundle' (set@ #.cursor old-cursor state')] + output]) + + (#try.Failure error) + (#try.Failure error)))))) + +(def: (locate-error cursor error) + (-> Cursor Text Text) + (format "@ " (%.cursor cursor) text.new-line + error)) + +(def: #export (fail error) + (-> Text Operation) + (function (_ [bundle state]) + (#try.Failure (locate-error (get@ #.cursor 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@ #.cursor 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 (action bundle,state) + (#try.Success output) + (#try.Success output) + + (#try.Failure error) + (let [[bundle state] bundle,state] + (#try.Failure (<| (locate-error (get@ #.cursor state)) + (exception.decorate (exception.construct exception message)) + error)))))) + +(template [ ] + [(def: #export ( value) + (-> (Operation Any)) + (extension.update (set@ )))] + + [set-source-code Source #.source value] + [set-current-module Text #.current-module (#.Some value)] + [set-cursor Cursor #.cursor value] + ) + +(def: #export (cursor file) + (-> Text Cursor) + [file 1 0]) + +(def: #export (source file code) + (-> Text Text Source) + [(cursor file) 0 code]) + +(def: dummy-source + Source + [.dummy-cursor 0 ""]) + +(def: type-context + Type-Context + {#.ex-counter 0 + #.var-counter 0 + #.var-bindings (list)}) + +(def: #export (state info host) + (-> Info Any Lux) + {#.info info + #.source ..dummy-source + #.cursor .dummy-cursor + #.current-module #.None + #.modules (list) + #.scopes (list) + #.type-context ..type-context + #.expected #.None + #.seed 0 + #.scope-type-vars (list) + #.extensions [] + #.host 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 new file mode 100644 index 000000000..710bb3eb0 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux @@ -0,0 +1,43 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." try]] + [data + [text + ["%" format (#+ format)]]]] + [// (#+ Operation) + [macro (#+ Expander)] + [// + [phase + [".P" synthesis] + [".P" analysis + ["." type]] + [// + ["." synthesis] + ["." generation] + [/// + ["." phase]]]]]]) + +(type: #export Eval + (-> Nat Type Code (Operation Any))) + +(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 count type exprC) + (do phase.monad + [exprA (type.with-type type + (analyze exprC))] + (phase.lift (do try.monad + [exprS (|> exprA synthesisP.phase (phase.run synthesis-state))] + (phase.run generation-state + (do phase.monad + [exprO (generate exprS)] + (generation.evaluate! (format "eval" (%.nat 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 new file mode 100644 index 000000000..89731a81b --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/analysis/macro.lux @@ -0,0 +1,54 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." text + ["%" format (#+ format)]] + [collection + [array (#+ Array)] + ["." list ("#@." functor)]]] + ["." macro]] + [///// + ["." 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) + ((phase.throw ..expansion-failed [name inputs error]) state))))) + +(def: #export (expand-one expander name macro inputs) + (-> Expander Name Macro (List Code) (Meta Code)) + (do macro.monad + [expansion (expand expander name macro inputs)] + (case expansion + (^ (list single)) + (wrap single) + + _ + (phase.throw ..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 new file mode 100644 index 000000000..2c1dd3be6 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/directive.lux @@ -0,0 +1,72 @@ +(.module: + [lux (#- Module) + [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 [ ] + [(type: #export ( anchor expression directive) + ( (..State anchor expression directive) Code Requirements))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(template [ ] + [(def: #export ( operation) + (All [anchor expression directive output] + (-> ( output) + (Operation anchor expression directive output))) + (extension.lift + (phase.sub [(get@ [ #..state]) + (set@ [ #..state])] + operation)))] + + [lift-analysis #..analysis analysis.Operation] + [lift-synthesis #..synthesis synthesis.Operation] + [lift-generation #..generation (generation.Operation anchor expression directive)] + ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux new file mode 100644 index 000000000..334be5331 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/generation.lux @@ -0,0 +1,300 @@ +(.module: + [lux (#- Module) + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." name ("#@." equivalence)] + ["." text + ["%" format (#+ format)]] + [collection + ["." row (#+ Row)] + ["." dictionary (#+ Dictionary)] + ["." list ("#@." functor)]]]] + [// + [synthesis (#+ Synthesis)] + [phase + ["." extension]] + [/// + ["." phase] + [meta + [archive + [descriptor (#+ Module)]]]]]) + +(type: #export Registry + (Dictionary Name Text)) + +(exception: #export (cannot-interpret {error Text}) + (exception.report + ["Error" error])) + +(exception: #export (unknown-lux-name {name Name} {registry Registry}) + (exception.report + ["Name" (%.name name)] + ["Registry" (|> registry + dictionary.keys + (list.sort (:: name.order <)) + (list@map %.name) + (text.join-with text.new-line))])) + +(exception: #export (cannot-overwrite-lux-name {lux-name Name} + {old-host-name Text} + {new-host-name Text}) + (exception.report + ["Lux Name" (%.name lux-name)] + ["Old Host Name" old-host-name] + ["New Host Name" new-host-name])) + +(template [] + [(exception: #export ( {name Name}) + (exception.report + ["Output" (%.name name)]))] + + [cannot-overwrite-output] + [no-buffer-for-saving-code] + ) + +(type: #export Context + {#scope-name Text + #inner-functions Nat}) + +(signature: #export (Host expression directive) + (: (-> Text expression (Try Any)) + evaluate!) + (: (-> Text directive (Try Any)) + execute!) + (: (-> Name expression (Try [Text Any directive])) + define!)) + +(type: #export (Buffer directive) (Row [Name directive])) +(type: #export (Output directive) (Row [Module (Buffer directive)])) + +(type: #export (State anchor expression directive) + {#context Context + #anchor (Maybe anchor) + #host (Host expression directive) + #buffer (Maybe (Buffer directive)) + #output (Output directive) + #counter Nat + #name-cache Registry}) + +(template [ ] + [(type: #export ( anchor expression directive) + ( (State anchor expression directive) Synthesis expression))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(def: #export (fresh-context scope-name) + (-> Text Context) + {#scope-name scope-name + #inner-functions 0}) + +(def: #export (state host) + (All [anchor expression directive] + (-> (Host expression directive) + (..State anchor expression directive))) + {#context (..fresh-context "") + #anchor #.None + #host host + #buffer #.None + #output row.empty + #counter 0 + #name-cache (dictionary.new name.hash)}) + +(def: #export (with-specific-context specific-scope expr) + (All [anchor expression directive output] + (-> Text + (Operation anchor expression directive output) + (Operation anchor expression directive output))) + (function (_ [bundle state]) + (let [old (get@ #context state)] + (case (expr [bundle (set@ #context (..fresh-context specific-scope) state)]) + (#try.Success [[bundle' state'] + output]) + (#try.Success [[bundle' (set@ #context old state')] + output]) + + (#try.Failure error) + (#try.Failure error))))) + +(def: #export (with-context expr) + (All [anchor expression directive output] + (-> (Operation anchor expression directive output) + (Operation anchor expression directive [Text output]))) + (function (_ [bundle state]) + (let [[old-scope old-inner] (get@ #context state) + new-scope (format old-scope "$c" (%.nat old-inner))] + (case (expr [bundle (set@ #context (..fresh-context new-scope) state)]) + (#try.Success [[bundle' state'] output]) + (#try.Success [[bundle' (set@ #context {#scope-name old-scope + #inner-functions (inc old-inner)} + state')] + [new-scope output]]) + + (#try.Failure error) + (#try.Failure error))))) + +(def: #export context + (All [anchor expression directive] + (Operation anchor expression directive Text)) + (extension.read (|>> (get@ #context) + (get@ #scope-name)))) + +(def: #export empty-buffer Buffer row.empty) + +(template [ + + ] + [(exception: #export ) + + (def: #export + (All [anchor expression directive output] ) + (function (_ body) + (function (_ [bundle state]) + (case (body [bundle (set@ (#.Some ) state)]) + (#try.Success [[bundle' state'] output]) + (#try.Success [[bundle' (set@ (get@ state) state')] + output]) + + (#try.Failure error) + (#try.Failure error))))) + + (def: #export + (All [anchor expression directive] + (Operation anchor expression directive )) + (function (_ (^@ stateE [bundle state])) + (case (get@ state) + (#.Some output) + (#try.Success [stateE output]) + + #.None + (exception.throw [])))) + + (def: #export ( value) + (All [anchor expression directive] + (-> (Operation anchor expression directive Any))) + (function (_ [bundle state]) + (#try.Success [[bundle (set@ (#.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 output + (All [anchor expression directive] + (Operation anchor expression directive (Output directive))) + (extension.read (get@ #output))) + +(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)) + +(template [ ] + [(def: #export ( label code) + (All [anchor expression directive] + (-> Text (Operation anchor expression directive Any))) + (function (_ (^@ state+ [bundle state])) + (case (:: (get@ #host state) label code) + (#try.Success output) + (#try.Success [state+ output]) + + (#try.Failure error) + (exception.throw cannot-interpret error))))] + + [evaluate! expression] + [execute! directive] + ) + +(def: #export (define! name code) + (All [anchor expression directive] + (-> Name expression (Operation anchor expression directive [Text Any directive]))) + (function (_ (^@ stateE [bundle state])) + (case (:: (get@ #host state) define! name code) + (#try.Success output) + (#try.Success [stateE output]) + + (#try.Failure error) + (exception.throw cannot-interpret error)))) + +(def: #export (save! execute? name code) + (All [anchor expression directive] + (-> Bit Name directive (Operation anchor expression directive Any))) + (do phase.monad + [label (..gensym "save") + _ (if execute? + (execute! label code) + (wrap [])) + ?buffer (extension.read (get@ #buffer))] + (case ?buffer + (#.Some buffer) + (if (row.any? (|>> product.left (name@= name)) buffer) + (phase.throw ..cannot-overwrite-output name) + (extension.update (set@ #buffer (#.Some (row.add [name code] buffer))))) + + #.None + (phase.throw no-buffer-for-saving-code name)))) + +(def: #export (save-buffer! target) + (All [anchor expression directive] + (-> Module (Operation anchor expression directive (Buffer directive)))) + (do phase.monad + [buffer ..buffer + _ (extension.update (update@ #output (row.add [target buffer])))] + (wrap buffer))) + +(def: #export (remember lux-name) + (All [anchor expression directive] + (-> Name (Operation anchor expression directive Text))) + (function (_ (^@ stateE [_ state])) + (let [cache (get@ #name-cache state)] + (case (dictionary.get lux-name cache) + (#.Some host-name) + (#try.Success [stateE host-name]) + + #.None + (exception.throw unknown-lux-name [lux-name cache]))))) + +(def: #export (learn lux-name host-name) + (All [anchor expression directive] + (-> Name Text (Operation anchor expression directive Any))) + (function (_ [bundle state]) + (let [cache (get@ #name-cache state)] + (case (dictionary.get lux-name cache) + #.None + (#try.Success [[bundle + (update@ #name-cache + (dictionary.put lux-name host-name) + state)] + []]) + + (#.Some old-host-name) + (exception.throw cannot-overwrite-lux-name [lux-name old-host-name host-name]))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux new file mode 100644 index 000000000..cd8a723b0 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux @@ -0,0 +1,133 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["ex" exception (#+ exception:)]] + [data + [text + ["%" format (#+ format)]]] + ["." macro]] + ["." / #_ + ["#." type] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." function] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + ["/" analysis (#+ Analysis Operation Phase) + ["#." macro (#+ Expander)]] + [/// + ["//" phase] + ["." reference]]]]]) + +(exception: #export (unrecognized-syntax {code Code}) + (ex.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 Cursor)) (Operation Analysis))) + (case code' + (^template [ ] + ( value) + ( value)) + ([#.Bit /primitive.bit] + [#.Nat /primitive.nat] + [#.Int /primitive.int] + [#.Rev /primitive.rev] + [#.Frac /primitive.frac] + [#.Text /primitive.text]) + + _ + (else code'))) + +(def: (compile|structure compile else code') + (-> Phase (Fix (-> (Code' (Ann Cursor)) (Operation Analysis)))) + (case code' + (^template [ ] + (^ (#.Form (list& [_ ( tag)] + values))) + (case values + (#.Cons value #.Nil) + ( compile tag value) + + _ + ( compile tag (` [(~+ values)])))) + ([#.Nat /structure.sum] + [#.Tag /structure.tagged-sum]) + + (#.Tag tag) + (/structure.tagged-sum compile tag (' [])) + + (^ (#.Tuple (list))) + /primitive.unit + + (^ (#.Tuple (list singleton))) + (compile singleton) + + (^ (#.Tuple elems)) + (/structure.product compile elems) + + (^ (#.Record pairs)) + (/structure.record compile pairs) + + _ + (else code'))) + +(def: (compile|others expander compile code') + (-> Expander Phase (-> (Code' (Ann Cursor)) (Operation Analysis))) + (case code' + (#.Identifier reference) + (/reference.reference reference) + + (^ (#.Form (list [_ (#.Record branches)] input))) + (/case.case compile input branches) + + (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) + (//extension.apply compile [extension-name extension-args]) + + (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function-name])] + [_ (#.Identifier ["" arg-name])]))] + body))) + (/function.function compile function-name arg-name body) + + (^ (#.Form (list& functionC argsC+))) + (do //.monad + [[functionT functionA] (/type.with-inference + (compile functionC))] + (case functionA + (#/.Reference (#reference.Constant def-name)) + (do @ + [?macro (//extension.lift (macro.find-macro def-name))] + (case ?macro + (#.Some macro) + (do @ + [expansion (//extension.lift (/macro.expand-one expander def-name macro argsC+))] + (compile expansion)) + + _ + (/function.apply compile functionT functionA functionC argsC+))) + + _ + (/function.apply compile functionT functionA functionC argsC+))) + + _ + (//.throw unrecognized-syntax [.dummy-cursor code']))) + +(def: #export (phase expander) + (-> Expander Phase) + (function (compile code) + (let [[cursor code'] code] + ## The cursor must be set in the state for the sake + ## of having useful error messages. + (/.with-cursor cursor + (compile|primitive (compile|structure compile (compile|others expander 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 new file mode 100644 index 000000000..a74613491 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux @@ -0,0 +1,321 @@ +(.module: + [lux (#- case) + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["ex" exception (#+ exception:)]] + [data + ["." product] + ["." maybe] + [number + ["n" nat]] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#@." fold monoid functor)]]] + ["." type + ["." check]] + ["." macro + ["." code]]] + ["." / #_ + ["#." coverage (#+ Coverage)] + ["/#" // #_ + ["#." scope] + ["#." type] + ["#." structure] + ["/#" // #_ + ["#." extension] + [// + ["/" analysis (#+ Pattern Analysis Operation Phase)] + [/// + ["#" phase]]]]]]) + +(exception: #export (cannot-match-with-pattern {type Type} {pattern Code}) + (ex.report ["Type" (%.type type)] + ["Pattern" (%.code pattern)])) + +(exception: #export (sum-has-no-case {case Nat} {type Type}) + (ex.report ["Case" (%.nat case)] + ["Type" (%.type type)])) + +(exception: #export (not-a-pattern {code Code}) + (ex.report ["Code" (%.code code)])) + +(exception: #export (cannot-simplify-for-pattern-matching {type Type}) + (ex.report ["Type" (%.type type)])) + +(exception: #export (non-exhaustive-pattern-matching {input Code} {branches (List [Code Code])} {coverage Coverage}) + (ex.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 cursor output next) + (All [a] (-> Type Type Cursor Pattern (Operation a) (Operation [Pattern a]))) + (/.with-cursor cursor + (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 + [cursor (#.Identifier ["" name])] + (/.with-cursor cursor + (do ///.monad + [outputA (//scope.with-local [name inputT] + next) + idx //scope.next-local] + (wrap [(#/.Bind idx) outputA]))) + + (^template [ ] + [cursor ] + (analyse-primitive inputT cursor (#/.Simple ) 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]) + + (^ [cursor (#.Tuple (list singleton))]) + (analyse-pattern #.None inputT singleton next) + + [cursor (#.Tuple sub-patterns)] + (/.with-cursor cursor + (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.zip2 (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.zip2 subs (list@compose prefix (list (code.tuple suffix))))) + + ## (n.= num-subs num-sub-patterns) + (list.zip2 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]] ((:coerce (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]) + ))) + + [cursor (#.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 [cursor (#.Tuple members)] next)) + + [cursor (#.Tag tag)] + (/.with-cursor cursor + (analyse-pattern #.None inputT (` ((~ pattern))) next)) + + (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))]) + (/.with-cursor cursor + (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)] + (.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)) + #let [right? (n.= (dec num-cases) idx) + lefts (if right? + (dec idx) + idx)]] + (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])))) + + (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) + (/.with-cursor cursor + (do ///.monad + [tag (///extension.lift (macro.normalize tag)) + [idx group variantT] (///extension.lift (macro.resolve-tag tag)) + _ (//type.with-env + (check.check inputT variantT))] + (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next))) + + _ + (/.throw not-a-pattern pattern) + )) + +(def: #export (case analyse inputC branches) + (-> Phase Code (List [Code Code]) (Operation Analysis)) + (.case branches + (#.Cons [patternH bodyH] branchesT) + (do ///.monad + [[inputT inputA] (//type.with-inference + (analyse inputC)) + outputH (analyse-pattern #.None inputT patternH (analyse bodyH)) + outputT (monad.map @ + (function (_ [patternT bodyT]) + (analyse-pattern #.None inputT patternT (analyse 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 new file mode 100644 index 000000000..ec76fb1f5 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux @@ -0,0 +1,371 @@ +(.module: + [lux #* + [abstract + equivalence + ["." monad (#+ do)]] + [control + ["." try (#+ Try) ("#@." monad)] + ["ex" exception (#+ exception:)]] + [data + ["." bit ("#@." equivalence)] + ["." maybe] + [number + ["n" nat]] + ["." text + ["%" format (#+ Format format)]] + [collection + ["." list ("#@." functor fold)] + ["." dictionary (#+ Dictionary)]]]] + ["." //// #_ + [// + ["/" 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 [] + (#/.Simple ( _)) + (////@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))) + +(structure: 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.zip2 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 new file mode 100644 index 000000000..7e367ee5c --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/function.lux @@ -0,0 +1,108 @@ +(.module: + [lux (#- function) + [abstract + monad] + [control + ["ex" exception (#+ exception:)]] + [data + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#@." fold monoid monad)]]] + ["." type + ["." check]] + ["." macro]] + ["." // #_ + ["#." scope] + ["#." type] + ["#." inference] + ["/#" // #_ + ["#." extension] + [// + ["/" analysis (#+ Analysis Operation Phase)] + [/// + ["#" phase]]]]]) + +(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.enumerate + (list@map (.function (_ [idx argC]) + (format (%.nat idx) " " (%.code argC)))) + (text.join-with text.new-line))])) + +(def: #export (function analyse function-name arg-name body) + (-> Phase Text Text Code (Operation Analysis)) + (do ///.monad + [functionT (///extension.lift macro.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 [ ] + ( _) + (do @ + [[_ instanceT] (//type.with-env )] + (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 (//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 body)) + + _ + (/.fail "") + ))))) + +(def: #export (apply analyse functionT functionA functionC argsC+) + (-> Phase Type Analysis Code (List Code) (Operation Analysis)) + (<| (/.with-stack cannot-apply [functionT functionC argsC+]) + (do ///.monad + [[applyT argsA+] (//inference.general 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 new file mode 100644 index 000000000..4510cf1dd --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux @@ -0,0 +1,297 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["ex" exception (#+ exception:)]] + [data + ["." maybe] + [number + ["n" nat]] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#@." functor)]]] + ["." type + ["." check]] + ["." macro]] + ["." // #_ + ["#." type] + ["/#" // #_ + ["#." extension] + [// + ["/" analysis (#+ Tag Analysis Operation Phase)] + [/// + ["#" phase ("#@." monad)]]]]]) + +(exception: #export (variant-tag-out-of-bounds {size Nat} {tag Tag} {type Type}) + (ex.report ["Tag" (%.nat tag)] + ["Variant size" (%.int (.int size))] + ["Variant type" (%.type type)])) + +(exception: #export (cannot-infer {type Type} {args (List Code)}) + (ex.report ["Type" (%.type type)] + ["Arguments" (|> args + list.enumerate + (list@map (function (_ [idx argC]) + (format text.new-line " " (%.nat idx) " " (%.code argC)))) + (text.join-with ""))])) + +(exception: #export (cannot-infer-argument {inferred Type} {argument Code}) + (ex.report ["Inferred Type" (%.type inferred)] + ["Argument" (%.code argument)])) + +(exception: #export (smaller-variant-than-expected {expected Nat} {actual Nat}) + (ex.report ["Expected" (%.int (.int expected))] + ["Actual" (%.int (.int actual))])) + +(template [] + [(exception: #export ( {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 [] + ( left right) + ( (replace parameter-idx replacement left) + (replace parameter-idx replacement right))) + ([#.Sum] + [#.Product] + [#.Function] + [#.Apply]) + + (#.Parameter idx) + (if (n.= parameter-idx idx) + replacement + type) + + (^template [] + ( env quantified) + ( (list@map (replace parameter-idx replacement) env) + (replace (n.+ 2 parameter-idx) replacement quantified))) + ([#.UnivQ] + [#.ExQ]) + + _ + type)) + +(def: (named-type cursor id) + (-> Cursor Nat Type) + (let [name (format "{New Type @ " (.cursor-description cursor) " " (%.nat id) "}")] + (#.Primitive name (list)))) + +(def: new-named-type + (Operation Type) + (do ///.monad + [cursor (///extension.lift macro.cursor) + [ex-id _] (//type.with-env check.existential)] + (wrap (named-type cursor 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 analyse inferT args) + (-> 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 analyse unnamedT args) + + (#.UnivQ _) + (do ///.monad + [[var-id varT] (//type.with-env check.var)] + (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) + + (#.ExQ _) + (do ///.monad + [[var-id varT] (//type.with-env check.var) + output (general 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 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 analyse outputT args') + argA (<| (/.with-stack cannot-infer-argument [inputT argC]) + (//type.with-type inputT) + (analyse 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 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 [] + ( left right) + ( (recur left) (recur right))) + ([#.Sum] [#.Product] [#.Function] [#.Apply]) + + (#.Parameter index) + (if (n.= target index) + sub + base) + + (^template [] + ( environment quantified) + ( (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 [] + ( env bodyT) + (do ///.monad + [bodyT+ (record' (n.+ 2 target) originalT bodyT)] + (wrap ( 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 [] + ( env bodyT) + (do ///.monad + [bodyT+ (recur (inc depth) bodyT)] + (wrap ( 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 new file mode 100644 index 000000000..1764dfdd6 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux @@ -0,0 +1,263 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + pipe + ["." try] + ["ex" exception (#+ exception:)]] + [data + ["." text ("#@." equivalence) + ["%" format (#+ format)]] + [collection + ["." list ("#@." fold functor)] + [dictionary + ["." plist]]]] + ["." macro]] + ["." /// #_ + ["#." extension] + [// + ["/" analysis (#+ Operation)] + [/// + ["#" phase]]]]) + +(type: #export Tag Text) + +(exception: #export (unknown-module {module Text}) + (ex.report ["Module" module])) + +(exception: #export (cannot-declare-tag-twice {module Text} {tag Text}) + (ex.report ["Module" module] + ["Tag" tag])) + +(template [] + [(exception: #export ( {tags (List Text)} {owner Type}) + (ex.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}) + (ex.report ["Definition" (%.name name)])) + +(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State}) + (ex.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}) + (ex.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 macro.current-module-name + self macro.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 macro.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 macro.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 macro.current-module-name + self macro.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]) state)))))) + +(def: #export (create hash name) + (-> Nat Text (Operation Any)) + (///extension.lift + (function (_ state) + (let [module (new hash)] + (#try.Success [(update@ #.modules + (plist.put name module) + 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 (macro.find-module name))] + (wrap [module output]))) + +(template [ ] + [(def: #export ( 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 module)) + state) + []]) + ((/.throw' can-only-change-state-of-active-module [module-name ]) + state))) + + #.None + ((/.throw' unknown-module module-name) state))))) + + (def: #export ( 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) + #1 + _ #0)]) + + #.None + ((/.throw' unknown-module module-name) state)))))] + + [set-active active? #.Active] + [set-compiled compiled? #.Compiled] + [set-cached cached? #.Cached] + ) + +(template [ ] + [(def: ( module-name) + (-> Text (Operation )) + (///extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (#try.Success [state (get@ 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 macro.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.enumerate 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 new file mode 100644 index 000000000..dfdb7e314 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/primitive.lux @@ -0,0 +1,32 @@ +(.module: + [lux (#- nat int rev) + [abstract + monad]] + ["." // #_ + ["#." type] + ["/#" // #_ + [// + ["/" analysis (#+ Analysis Operation)] + [/// + ["#" phase]]]]]) + +(template [ ] + [(def: #export ( value) + (-> (Operation Analysis)) + (do ///.monad + [_ (//type.infer )] + (wrap (#/.Primitive ( 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 new file mode 100644 index 000000000..950c6a360 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/reference.lux @@ -0,0 +1,84 @@ +(.module: + [lux #* + [abstract + monad] + [control + ["." exception (#+ exception:)]] + ["." macro] + [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 [ (wrap (|> def-name ///reference.constant #/.Reference))] + (do ///.monad + [constant (///extension.lift (macro.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 (macro.normalize def-name)) + current (///extension.lift macro.current-module-name)] + (if (text@= current ::module) + + (if exported? + (do @ + [imported! (///extension.lift (macro.imported-by? ::module current))] + (if imported! + + (/.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 macro.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 new file mode 100644 index 000000000..d68d3fed7 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux @@ -0,0 +1,207 @@ +(.module: + [lux #* + [abstract + monad] + [control + ["." try] + ["ex" exception (#+ exception:)]] + [data + ["." text ("#@." equivalence)] + ["." maybe ("#@." monad)] + ["." product] + [collection + ["." list ("#@." functor fold monoid)] + [dictionary + ["." plist]]]]] + ["." /// #_ + ["#." extension] + [// + ["/" analysis (#+ Operation Phase)] + [/// + ["." reference (#+ 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 (#reference.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 (#reference.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) + [(#reference.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])) + + _ + (ex.throw invalid-scope-alteration [])) + + (#try.Failure error) + (#try.Failure error))) + + _ + (ex.throw cannot-create-local-binding-without-a-scope [])) + )) + +(template [ ] + [(def: + (Bindings Text [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 + (ex.throw cannot-get-next-reference-when-there-is-no-scope []))))) + +(def: (ref-to-variable ref) + (-> Ref Variable) + (case ref + (#.Local register) + (#reference.Local register) + + (#.Captured register) + (#reference.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 new file mode 100644 index 000000000..ee4ebb40d --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux @@ -0,0 +1,364 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["ex" exception (#+ exception:)] + ["." state]] + [data + ["." name] + ["." product] + ["." maybe] + [number + ["n" nat]] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#@." functor)] + ["." dictionary (#+ Dictionary)]]] + ["." type + ["." check]] + ["." macro + ["." code]]] + ["." // #_ + ["#." type] + ["#." primitive] + ["#." inference] + ["/#" // #_ + ["#." extension] + [// + ["/" analysis (#+ Tag Analysis Operation Phase)] + [/// + ["#" phase]]]]]) + +(exception: #export (invalid-variant-type {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%.type type)] + ["Tag" (%.nat tag)] + ["Expression" (%.code code)])) + +(template [] + [(exception: #export ( {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 [] + [(exception: #export ( {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 [] + [(exception: #export ( {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 tag valueC) + (-> Phase Nat Code (Operation Analysis)) + (do ///.monad + [expectedT (///extension.lift macro.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) + type-size (list.size flat) + right? (n.= (dec type-size) + tag) + lefts (if right? + (dec tag) + tag)] + (case (list.nth tag flat) + (#.Some variant-type) + (do @ + [valueA (//type.with-type variant-type + (analyse valueC))] + (wrap (/.variant [lefts right? valueA]))) + + #.None + (/.throw //inference.variant-tag-out-of-bounds [type-size tag expectedT]))) + + (#.Named name unnamedT) + (//type.with-type unnamedT + (sum analyse tag valueC)) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (//type.with-type expectedT' + (sum analyse tag 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 [ ] + ( _) + (do @ + [[instance-id instanceT] (//type.with-env )] + (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + (sum analyse tag 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') + (sum analyse tag valueC)) + + _ + (/.throw invalid-variant-type [expectedT tag valueC]))) + + _ + (case (type.apply (list inputT) funT) + (#.Some outputT) + (//type.with-type outputT + (sum analyse tag valueC)) + + #.None + (/.throw not-a-quantified-type funT))) + + _ + (/.throw invalid-variant-type [expectedT tag valueC]))))) + +(def: (typed-product analyse members) + (-> Phase (List Code) (Operation Analysis)) + (do ///.monad + [expectedT (///extension.lift macro.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 (code.tuple membersC+)))) + + [_ (#.Cons memberC #.Nil)] + (//type.with-type (type.tuple membersT+) + (:: @ map (|>> list) (analyse memberC))) + + [(#.Cons memberT membersT+') (#.Cons memberC membersC+')] + (do @ + [memberA (//type.with-type memberT + (analyse memberC)) + memberA+ (recur membersT+' membersC+')] + (wrap (#.Cons memberA memberA+))) + + _ + (/.throw cannot-analyse-tuple [expectedT members]))))] + (wrap (/.tuple membersA+)))) + +(def: #export (product analyse membersC) + (-> Phase (List Code) (Operation Analysis)) + (do ///.monad + [expectedT (///extension.lift macro.expected-type)] + (/.with-stack cannot-analyse-tuple [expectedT membersC] + (case expectedT + (#.Product _) + (..typed-product analyse membersC) + + (#.Named name unnamedT) + (//type.with-type unnamedT + (product analyse membersC)) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (//type.with-type expectedT' + (product analyse membersC)) + + _ + ## Must do inference... + (do @ + [membersTA (monad.map @ (|>> analyse //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 [ ] + ( _) + (do @ + [[instance-id instanceT] (//type.with-env )] + (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + (product 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 analyse membersC)) + + _ + (/.throw invalid-tuple-type [expectedT membersC]))) + + _ + (case (type.apply (list inputT) funT) + (#.Some outputT) + (//type.with-type outputT + (product analyse membersC)) + + #.None + (/.throw not-a-quantified-type funT))) + + _ + (/.throw invalid-tuple-type [expectedT membersC]) + )))) + +(def: #export (tagged-sum analyse tag valueC) + (-> Phase Name Code (Operation Analysis)) + (do ///.monad + [tag (///extension.lift (macro.normalize tag)) + [idx group variantT] (///extension.lift (macro.resolve-tag tag)) + expectedT (///extension.lift macro.expected-type)] + (case expectedT + (#.Var _) + (do @ + [#let [case-size (list.size group)] + inferenceT (//inference.variant idx case-size variantT) + [inferredT valueA+] (//inference.general analyse inferenceT (list valueC)) + #let [right? (n.= (dec case-size) idx) + lefts (if right? + (dec idx) + idx)]] + (wrap (/.variant [lefts right? (|> valueA+ list.head maybe.assume)]))) + + _ + (..sum analyse idx 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 (macro.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 (macro.normalize head-k)) + [_ tag-set recordT] (///extension.lift (macro.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.zip2 tag-set tuple-range))] + idx->val (monad.fold @ + (function (_ [key val] idx->val) + (do @ + [key (///extension.lift (macro.normalize key))] + (case (dictionary.get key tag->idx) + (#.Some idx) + (if (dictionary.contains? idx idx->val) + (/.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 analyse members) + (-> Phase (List [Code Code]) (Operation Analysis)) + (case members + (^ (list)) + //primitive.unit + + (^ (list [_ singletonC])) + (analyse singletonC) + + _ + (do ///.monad + [members (normalize members) + [membersC recordT] (order members) + expectedT (///extension.lift macro.expected-type)] + (case expectedT + (#.Var _) + (do @ + [inferenceT (//inference.record recordT) + [inferredT membersA] (//inference.general analyse inferenceT membersC)] + (wrap (/.tuple membersA))) + + _ + (..product 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 new file mode 100644 index 000000000..1de24a1c0 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux @@ -0,0 +1,55 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." function] + ["." try]] + [type + ["." check (#+ Check)]] + ["." macro]] + ["." /// #_ + ["#." 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 macro.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 new file mode 100644 index 000000000..a6311eaf8 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/directive.lux @@ -0,0 +1,77 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." exception (#+ exception:)]] + [data + [text + ["%" format (#+ format)]] + [collection + ["." list ("#;." fold monoid)]]] + ["." macro]] + ["." // #_ + ["#." extension] + ["#." analysis + ["#/." type]] + ["/#" // #_ + ["/" directive (#+ Phase)] + ["#." analysis + ["#/." macro (#+ Expander)]] + [/// + [reference (#+)] + ["//" phase]]]]) + +(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 [ (as-is [|form-cursor| (#.Form (list& [|text-cursor| (#.Text "lux def module")] annotations))])] + (def: #export (phase expander) + (-> Expander Phase) + (let [analyze (//analysis.phase expander)] + (function (recur code) + (case code + (^ [_ (#.Form (list& [_ (#.Text name)] inputs))]) + (//extension.apply recur [name inputs]) + + (^ [_ (#.Form (list& macro inputs))]) + (do //.monad + [expansion (/.lift-analysis + (do @ + [macroA (//analysis/type.with-type Macro + (analyze macro))] + (case macroA + (^ (///analysis.constant macro-name)) + (do @ + [?macro (//extension.lift (macro.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& referrals)) + (|> (recur ) + (:: @ map (update@ #/.referrals (list;compose referrals)))) + + _ + (|> expansion + (monad.map @ recur) + (:: @ 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 new file mode 100644 index 000000000..a3e841912 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux @@ -0,0 +1,146 @@ +(.module: + [lux (#- Name) + [abstract + [monad (#+ do)]] + [control + ["." function] + ["." try (#+ Try)] + ["." exception (#+ exception:)]] + [data + ["." text ("#@." order) + ["%" format (#+ Format format)]] + [collection + ["." list ("#@." functor)] + ["." dictionary (#+ Dictionary)]]]] + [///// + ["//" phase]]) + +(type: #export Name Text) + +(type: #export (Extension i) + [Name (List i)]) + +(with-expansions [ (as-is (Dictionary Name (Handler s i o)))] + (type: #export (Handler s i o) + (-> Name + (//.Phase [ s] i o) + (//.Phase [ s] (List i) o))) + + (type: #export (Bundle s i o) + )) + +(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 (apply phase [name parameters]) + (All [s i o] + (-> (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) 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 new file mode 100644 index 000000000..0f38bce97 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis.lux @@ -0,0 +1,15 @@ +(.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/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux new file mode 100644 index 000000000..0b9c4de2f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux @@ -0,0 +1,198 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["" code (#+ Parser)]] + pipe] + [data + [collection + ["." array (#+ Array)] + ["." dictionary]]] + [type + ["." check]] + [target + ["_" js]]] + ["." // #_ + ["/" lux (#+ custom)] + ["/#" // + ["#." bundle] + ["/#" // ("#@." monad) + [analysis + [".A" type]] + ["/#" // #_ + ["#." analysis (#+ Analysis Operation Phase Handler Bundle)]]]]]) + +(def: array::new + Handler + (custom + [.any + (function (_ extension phase lengthC) + (do ////.monad + [lengthA (typeA.with-type Nat + (phase lengthC)) + [var-id varT] (typeA.with-env check.var) + _ (typeA.infer (type (Array varT)))] + (wrap (#/////analysis.Extension extension (list lengthA)))))])) + +(def: array::length + Handler + (custom + [.any + (function (_ extension phase arrayC) + (do ////.monad + [[var-id varT] (typeA.with-env check.var) + arrayA (typeA.with-type (type (Array varT)) + (phase arrayC)) + _ (typeA.infer Nat)] + (wrap (#/////analysis.Extension extension (list arrayA)))))])) + +(def: array::read + Handler + (custom + [(<>.and .any .any) + (function (_ extension phase [indexC arrayC]) + (do ////.monad + [indexA (typeA.with-type Nat + (phase indexC)) + [var-id varT] (typeA.with-env check.var) + arrayA (typeA.with-type (type (Array varT)) + (phase arrayC)) + _ (typeA.infer varT)] + (wrap (#/////analysis.Extension extension (list indexA arrayA)))))])) + +(def: array::write + Handler + (custom + [($_ <>.and .any .any .any) + (function (_ extension phase [indexC valueC arrayC]) + (do ////.monad + [indexA (typeA.with-type Nat + (phase indexC)) + [var-id varT] (typeA.with-env check.var) + valueA (typeA.with-type varT + (phase valueC)) + arrayA (typeA.with-type (type (Array varT)) + (phase arrayC)) + _ (typeA.infer (type (Array varT)))] + (wrap (#/////analysis.Extension extension (list indexA valueA arrayA)))))])) + +(def: array::delete + Handler + (custom + [($_ <>.and .any .any) + (function (_ extension phase [indexC arrayC]) + (do ////.monad + [indexA (typeA.with-type Nat + (phase indexC)) + [var-id varT] (typeA.with-env check.var) + arrayA (typeA.with-type (type (Array varT)) + (phase arrayC)) + _ (typeA.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 .any (.tuple (<>.some .any))) + (function (_ extension phase [constructorC inputsC]) + (do ////.monad + [constructorA (typeA.with-type Any + (phase constructorC)) + inputsA (monad.map @ (|>> phase (typeA.with-type Any)) inputsC) + _ (typeA.infer .Any)] + (wrap (#/////analysis.Extension extension (list& constructorA inputsA)))))])) + +(def: object::get + Handler + (custom + [($_ <>.and .text .any) + (function (_ extension phase [fieldC objectC]) + (do ////.monad + [objectA (typeA.with-type Any + (phase objectC)) + _ (typeA.infer .Any)] + (wrap (#/////analysis.Extension extension (list (/////analysis.text fieldC) + objectA)))))])) + +(def: object::do + Handler + (custom + [($_ <>.and .text .any (.tuple (<>.some .any))) + (function (_ extension phase [methodC objectC inputsC]) + (do ////.monad + [objectA (typeA.with-type Any + (phase objectC)) + inputsA (monad.map @ (|>> phase (typeA.with-type Any)) inputsC) + _ (typeA.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 + [.text + (function (_ extension phase name) + (do ////.monad + [_ (typeA.infer Any)] + (wrap (#/////analysis.Extension extension (list (/////analysis.text name))))))])) + +(def: js::apply + Handler + (custom + [($_ <>.and .any (<>.some .any)) + (function (_ extension phase [abstractionC inputsC]) + (do ////.monad + [abstractionA (typeA.with-type Any + (phase abstractionC)) + inputsA (monad.map @ (|>> phase (typeA.with-type Any)) inputsC) + _ (typeA.infer Any)] + (wrap (#/////analysis.Extension extension (list& abstractionA inputsA)))))])) + +(def: js::type-of + Handler + (custom + [.any + (function (_ extension phase objectC) + (do ////.monad + [objectA (typeA.with-type Any + (phase objectC)) + _ (typeA.infer .Text)] + (wrap (#/////analysis.Extension extension (list objectA)))))])) + +(def: #export bundle + Bundle + (<| (///bundle.prefix "js") + (|> ///bundle.empty + (///bundle.install "constant" js::constant) + (///bundle.install "apply" js::apply) + (///bundle.install "type-of" js::type-of) + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + ))) 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 new file mode 100644 index 000000000..aaa37ccfc --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -0,0 +1,1997 @@ +(.module: + [lux (#- Type Module primitive type char int) + ["." host (#+ import:)] + ["." macro] + [abstract + ["." monad (#+ do)]] + [control + pipe + ["." try (#+ Try) ("#@." monad)] + ["." exception (#+ exception:)] + ["<>" parser + ["" code (#+ Parser)] + ["" text]]] + [data + ["." maybe] + ["." product] + [number + ["n" nat]] + ["." text ("#@." equivalence) + ["%" format (#+ format)]] + [collection + ["." list ("#@." fold monad monoid)] + ["." array] + ["." dictionary (#+ Dictionary)]]] + ["." type + ["." check (#+ Check) ("#@." monad)]] + [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)]]]]] + ["." // #_ + ["#." lux (#+ custom)] + ["/#" // + ["#." bundle] + ["/#" // #_ + [analysis + [".A" type] + [".A" inference] + ["." scope]] + ["/#" // #_ + ["#." analysis (#+ Analysis Operation Phase Handler Bundle)] + ["#." synthesis] + [/// + [reference (#+)] + ["." phase ("#@." monad)] + [meta + [archive + [descriptor (#+ Module)]]]]]]]]) + +(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/host.jvm.lux ASAP +(template [ ] + [(def: #export .Type (#.Primitive #.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 .text .text)) + +(type: Method-Signature + {#method .Type + #exceptions (List .Type)}) + +(template [] + [(exception: #export ( {type .Type}) + (exception.report + ["Type" (%.type type)]))] + + [non-object] + [non-array] + [non-parameter] + [non-jvm-type] + ) + +(template [] + [(exception: #export ( {class External}) + (exception.report + ["Class/type" (%.text class)]))] + + [non-interface] + [non-throwable] + [primitives-are-not-objects] + ) + +(exception: #export (cannot-set-a-final-field {field Text} {class External}) + (exception.report + ["Field" (%.text field)] + ["Class" (%.text class)])) + +(template [] + [(exception: #export ( {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 [] + [(exception: #export ( {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 [ ] + [(def: + Bundle + (<| (///bundle.prefix (reflection.reflection )) + (|> ///bundle.empty + (///bundle.install "+" (//lux.binary )) + (///bundle.install "-" (//lux.binary )) + (///bundle.install "*" (//lux.binary )) + (///bundle.install "/" (//lux.binary )) + (///bundle.install "%" (//lux.binary )) + (///bundle.install "=" (//lux.binary Bit)) + (///bundle.install "<" (//lux.binary Bit)) + (///bundle.install "and" (//lux.binary )) + (///bundle.install "or" (//lux.binary )) + (///bundle.install "xor" (//lux.binary )) + (///bundle.install "shl" (//lux.binary Integer )) + (///bundle.install "shr" (//lux.binary Integer )) + (///bundle.install "ushr" (//lux.binary Integer )) + )))] + + [bundle::int reflection.int ..long] + [bundle::long reflection.long ..long] + ) + +(template [ ] + [(def: + Bundle + (<| (///bundle.prefix (reflection.reflection )) + (|> ///bundle.empty + (///bundle.install "+" (//lux.binary )) + (///bundle.install "-" (//lux.binary )) + (///bundle.install "*" (//lux.binary )) + (///bundle.install "/" (//lux.binary )) + (///bundle.install "%" (//lux.binary )) + (///bundle.install "=" (//lux.binary Bit)) + (///bundle.install "<" (//lux.binary 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 + (.run jvm-parser.array) + phase.lift))) + +(def: (primitive-array-length-handler primitive-type) + (-> (Type Primitive) Handler) + (function (_ extension-name analyse args) + (case args + (^ (list arrayC)) + (do phase.monad + [_ (typeA.infer ..int) + arrayA (typeA.with-type (#.Primitive (|> (jvm.array primitive-type) + ..reflection) + (list)) + (analyse 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 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 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 args) + (case args + (^ (list lengthC)) + (do phase.monad + [lengthA (typeA.with-type ..int + (analyse 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 args) + (case args + (^ (list lengthC)) + (do phase.monad + [lengthA (typeA.with-type ..int + (analyse lengthC)) + expectedT (///.lift macro.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 [] + [(text@= (..reflection ) 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 [] + ( id) + (phase@wrap (jvm.class ..object-class (list)))) + ([#.Var] + [#.Ex]) + + (^template [] + ( 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 [] + [(text@= (..reflection ) name) + (phase@wrap )] + + [jvm.boolean] + [jvm.byte] + [jvm.short] + [jvm.int] + [jvm.long] + [jvm.float] + [jvm.double] + [jvm.char])) + + (~~ (template [] + [(text@= (..reflection (jvm.array )) name) + (phase@wrap (jvm.array ))] + + [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 [] + ( 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.contains? name ..boxes) + (/////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 args) + (case args + (^ (list idxC arrayC)) + (do phase.monad + [_ (typeA.infer lux-type) + idxA (typeA.with-type ..int + (analyse idxC)) + arrayA (typeA.with-type (#.Primitive (|> (jvm.array jvm-type) ..reflection) + (list)) + (analyse 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 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 arrayC)) + varT (typeA.with-env + (check.clean varT)) + arrayJT (jvm-array-type (.type (array.Array varT))) + idxA (typeA.with-type ..int + (analyse 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 args) + (case args + (^ (list idxC valueC arrayC)) + (do phase.monad + [_ (typeA.infer array-type) + idxA (typeA.with-type ..int + (analyse idxC)) + valueA (typeA.with-type lux-type + (analyse valueC)) + arrayA (typeA.with-type array-type + (analyse 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 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 arrayC)) + varT (typeA.with-env + (check.clean varT)) + arrayJT (jvm-array-type (.type (array.Array varT))) + idxA (typeA.with-type ..int + (analyse idxC)) + valueA (typeA.with-type varT + (analyse 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 args) + (case args + (^ (list)) + (do phase.monad + [expectedT (///.lift macro.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 args) + (case args + (^ (list objectC)) + (do phase.monad + [_ (typeA.infer Bit) + [objectT objectA] (typeA.with-inference + (analyse 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 args) + (case args + (^ (list monitorC exprC)) + (do phase.monad + [[monitorT monitorA] (typeA.with-inference + (analyse monitorC)) + _ (check-object monitorT) + exprA (analyse 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 args) + (case args + (^ (list exceptionC)) + (do phase.monad + [_ (typeA.infer Nothing) + [exceptionT exceptionA] (typeA.with-inference + (analyse 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 args) + (case args + (^ (list classC)) + (case classC + [_ (#.Text class)] + (do phase.monad + [_ (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 .text .any) + (function (_ extension-name analyse [sub-class objectC]) + (do phase.monad + [_ (typeA.infer Bit) + [objectT objectA] (typeA.with-inference + (analyse 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)))))])) + +(import: #long java/lang/Object + (equals [java/lang/Object] boolean)) + +(import: #long java/lang/reflect/Type) + +(import: #long (java/lang/reflect/TypeVariable d) + (getName [] java/lang/String) + (getBounds [] [java/lang/reflect/Type])) + +(import: #long java/lang/reflect/Modifier + (#static isStatic [int] boolean) + (#static isFinal [int] boolean) + (#static isInterface [int] boolean) + (#static isAbstract [int] boolean)) + +(import: #long 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: #long (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: #long (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])) + +(template [ ] + [(def: ( mapping typeJ) + (-> Mapping (Type ) (Operation .Type)) + (case (|> typeJ ..signature (.run ( 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 (:coerce java/lang/reflect/Type (host.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 args) + (case args + (^ (list fromC)) + (do phase.monad + [toT (///.lift macro.expected-type) + to-name (:: @ map ..reflection (check-jvm toT)) + [fromT fromA] (typeA.with-inference + (analyse fromC)) + from-name (:: @ map ..reflection (check-jvm fromT)) + can-cast? (: (Operation Bit) + (`` (cond (~~ (template [ ] + [(let [=primitive (reflection.reflection )] + (or (and (text@= =primitive from-name) + (or (text@= to-name) + (text@= =primitive to-name))) + (and (text@= 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.contains? from-name ..boxes))) + _ (phase.assert ..primitives-are-not-objects [to-name] + (not (dictionary.contains? to-name ..boxes))) + 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 + (/////analysis.throw cannot-cast [fromT toT fromC])) + )))))))] + (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 [class field]) + (do phase.monad + [[final? fieldJT] (phase.lift + (do try.monad + [class (reflection!.load class)] + (reflection!.static-field field class))) + 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 .any) + (function (_ extension-name analyse [[class field] valueC]) + (do phase.monad + [_ (typeA.infer Any) + [final? fieldJT] (phase.lift + (do try.monad + [class (reflection!.load class)] + (reflection!.static-field field class))) + fieldT (reflection-type luxT.fresh fieldJT) + _ (phase.assert ..cannot-set-a-final-field [class field] + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (<| (#/////analysis.Extension extension-name) + (list (/////analysis.text class) + (/////analysis.text field) + valueA)))))])) + +(def: get::virtual + Handler + (..custom + [($_ <>.and ..member .any) + (function (_ extension-name analyse [[class field] objectC]) + (do phase.monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + [mapping fieldJT] (phase.lift + (do try.monad + [class (reflection!.load class) + [final? fieldJT] (reflection!.virtual-field field class) + mapping (reflection!.correspond class objectT)] + (wrap [mapping fieldJT]))) + 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 .any .any) + (function (_ extension-name analyse [[class field] valueC objectC]) + (do phase.monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (typeA.infer objectT) + [final? mapping fieldJT] (phase.lift + (do try.monad + [class (reflection!.load class) + [final? fieldJT] (reflection!.virtual-field field class) + mapping (reflection!.correspond class objectT)] + (wrap [final? mapping fieldJT]))) + fieldT (reflection-type mapping fieldJT) + _ (phase.assert cannot-set-a-final-field [class field] + (not final?)) + valueA (typeA.with-type fieldT + (analyse 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? (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.zip2 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.zip2 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.enumerate + (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 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 exceptionsT])))) + +(type: Evaluation + (#Pass Method-Signature) + (#Hint Method-Signature)) + +(template [ ] + [(def: + (-> Evaluation (Maybe Method-Signature)) + (|>> (case> ( output) + (#.Some output) + + _ + #.None)))] + + [pass! #Pass] + [hint! #Hint] + ) + +(template [ ] + [(def: + (-> (List (Type Var))) + (|>> + 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.zip2 (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.search-all pass! candidates) + (#.Cons method #.Nil) + (wrap method) + + #.Nil + (/////analysis.throw ..no-candidates [class-name method-name inputsJT (list.search-all hint! candidates)]) + + candidates + (/////analysis.throw ..too-many-candidates [class-name method-name inputsJT candidates])))) + +(def: constructor-method "") + +(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.search-all pass! candidates) + (#.Cons constructor #.Nil) + (wrap constructor) + + #.Nil + (/////analysis.throw ..no-candidates [class-name ..constructor-method inputsJT (list.search-all hint! candidates)]) + + candidates + (/////analysis.throw ..too-many-candidates [class-name ..constructor-method inputsJT candidates])))) + +(template [ ] + [(def: #export + (Parser (Type )) + (.embed .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)) + (.tuple (<>.and ..type .any))) + +(def: (decorate-inputs typesT inputsA) + (-> (List (Type Value)) (List Analysis) (List Analysis)) + (|> inputsA + (list.zip2 (list@map (|>> ..signature /////analysis.text) typesT)) + (list@map (function (_ [type value]) + (/////analysis.tuple (list type value)))))) + +(def: type-vars (.tuple (<>.some ..var))) + +(def: invoke::static + Handler + (..custom + [($_ <>.and ..type-vars ..member ..type-vars (<>.some ..input)) + (function (_ extension-name analyse [class-tvars [class method] method-tvars argsTC]) + (do phase.monad + [#let [argsT (list@map product.left argsTC)] + [methodT exceptionsT] (method-candidate class-tvars class method-tvars method #Static argsT) + [outputT argsA] (inferenceA.general 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 .any (<>.some ..input)) + (function (_ extension-name analyse [class-tvars [class method] method-tvars objectC argsTC]) + (do phase.monad + [#let [argsT (list@map product.left argsTC)] + [methodT exceptionsT] (method-candidate class-tvars class method-tvars method #Virtual argsT) + [outputT allA] (inferenceA.general 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 .any (<>.some ..input)) + (function (_ extension-name analyse [class-tvars [class method] method-tvars objectC argsTC]) + (do phase.monad + [#let [argsT (list@map product.left argsTC)] + [methodT exceptionsT] (method-candidate class-tvars class method-tvars method #Special argsT) + [outputT argsA] (inferenceA.general 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 .any (<>.some ..input)) + (function (_ extension-name analyse [class-tvars [class-name method] method-tvars objectC argsTC]) + (do phase.monad + [#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 exceptionsT] (method-candidate class-tvars class-name method-tvars method #Interface argsT) + [outputT allA] (inferenceA.general 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 .text ..type-vars (<>.some ..input)) + (function (_ extension-name analyse [class-tvars class method-tvars argsTC]) + (do phase.monad + [#let [argsT (list@map product.left argsTC)] + [methodT exceptionsT] (constructor-candidate class-tvars class method-tvars argsT) + [outputT argsA] (inferenceA.general 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)) + (.tuple (<>.and .text .any))) + +(type: #export (Annotation a) + [Text (List (Annotation-Parameter a))]) + +(def: #export annotation + (Parser (Annotation Code)) + (.form (<>.and .text (<>.some ..annotation-parameter)))) + +(def: #export argument + (Parser Argument) + (.tuple (<>.and .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 [ ] + [(def: + (-> (Type ) 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 [ ] + [(def: + (-> (java/lang/Class java/lang/Object) + (Try (List [Text (Type Method)]))) + (|>> java/lang/Class::getDeclaredMethods + array.to-list + + (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 [ ] + [(def: + (-> (List (Type Class)) (Try (List [Text (Type Method)]))) + (|>> (monad.map try.monad (|>> ..reflection reflection!.load)) + (try@map (monad.map try.monad )) + try@join + (try@map list@join)))] + + [all-abstract-methods ..abstract-methods] + [all-methods ..methods] + ) + +(template [] + [(exception: #export ( {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 + (.text! ..public-tag) + (.text! ..private-tag) + (.text! ..protected-tag) + (.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)) + (<| .form + (<>.after (.text! ..constructor-tag)) + ($_ <>.and + ..visibility + .bit + (.tuple (<>.some ..annotation)) + (.tuple (<>.some ..var)) + (.tuple (<>.some ..class)) + .text + (.tuple (<>.some ..argument)) + (.tuple (<>.some ..input)) + .any))) + +(def: #export (analyse-constructor-method analyse selfT mapping method) + (-> Phase .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 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 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 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 + (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)) + (<| .form + (<>.after (.text! ..virtual-tag)) + ($_ <>.and + .text + ..visibility + .bit + .bit + (.tuple (<>.some ..annotation)) + (.tuple (<>.some ..var)) + .text + (.tuple (<>.some ..argument)) + ..return + (.tuple (<>.some ..class)) + .any))) + +(def: #export (analyse-virtual-method analyse selfT mapping method) + (-> Phase .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 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 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 + (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)) + (<| .form + (<>.after (.text! ..static-tag)) + ($_ <>.and + .text + ..visibility + .bit + (.tuple (<>.some ..annotation)) + (.tuple (<>.some ..var)) + (.tuple (<>.some ..class)) + (.tuple (<>.some ..argument)) + ..return + .any))) + +(def: #export (analyse-static-method analyse mapping method) + (-> Phase 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 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 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 + (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)) + (<| .form + (<>.after (.text! ..overriden-tag)) + ($_ <>.and + ..class + .text + .bit + (.tuple (<>.some ..annotation)) + (.tuple (<>.some ..var)) + .text + (.tuple (<>.some ..argument)) + ..return + (.tuple (<>.some ..class)) + .any + ))) + +(def: #export (analyse-overriden-method analyse selfT mapping method) + (-> Phase .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 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 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 + (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.zip2 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 + (.tuple (<>.some ..var)) + ..class + (.tuple (<>.some ..class)) + (.tuple (<>.some ..input)) + (.tuple (<>.some ..overriden-method-definition))) + (function (_ extension-name analyse [parameters + super-class + super-interfaces + constructor-args + methods]) + (do phase.monad + [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)] + name (///.lift (do macro.monad + [where macro.current-module-name + id macro.count] + (wrap (..anonymous-class-name where id)))) + 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)) + #let [selfT (inheritance-relationship-type (#.Primitive name (list)) + super-classT + super-interfaceT+)] + constructor-argsA+ (monad.map @ (function (_ [type term]) + (do @ + [argT (reflection-type mapping type) + termA (typeA.with-type argT + (analyse term))] + (wrap [type termA]))) + constructor-args) + methodsA (monad.map @ (analyse-overriden-method analyse 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)] + _ (typeA.infer selfT) + _ (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 (/////analysis.text name) + (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/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux new file mode 100644 index 000000000..5a813c253 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux @@ -0,0 +1,289 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + [io (#+ IO)] + ["." try] + ["." exception (#+ exception:)] + ["<>" parser + ["" code (#+ Parser)]]] + [data + ["." maybe] + [number + ["n" nat]] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#@." functor)] + ["." dictionary (#+ Dictionary)]]] + [type + ["." check]] + ["." macro]] + ["." /// + ["#." bundle] + ["/#" // #_ + [analysis + [".A" type] + [".A" case] + [".A" function]] + [// + ["#." analysis (#+ Analysis Operation Phase Handler Bundle) + [evaluation (#+ Eval)]] + [/// + ["#" phase]]]]]) + +(def: #export (custom [syntax handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase s (Operation Analysis))] + Handler)) + (function (_ extension-name analyse args) + (case (.run syntax args) + (#try.Success inputs) + (handler extension-name analyse 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 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 argC))) + (list.zip2 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 .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 + .any + (.tuple (<>.some (<>.and (.tuple (<>.many ..text-char)) + .any))) + .any) + (function (_ extension-name phase [input conditionals else]) + (do ////.monad + [input (typeA.with-type text.Char + (phase input)) + expectedT (///.lift macro.expected-type) + conditionals (monad.map @ (function (_ [cases branch]) + (do @ + [branch (typeA.with-type expectedT + (phase branch))] + (wrap [cases branch]))) + conditionals) + else (typeA.with-type expectedT + (phase 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 args) + (do ////.monad + [[var-id varT] (typeA.with-env check.var)] + ((binary varT varT Bit extension-name) + analyse 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 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 (IO varT)) + (analyse 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 argsC+) + (case argsC+ + (^ (list [_ (#.Text module-name)] exprC)) + (////analysis.with-current-module module-name + (analyse exprC)) + + _ + (////analysis.throw ///.invalid-syntax [extension-name %.code argsC+])))) + +(def: (lux::check eval) + (-> Eval Handler) + (function (_ extension-name analyse args) + (case args + (^ (list typeC valueC)) + (do ////.monad + [count (///.lift macro.count) + actualT (:: @ map (|>> (:coerce Type)) + (eval count Type typeC)) + _ (typeA.infer actualT)] + (typeA.with-type actualT + (analyse valueC))) + + _ + (////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: (lux::coerce eval) + (-> Eval Handler) + (function (_ extension-name analyse args) + (case args + (^ (list typeC valueC)) + (do ////.monad + [count (///.lift macro.count) + actualT (:: @ map (|>> (:coerce Type)) + (eval count Type typeC)) + _ (typeA.infer actualT) + [valueT valueA] (typeA.with-inference + (analyse valueC))] + (wrap valueA)) + + _ + (////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: (caster input output) + (-> Type Type Handler) + (function (_ extension-name analyse args) + (case args + (^ (list valueC)) + (do ////.monad + [_ (typeA.infer output)] + (typeA.with-type input + (analyse valueC))) + + _ + (////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(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 "check" (lux::check eval)) + (///bundle.install "coerce" (lux::coerce eval)) + (///bundle.install "macro" (..caster .Macro' .Macro)) + (///bundle.install "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)) + (///bundle.install "current-time" (nullary Int))))) + +(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 "logical-right-shift" (binary Nat I64* I64)) + (///bundle.install "arithmetic-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 "smallest" (nullary Frac)) + (///bundle.install "min" (nullary Frac)) + (///bundle.install "max" (nullary Frac)) + (///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/bundle.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux new file mode 100644 index 000000000..4816993f3 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux @@ -0,0 +1,28 @@ +(.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 new file mode 100644 index 000000000..4db15e8e6 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux @@ -0,0 +1,303 @@ +(.module: + [lux (#- Type Definition) + ["." host] + [abstract + ["." monad (#+ do)]] + [control + [pipe (#+ case>)] + ["<>" parser ("#@." monad) + ["" code (#+ Parser)] + ["" text]]] + [data + ["." product] + [number + ["." i32]] + [text + ["%" format (#+ format)]] + [collection + ["." list ("#@." functor fold)] + ["." dictionary] + ["." row]]] + [type + ["." check (#+ Check)]] + [macro + ["." template]] + [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] + ["." directive (#+ Handler Bundle)] + ["." phase + [analysis + [".A" type]] + ["." generation + [jvm + [runtime (#+ Anchor Definition)]]] + ["." extension + ["." bundle] + [analysis + ["." jvm]] + [directive + ["/" lux]]]]]]]) + +(type: Operation + (directive.Operation Anchor (Bytecode Any) Definition)) + +(def: signature (|>> type.signature signature.signature)) + +(type: Declaration + [Text (List (Type Var))]) + +(def: declaration + (Parser Declaration) + (.form (<>.and .text (<>.some jvm.var)))) + +(def: visibility + (Parser (Modifier field.Field)) + (`` ($_ <>.either + (~~ (template [