From b7b0dd9bd952ede4710da157b40304d714229e04 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 17 Jun 2018 22:27:40 -0400 Subject: - Heavy refactoring to integrate extensions better with the rest of the compiler. --- stdlib/source/lux/lang.lux | 112 +- stdlib/source/lux/lang/analysis.lux | 209 ---- stdlib/source/lux/lang/analysis/case.lux | 295 ----- stdlib/source/lux/lang/analysis/case/coverage.lux | 322 ----- stdlib/source/lux/lang/analysis/expression.lux | 122 -- stdlib/source/lux/lang/analysis/function.lux | 104 -- stdlib/source/lux/lang/analysis/inference.lux | 256 ---- stdlib/source/lux/lang/analysis/primitive.lux | 28 - stdlib/source/lux/lang/analysis/reference.lux | 56 - stdlib/source/lux/lang/analysis/structure.lux | 358 ------ stdlib/source/lux/lang/analysis/type.lux | 60 - stdlib/source/lux/lang/compiler.lux | 57 +- stdlib/source/lux/lang/compiler/analysis.lux | 281 +++++ stdlib/source/lux/lang/compiler/analysis/case.lux | 290 +++++ .../lux/lang/compiler/analysis/case/coverage.lux | 321 +++++ .../lux/lang/compiler/analysis/expression.lux | 121 ++ .../source/lux/lang/compiler/analysis/function.lux | 103 ++ .../lux/lang/compiler/analysis/inference.lux | 256 ++++ .../lux/lang/compiler/analysis/primitive.lux | 28 + .../lux/lang/compiler/analysis/reference.lux | 57 + .../lux/lang/compiler/analysis/structure.lux | 358 ++++++ stdlib/source/lux/lang/compiler/analysis/type.lux | 61 + stdlib/source/lux/lang/compiler/extension.lux | 68 ++ .../lux/lang/compiler/extension/analysis.lux | 18 + .../lang/compiler/extension/analysis/common.lux | 396 +++++++ .../lang/compiler/extension/analysis/host.jvm.lux | 1224 ++++++++++++++++++++ .../source/lux/lang/compiler/extension/bundle.lux | 31 + .../lux/lang/compiler/extension/synthesis.lux | 9 + .../lux/lang/compiler/extension/translation.lux | 9 + stdlib/source/lux/lang/compiler/init.lux | 51 + stdlib/source/lux/lang/compiler/synthesis.lux | 241 ++++ stdlib/source/lux/lang/compiler/synthesis/case.lux | 177 +++ .../lux/lang/compiler/synthesis/expression.lux | 99 ++ .../lux/lang/compiler/synthesis/function.lux | 130 +++ stdlib/source/lux/lang/compiler/synthesis/loop.lux | 285 +++++ stdlib/source/lux/lang/compiler/translation.lux | 164 +++ .../lang/compiler/translation/scheme/case.jvm.lux | 170 +++ .../compiler/translation/scheme/expression.jvm.lux | 53 + .../compiler/translation/scheme/extension.jvm.lux | 32 + .../translation/scheme/extension/common.jvm.lux | 389 +++++++ .../compiler/translation/scheme/function.jvm.lux | 85 ++ .../lang/compiler/translation/scheme/loop.jvm.lux | 39 + .../compiler/translation/scheme/primitive.jvm.lux | 22 + .../compiler/translation/scheme/reference.jvm.lux | 54 + .../compiler/translation/scheme/runtime.jvm.lux | 362 ++++++ .../compiler/translation/scheme/structure.jvm.lux | 29 + stdlib/source/lux/lang/extension.lux | 131 --- stdlib/source/lux/lang/extension/analysis.lux | 16 - .../source/lux/lang/extension/analysis/common.lux | 444 ------- .../lux/lang/extension/analysis/host.jvm.lux | 1224 -------------------- stdlib/source/lux/lang/extension/synthesis.lux | 9 - stdlib/source/lux/lang/extension/translation.lux | 9 - stdlib/source/lux/lang/host.lux | 18 + stdlib/source/lux/lang/init.lux | 61 - stdlib/source/lux/lang/module.lux | 51 +- stdlib/source/lux/lang/synthesis.lux | 243 ---- stdlib/source/lux/lang/synthesis/case.lux | 177 --- stdlib/source/lux/lang/synthesis/expression.lux | 99 -- stdlib/source/lux/lang/synthesis/function.lux | 130 --- stdlib/source/lux/lang/synthesis/loop.lux | 285 ----- stdlib/source/lux/lang/target.lux | 18 - stdlib/source/lux/lang/translation.lux | 164 --- .../lux/lang/translation/scheme/case.jvm.lux | 170 --- .../lux/lang/translation/scheme/expression.jvm.lux | 53 - .../lux/lang/translation/scheme/extension.jvm.lux | 32 - .../translation/scheme/extension/common.jvm.lux | 389 ------- .../lux/lang/translation/scheme/function.jvm.lux | 85 -- .../lux/lang/translation/scheme/loop.jvm.lux | 39 - .../lux/lang/translation/scheme/primitive.jvm.lux | 22 - .../lux/lang/translation/scheme/reference.jvm.lux | 54 - .../lux/lang/translation/scheme/runtime.jvm.lux | 362 ------ .../lux/lang/translation/scheme/structure.jvm.lux | 29 - stdlib/test/test/lux/lang/analysis/case.lux | 194 ---- stdlib/test/test/lux/lang/analysis/function.lux | 112 -- stdlib/test/test/lux/lang/analysis/primitive.lux | 86 -- .../test/lux/lang/analysis/procedure/common.lux | 316 ----- .../test/lux/lang/analysis/procedure/host.jvm.lux | 541 --------- stdlib/test/test/lux/lang/analysis/reference.lux | 58 - stdlib/test/test/lux/lang/analysis/structure.lux | 292 ----- .../test/test/lux/lang/compiler/analysis/case.lux | 194 ++++ .../test/lux/lang/compiler/analysis/function.lux | 112 ++ .../test/lux/lang/compiler/analysis/primitive.lux | 86 ++ .../lang/compiler/analysis/procedure/common.lux | 316 +++++ .../lang/compiler/analysis/procedure/host.jvm.lux | 541 +++++++++ .../test/lux/lang/compiler/analysis/reference.lux | 58 + .../test/lux/lang/compiler/analysis/structure.lux | 292 +++++ .../test/test/lux/lang/compiler/synthesis/case.lux | 82 ++ .../test/lux/lang/compiler/synthesis/function.lux | 168 +++ .../test/lux/lang/compiler/synthesis/primitive.lux | 92 ++ .../test/lux/lang/compiler/synthesis/structure.lux | 57 + stdlib/test/test/lux/lang/synthesis/case.lux | 82 -- stdlib/test/test/lux/lang/synthesis/function.lux | 168 --- stdlib/test/test/lux/lang/synthesis/primitive.lux | 92 -- stdlib/test/test/lux/lang/synthesis/structure.lux | 57 - 94 files changed, 8107 insertions(+), 8195 deletions(-) delete mode 100644 stdlib/source/lux/lang/analysis.lux delete mode 100644 stdlib/source/lux/lang/analysis/case.lux delete mode 100644 stdlib/source/lux/lang/analysis/case/coverage.lux delete mode 100644 stdlib/source/lux/lang/analysis/expression.lux delete mode 100644 stdlib/source/lux/lang/analysis/function.lux delete mode 100644 stdlib/source/lux/lang/analysis/inference.lux delete mode 100644 stdlib/source/lux/lang/analysis/primitive.lux delete mode 100644 stdlib/source/lux/lang/analysis/reference.lux delete mode 100644 stdlib/source/lux/lang/analysis/structure.lux delete mode 100644 stdlib/source/lux/lang/analysis/type.lux create mode 100644 stdlib/source/lux/lang/compiler/analysis.lux create mode 100644 stdlib/source/lux/lang/compiler/analysis/case.lux create mode 100644 stdlib/source/lux/lang/compiler/analysis/case/coverage.lux create mode 100644 stdlib/source/lux/lang/compiler/analysis/expression.lux create mode 100644 stdlib/source/lux/lang/compiler/analysis/function.lux create mode 100644 stdlib/source/lux/lang/compiler/analysis/inference.lux create mode 100644 stdlib/source/lux/lang/compiler/analysis/primitive.lux create mode 100644 stdlib/source/lux/lang/compiler/analysis/reference.lux create mode 100644 stdlib/source/lux/lang/compiler/analysis/structure.lux create mode 100644 stdlib/source/lux/lang/compiler/analysis/type.lux create mode 100644 stdlib/source/lux/lang/compiler/extension.lux create mode 100644 stdlib/source/lux/lang/compiler/extension/analysis.lux create mode 100644 stdlib/source/lux/lang/compiler/extension/analysis/common.lux create mode 100644 stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux create mode 100644 stdlib/source/lux/lang/compiler/extension/bundle.lux create mode 100644 stdlib/source/lux/lang/compiler/extension/synthesis.lux create mode 100644 stdlib/source/lux/lang/compiler/extension/translation.lux create mode 100644 stdlib/source/lux/lang/compiler/init.lux create mode 100644 stdlib/source/lux/lang/compiler/synthesis.lux create mode 100644 stdlib/source/lux/lang/compiler/synthesis/case.lux create mode 100644 stdlib/source/lux/lang/compiler/synthesis/expression.lux create mode 100644 stdlib/source/lux/lang/compiler/synthesis/function.lux create mode 100644 stdlib/source/lux/lang/compiler/synthesis/loop.lux create mode 100644 stdlib/source/lux/lang/compiler/translation.lux create mode 100644 stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux create mode 100644 stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux create mode 100644 stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux create mode 100644 stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux create mode 100644 stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux create mode 100644 stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux create mode 100644 stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux create mode 100644 stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux create mode 100644 stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux create mode 100644 stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux delete mode 100644 stdlib/source/lux/lang/extension.lux delete mode 100644 stdlib/source/lux/lang/extension/analysis.lux delete mode 100644 stdlib/source/lux/lang/extension/analysis/common.lux delete mode 100644 stdlib/source/lux/lang/extension/analysis/host.jvm.lux delete mode 100644 stdlib/source/lux/lang/extension/synthesis.lux delete mode 100644 stdlib/source/lux/lang/extension/translation.lux create mode 100644 stdlib/source/lux/lang/host.lux delete mode 100644 stdlib/source/lux/lang/init.lux delete mode 100644 stdlib/source/lux/lang/synthesis.lux delete mode 100644 stdlib/source/lux/lang/synthesis/case.lux delete mode 100644 stdlib/source/lux/lang/synthesis/expression.lux delete mode 100644 stdlib/source/lux/lang/synthesis/function.lux delete mode 100644 stdlib/source/lux/lang/synthesis/loop.lux delete mode 100644 stdlib/source/lux/lang/target.lux delete mode 100644 stdlib/source/lux/lang/translation.lux delete mode 100644 stdlib/source/lux/lang/translation/scheme/case.jvm.lux delete mode 100644 stdlib/source/lux/lang/translation/scheme/expression.jvm.lux delete mode 100644 stdlib/source/lux/lang/translation/scheme/extension.jvm.lux delete mode 100644 stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux delete mode 100644 stdlib/source/lux/lang/translation/scheme/function.jvm.lux delete mode 100644 stdlib/source/lux/lang/translation/scheme/loop.jvm.lux delete mode 100644 stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux delete mode 100644 stdlib/source/lux/lang/translation/scheme/reference.jvm.lux delete mode 100644 stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux delete mode 100644 stdlib/source/lux/lang/translation/scheme/structure.jvm.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/case.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/function.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/primitive.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/procedure/common.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/reference.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/structure.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/case.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/function.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/primitive.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/reference.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/structure.lux create mode 100644 stdlib/test/test/lux/lang/compiler/synthesis/case.lux create mode 100644 stdlib/test/test/lux/lang/compiler/synthesis/function.lux create mode 100644 stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux create mode 100644 stdlib/test/test/lux/lang/compiler/synthesis/structure.lux delete mode 100644 stdlib/test/test/lux/lang/synthesis/case.lux delete mode 100644 stdlib/test/test/lux/lang/synthesis/function.lux delete mode 100644 stdlib/test/test/lux/lang/synthesis/primitive.lux delete mode 100644 stdlib/test/test/lux/lang/synthesis/structure.lux diff --git a/stdlib/source/lux/lang.lux b/stdlib/source/lux/lang.lux index 322b9f655..bc6e2c9ec 100644 --- a/stdlib/source/lux/lang.lux +++ b/stdlib/source/lux/lang.lux @@ -1,17 +1,5 @@ (.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [product] - ["e" error] - [text "text/" Eq] - text/format) - [macro] - (macro ["s" syntax #+ syntax:]))) - -(type: #export (Extension e) - {#name Text - #parameters (List e)}) + lux) (type: #export Eval (-> Type Code (Meta Any))) @@ -19,101 +7,3 @@ (type: #export Version Text) (def: #export version Version "0.6.0") - -(def: #export (fail message) - (All [a] (-> Text (Meta a))) - (do macro.Monad - [[file line col] macro.cursor - #let [location (format file - "," (|> line .int %i) - "," (|> col .int %i))]] - (macro.fail (format message "\n\n" - "@ " location)))) - -(def: #export (throw exception message) - (All [e a] (-> (ex.Exception e) e (Meta a))) - (fail (ex.construct exception message))) - -(syntax: #export (assert exception message test) - (wrap (list (` (if (~ test) - (:: macro.Monad (~' wrap) []) - (..throw (~ exception) (~ message))))))) - -(def: #export (with-source-code source action) - (All [a] (-> Source (Meta a) (Meta a))) - (function (_ compiler) - (let [old-source (get@ #.source compiler)] - (case (action (set@ #.source source compiler)) - (#e.Error error) - (#e.Error error) - - (#e.Success [compiler' output]) - (#e.Success [(set@ #.source old-source compiler') - output]))))) - -(def: #export (with-stacked-errors handler action) - (All [a] (-> (-> [] Text) (Meta a) (Meta a))) - (function (_ compiler) - (case (action compiler) - (#e.Success [compiler' output]) - (#e.Success [compiler' output]) - - (#e.Error error) - (#e.Error (if (text/= "" error) - (handler []) - (format (handler []) "\n\n-----------------------------------------\n\n" 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] (-> (Meta a) (Meta [Scope a]))) - (function (_ compiler) - (case (action (update@ #.scopes (|>> (#.Cons fresh-scope)) compiler)) - (#e.Success [compiler' output]) - (case (get@ #.scopes compiler') - #.Nil - (#e.Error "Impossible error: Drained scopes!") - - (#.Cons head tail) - (#e.Success [(set@ #.scopes tail compiler') - [head output]])) - - (#e.Error error) - (#e.Error error)))) - -(def: #export (with-current-module name action) - (All [a] (-> Text (Meta a) (Meta a))) - (function (_ compiler) - (case (action (set@ #.current-module (#.Some name) compiler)) - (#e.Success [compiler' output]) - (#e.Success [(set@ #.current-module - (get@ #.current-module compiler) - compiler') - output]) - - (#e.Error error) - (#e.Error error)))) - -(def: #export (with-cursor cursor action) - (All [a] (-> Cursor (Meta a) (Meta a))) - (if (text/= "" (product.left cursor)) - action - (function (_ compiler) - (let [old-cursor (get@ #.cursor compiler)] - (case (action (set@ #.cursor cursor compiler)) - (#e.Success [compiler' output]) - (#e.Success [(set@ #.cursor old-cursor compiler') - output]) - - (#e.Error error) - (#e.Error error)))))) diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux deleted file mode 100644 index 6efa934d8..000000000 --- a/stdlib/source/lux/lang/analysis.lux +++ /dev/null @@ -1,209 +0,0 @@ -(.module: - [lux #- nat int deg] - (lux [function] - (data (coll [list "list/" Fold]))) - [// #+ Extension] - [//reference #+ Register Variable Reference]) - -(type: #export #rec Primitive - #Unit - (#Bool Bool) - (#Nat Nat) - (#Int Int) - (#Deg Deg) - (#Frac Frac) - (#Text Text)) - -(type: #export Tag Nat) - -(type: #export (Composite a) - (#Sum (Either a a)) - (#Product [a 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)) - -(do-template [ ] - [(template: #export ( content) - ( content))] - - [control/case #Case] - ) - -(do-template [ ] - [(def: #export - (-> Analysis) - (|>> #Primitive))] - - [bool Bool #Bool] - [nat Nat #Nat] - [int Int #Int] - [deg Deg #Deg] - [frac Frac #Frac] - [text Text #Text] - ) - -(type: #export (Variant a) - {#lefts Nat - #right? Bool - #value a}) - -(type: #export (Tuple a) (List a)) - -(type: #export Arity Nat) - -(type: #export (Abstraction c) [Environment Arity c]) - -(type: #export (Application c) [c (List c)]) - -(def: (last? size tag) - (-> Nat Tag Bool) - (n/= (dec size) tag)) - -(template: #export (no-op value) - (|> +1 #//reference.Local #//reference.Variable #..Reference - (#..Function (list)) - (#..Apply value))) - -(do-template [ ] - [(def: #export ( size tag value) - (-> Nat Tag ) - (let [left (function.constant (|>> #.Left #Sum )) - right (|>> #.Right #Sum )] - (if (last? size tag) - (if (n/= +1 tag) - (right value) - (list/fold left - (right value) - (list.n/range +0 (n/- +2 tag)))) - (list/fold left - (case value - ( (#Sum _)) - ( value) - - _ - value) - (list.n/range +0 tag)))))] - - [sum-analysis Analysis #Structure no-op] - [sum-pattern Pattern #Complex id] - ) - -(do-template [ ] - [(def: #export ( members) - (-> (Tuple ) ) - (case (list.reverse members) - #.Nil - ( #Unit) - - (#.Cons singleton #.Nil) - singleton - - (#.Cons last prevs) - (list/fold (function (_ left right) ( (#Product left right))) - last prevs)))] - - [product-analysis Analysis #Primitive #Structure] - [product-pattern Pattern #Simple #Complex] - ) - -(def: #export (apply [func args]) - (-> (Application Analysis) Analysis) - (list/fold (function (_ arg func) (#Apply arg func)) func args)) - -(type: #export Analyser - (-> Code (Meta Analysis))) - -(do-template [ ] - [(def: #export ( value) - (-> (Tuple )) - (case value - ( (#Product left right)) - (#.Cons left ( right)) - - _ - (list value)))] - - [tuple Analysis #Structure] - [tuple-pattern Pattern #Complex] - ) - -(do-template [ ] - [(def: #export ( value) - (-> (Maybe (Variant ))) - (loop [lefts +0 - variantA value] - (case variantA - ( (#Sum (#.Left valueA))) - (case valueA - ( (#Sum _)) - (recur (inc lefts) valueA) - - _ - (#.Some {#lefts lefts - #right? false - #value valueA})) - - ( (#Sum (#.Right valueA))) - (#.Some {#lefts lefts - #right? true - #value valueA}) - - _ - #.None)))] - - [variant Analysis #Structure] - [variant-pattern Pattern #Complex] - ) - -(def: #export (application analysis) - (-> Analysis (Application Analysis)) - (case analysis - (#Apply head func) - (let [[func' tail] (application func)] - [func' (#.Cons head tail)]) - - _ - [analysis (list)])) - -(template: #export (pattern/unit) - (#..Simple #..Unit)) - -(do-template [ ] - [(template: #export ( content) - (#..Simple ( content)))] - - [pattern/bool #..Bool] - [pattern/nat #..Nat] - [pattern/int #..Int] - [pattern/deg #..Deg] - [pattern/frac #..Frac] - [pattern/text #..Text] - ) diff --git a/stdlib/source/lux/lang/analysis/case.lux b/stdlib/source/lux/lang/analysis/case.lux deleted file mode 100644 index 744d3cf24..000000000 --- a/stdlib/source/lux/lang/analysis/case.lux +++ /dev/null @@ -1,295 +0,0 @@ -(.module: - [lux #- case] - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - [equality #+ Eq]) - (data [bool] - [number] - [product] - ["e" error] - [maybe] - [text] - text/format - (coll [list "list/" Fold Monoid Functor])) - [function] - [macro] - (macro [code]) - [lang] - (lang [type] - (type ["tc" check]) - [".L" scope] - [".L" analysis #+ Pattern Analysis Analyser] - (analysis [".A" type] - [".A" structure] - (case [".A" coverage]))))) - -(exception: #export (cannot-match-type-with-pattern {type Type} {pattern Code}) - (ex.report ["Type" (%type type)] - ["Pattern" (%code pattern)])) - -(exception: #export (sum-type-has-no-case {case Nat} {type Type}) - (ex.report ["Case" (%n case)] - ["Type" (%type type)])) - -(exception: #export (unrecognized-pattern-syntax {pattern Code}) - (%code pattern)) - -(exception: #export (cannot-simplify-type-for-pattern-matching {type Type}) - (%type type)) - -(do-template [] - [(exception: #export ( {message Text}) - message)] - - [cannot-have-empty-branches] - [non-exhaustive-pattern-matching] - ) - -(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-type caseT) - (-> Type (Meta Type)) - (loop [envs (: (List (List Type)) - (list)) - caseT caseT] - (.case caseT - (#.Var id) - (do macro.Monad - [?caseT' (typeA.with-env - (tc.read id))] - (.case ?caseT' - (#.Some caseT') - (recur envs caseT') - - _ - (lang.throw cannot-simplify-type-for-pattern-matching caseT))) - - (#.Named name unnamedT) - (recur envs unnamedT) - - (#.UnivQ env unquantifiedT) - (recur (#.Cons env envs) unquantifiedT) - - (#.ExQ _) - (do macro.Monad - [[ex-id exT] (typeA.with-env - tc.existential)] - (recur envs (maybe.assume (type.apply (list exT) caseT)))) - - (#.Apply inputT funcT) - (.case funcT - (#.Var funcT-id) - (do macro.Monad - [funcT' (typeA.with-env - (do tc.Monad - [?funct' (tc.read funcT-id)] - (.case ?funct' - (#.Some funct') - (wrap funct') - - _ - (tc.throw cannot-simplify-type-for-pattern-matching caseT))))] - (recur envs (#.Apply inputT funcT'))) - - _ - (.case (type.apply (list inputT) funcT) - (#.Some outputT) - (recur envs outputT) - - #.None - (lang.throw cannot-simplify-type-for-pattern-matching caseT))) - - (#.Product _) - (|> caseT - type.flatten-tuple - (list/map (re-quantify envs)) - type.tuple - (:: macro.Monad wrap)) - - _ - (:: macro.Monad wrap (re-quantify envs caseT))))) - -(def: (analyse-primitive type inputT cursor output next) - (All [a] (-> Type Type Cursor Pattern (Meta a) (Meta [Pattern a]))) - (lang.with-cursor cursor - (do macro.Monad - [_ (typeA.with-env - (tc.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 (Meta a) (Meta [Pattern a]))) - (.case pattern - [cursor (#.Symbol ["" name])] - (lang.with-cursor cursor - (do macro.Monad - [outputA (scopeL.with-local [name inputT] - next) - idx scopeL.next-local] - (wrap [(#analysisL.Bind idx) outputA]))) - - (^template [ ] - [cursor ] - (analyse-primitive inputT cursor (#analysisL.Simple ) next)) - ([Bool (#.Bool pattern-value) (#analysisL.Bool pattern-value)] - [Nat (#.Nat pattern-value) (#analysisL.Nat pattern-value)] - [Int (#.Int pattern-value) (#analysisL.Int pattern-value)] - [Deg (#.Deg pattern-value) (#analysisL.Deg pattern-value)] - [Frac (#.Frac pattern-value) (#analysisL.Frac pattern-value)] - [Text (#.Text pattern-value) (#analysisL.Text pattern-value)] - [Any (#.Tuple #.Nil) #analysisL.Unit]) - - (^ [cursor (#.Tuple (list singleton))]) - (analyse-pattern #.None inputT singleton next) - - [cursor (#.Tuple sub-patterns)] - (lang.with-cursor cursor - (do macro.Monad - [inputT' (simplify-case-type inputT)] - (.case inputT' - (#.Product _) - (let [sub-types (type.flatten-tuple inputT') - num-sub-types (maybe.default (list.size sub-types) - num-tags) - num-sub-patterns (list.size sub-patterns) - matches (cond (n/< num-sub-types num-sub-patterns) - (let [[prefix suffix] (list.split (dec num-sub-patterns) sub-types)] - (list.zip2 (list/compose prefix (list (type.tuple suffix))) sub-patterns)) - - (n/> num-sub-types num-sub-patterns) - (let [[prefix suffix] (list.split (dec num-sub-types) sub-patterns)] - (list.zip2 sub-types (list/compose prefix (list (code.tuple suffix))))) - - ## (n/= num-sub-types num-sub-patterns) - (list.zip2 sub-types sub-patterns))] - (do @ - [[memberP+ thenA] (list/fold (: (All [a] - (-> [Type Code] (Meta [(List Pattern) a]) - (Meta [(List Pattern) a]))) - (function (_ [memberT memberC] then) - (do @ - [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [Pattern a]))) - analyse-pattern) - #.None memberT memberC then)] - (wrap [(list& memberP memberP+) thenA])))) - (do @ - [nextA next] - (wrap [(list) nextA])) - (list.reverse matches))] - (wrap [(analysisL.product-pattern memberP+) - thenA]))) - - _ - (lang.throw cannot-match-type-with-pattern [inputT pattern]) - ))) - - [cursor (#.Record record)] - (do macro.Monad - [record (structureA.normalize record) - [members recordT] (structureA.order record) - _ (typeA.with-env - (tc.check inputT recordT))] - (analyse-pattern (#.Some (list.size members)) inputT [cursor (#.Tuple members)] next)) - - [cursor (#.Tag tag)] - (lang.with-cursor cursor - (analyse-pattern #.None inputT (` ((~ pattern))) next)) - - (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))]) - (lang.with-cursor cursor - (do macro.Monad - [inputT' (simplify-case-type 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 case-type) - (n/< num-cases idx)) - (do macro.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 case-type (` [(~+ values)]) next))] - (wrap [(analysisL.sum-pattern num-cases idx testP) - nextA])) - - _ - (lang.throw sum-type-has-no-case [idx inputT]))) - - _ - (lang.throw cannot-match-type-with-pattern [inputT pattern])))) - - (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) - (lang.with-cursor cursor - (do macro.Monad - [tag (macro.normalize tag) - [idx group variantT] (macro.resolve-tag tag) - _ (typeA.with-env - (tc.check inputT variantT))] - (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next))) - - _ - (lang.throw unrecognized-pattern-syntax pattern) - )) - -(def: #export (case analyse inputC branches) - (-> Analyser Code (List [Code Code]) (Meta Analysis)) - (.case branches - #.Nil - (lang.throw cannot-have-empty-branches "") - - (#.Cons [patternH bodyH] branchesT) - (do macro.Monad - [[inputT inputA] (typeA.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 coverageA.determine) - outputTC (monad.map @ (|>> product.left coverageA.determine) outputT) - _ (.case (monad.fold e.Monad coverageA.merge outputHC outputTC) - (#e.Success coverage) - (lang.assert non-exhaustive-pattern-matching "" - (coverageA.exhaustive? coverage)) - - (#e.Error error) - (lang.fail error))] - (wrap (#analysisL.Case inputA [outputH outputT]))))) diff --git a/stdlib/source/lux/lang/analysis/case/coverage.lux b/stdlib/source/lux/lang/analysis/case/coverage.lux deleted file mode 100644 index a5958001f..000000000 --- a/stdlib/source/lux/lang/analysis/case/coverage.lux +++ /dev/null @@ -1,322 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - equality) - (data [bool "bool/" Eq] - [number] - ["e" error "error/" Monad] - [maybe] - text/format - (coll [list "list/" Fold] - (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad] - [lang] - (lang [".L" analysis #+ Pattern Variant]))) - -(def: cases - (-> (Maybe Nat) Nat) - (|>> (maybe.default +0))) - -(def: (variant sum-side) - (-> (Either Pattern Pattern) (Variant Pattern)) - (loop [lefts +0 - variantP sum-side] - (case variantP - (#.Left valueP) - (case valueP - (#analysisL.Complex (#analysisL.Sum value-side)) - (recur (inc lefts) value-side) - - _ - {#analysisL.lefts lefts - #analysisL.right? false - #analysisL.value valueP}) - - (#.Right valueP) - {#analysisL.lefts lefts - #analysisL.right? true - #analysisL.value valueP}))) - -## 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 booleans -## and variants. -(type: #export #rec Coverage - #Partial - (#Bool Bool) - (#Variant (Maybe Nat) (Dict Nat Coverage)) - (#Seq Coverage Coverage) - (#Alt Coverage Coverage) - #Exhaustive) - -(def: #export (exhaustive? coverage) - (-> Coverage Bool) - (case coverage - (#Exhaustive _) - true - - _ - false)) - -(def: #export (determine pattern) - (-> Pattern (Meta Coverage)) - (case pattern - (^or (#analysisL.Simple #analysisL.Unit) - (#analysisL.Bind _)) - (macro/wrap #Exhaustive) - - ## Primitive patterns always have partial coverage because there - ## are too many possibilities as far as values go. - (^template [] - (#analysisL.Simple ( _)) - (macro/wrap #Partial)) - ([#analysisL.Nat] - [#analysisL.Int] - [#analysisL.Deg] - [#analysisL.Frac] - [#analysisL.Text]) - - ## Bools are the exception, since there is only "true" and - ## "false", which means it is possible for boolean - ## pattern-matching to become exhaustive if complementary parts meet. - (#analysisL.Simple (#analysisL.Bool value)) - (macro/wrap (#Bool value)) - - ## Tuple patterns can be exhaustive if there is exhaustiveness for all of - ## their sub-patterns. - (#analysisL.Complex (#analysisL.Product [left right])) - (do macro.Monad - [left (determine left) - right (determine right)] - (case right - (#Exhaustive _) - (wrap left) - - _ - (wrap (#Seq left right)))) - - (#analysisL.Complex (#analysisL.Sum sum-side)) - (let [[variant-lefts variant-right? variant-value] (variant sum-side)] - ## Variant patterns can be shown to be exhaustive if all the possible - ## cases are handled exhaustively. - (do macro.Monad - [value-coverage (determine variant-value) - #let [variant-idx (if variant-right? - (inc variant-lefts) - variant-lefts)]] - (wrap (#Variant (if variant-right? - (#.Some variant-idx) - #.None) - (|> (dict.new number.Hash) - (dict.put variant-idx value-coverage)))))))) - -(def: (xor left right) - (-> Bool Bool Bool) - (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. -(def: redundant-pattern - (e.Error Coverage) - (e.fail "Redundant pattern.")) - -(def: (flatten-alt coverage) - (-> Coverage (List Coverage)) - (case coverage - (#Alt left right) - (list& left (flatten-alt right)) - - _ - (list coverage))) - -(struct: _ (Eq Coverage) - (def: (= reference sample) - (case [reference sample] - [#Exhaustive #Exhaustive] - true - - [(#Bool sideR) (#Bool sideS)] - (bool/= sideR sideS) - - [(#Variant allR casesR) (#Variant allS casesS)] - (and (n/= (cases allR) - (cases allS)) - (:: (dict.Eq =) = 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)))) - - _ - false))) - -(open: "C/" Eq) - -## 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 (e.Error Coverage)) - (case [addition so-far] - ## The addition cannot possibly improve the coverage. - [_ #Exhaustive] - redundant-pattern - - ## The addition completes the coverage. - [#Exhaustive _] - (error/wrap #Exhaustive) - - [#Partial #Partial] - (error/wrap #Partial) - - ## 2 boolean coverages are exhaustive if they compliment one another. - (^multi [(#Bool sideA) (#Bool sideSF)] - (xor sideA sideSF)) - (error/wrap #Exhaustive) - - [(#Variant allA casesA) (#Variant allSF casesSF)] - (cond (not (n/= (cases allSF) (cases allA))) - (e.fail "Variants do not match.") - - (:: (dict.Eq Eq) = casesSF casesA) - redundant-pattern - - ## else - (do e.Monad - [casesM (monad.fold @ - (function (_ [tagA coverageA] casesSF') - (case (dict.get tagA casesSF') - (#.Some coverageSF) - (do @ - [coverageM (merge coverageA coverageSF)] - (wrap (dict.put tagA coverageM casesSF'))) - - #.None - (wrap (dict.put tagA coverageA casesSF')))) - casesSF (dict.entries casesA))] - (wrap (if (let [case-coverages (dict.values casesM)] - (and (n/= (cases allSF) (list.size case-coverages)) - (list.every? exhaustive? case-coverages))) - #Exhaustive - (#Variant allSF casesM))))) - - [(#Seq leftA rightA) (#Seq leftSF rightSF)] - (case [(C/= leftSF leftA) (C/= rightSF rightA)] - ## There is nothing the addition adds to the coverage. - [true true] - redundant-pattern - - ## The 2 sequences cannot possibly be merged. - [false false] - (error/wrap (#Alt so-far addition)) - - ## Same prefix - [true false] - (do e.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 - [false true] - (do e.Monad - [leftM (merge leftA leftSF)] - (wrap (#Seq leftM rightA)))) - - ## The left part will always match, so the addition is redundant. - (^multi [(#Seq left right) single] - (C/= left single)) - redundant-pattern - - ## The right part is not necessary, since it can always match the left. - (^multi [single (#Seq left right)] - (C/= left single)) - (error/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 e.Monad - [#let [fuse-once (: (-> Coverage (List Coverage) - (e.Error [(Maybe Coverage) - (List Coverage)])) - (function (_ coverage possibilities) - (loop [alts possibilities] - (case alts - #.Nil - (wrap [#.None (list coverage)]) - - (#.Cons alt alts') - (case (merge coverage alt) - (#e.Success altM) - (case altM - (#Alt _) - (do @ - [[success alts+] (recur alts')] - (wrap [success (#.Cons alt alts+)])) - - _ - (wrap [(#.Some altM) alts'])) - - (#e.Error error) - (e.fail error)) - ))))] - [success possibilities] (fuse-once addition (flatten-alt so-far))] - (loop [success success - possibilities possibilities] - (case success - (#.Some coverage') - (do @ - [[success' possibilities'] (fuse-once coverage' possibilities)] - (recur success' possibilities')) - - #.None - (case (list.reverse possibilities) - (#.Cons last prevs) - (wrap (list/fold (function (_ left right) (#Alt left right)) - last - prevs)) - - #.Nil - (undefined))))) - - _ - (if (C/= so-far addition) - ## The addition cannot possibly improve the coverage. - redundant-pattern - ## There are now 2 alternative paths. - (error/wrap (#Alt so-far addition))))) diff --git a/stdlib/source/lux/lang/analysis/expression.lux b/stdlib/source/lux/lang/analysis/expression.lux deleted file mode 100644 index 325394e73..000000000 --- a/stdlib/source/lux/lang/analysis/expression.lux +++ /dev/null @@ -1,122 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data ["e" error] - [product] - text/format) - [macro] - [lang #+ Eval] - (lang [type] - (type ["tc" check]) - [".L" analysis #+ Analysis Analyser] - (analysis [".A" type] - [".A" primitive] - [".A" structure] - [".A" reference]) - ## [".L" macro] - [".L" extension]))) - -(exception: #export (macro-expansion-failed {message Text}) - message) - -(do-template [] - [(exception: #export ( {code Code}) - (%code code))] - - [macro-call-must-have-single-expansion] - [unrecognized-syntax] - ) - -(def: #export (analyser eval) - (-> Eval Analyser) - (: (-> Code (Meta Analysis)) - (function (analyse code) - (do macro.Monad - [expectedT macro.expected-type] - (let [[cursor code'] code] - ## The cursor must be set in the compiler for the sake - ## of having useful error messages. - (lang.with-cursor cursor - (case code' - (^template [ ] - ( value) - ( value)) - ([#.Bool primitiveA.bool] - [#.Nat primitiveA.nat] - [#.Int primitiveA.int] - [#.Deg primitiveA.deg] - [#.Frac primitiveA.frac] - [#.Text primitiveA.text]) - - (^template [ ] - (^ (#.Form (list& [_ ( tag)] - values))) - (case values - (#.Cons value #.Nil) - ( analyse tag value) - - _ - ( analyse tag (` [(~+ values)])))) - ([#.Nat structureA.sum] - [#.Tag structureA.tagged-sum]) - - (#.Tag tag) - (structureA.tagged-sum analyse tag (' [])) - - (^ (#.Tuple (list))) - primitiveA.unit - - (^ (#.Tuple (list singleton))) - (analyse singleton) - - (^ (#.Tuple elems)) - (structureA.product analyse elems) - - (^ (#.Record pairs)) - (structureA.record analyse pairs) - - (#.Symbol reference) - (referenceA.reference reference) - - (^ (#.Form (list& [_ (#.Text proc-name)] proc-args))) - (do macro.Monad - [procedure (extensionL.find-analysis proc-name)] - (procedure analyse eval proc-args)) - - ## (^ (#.Form (list& func args))) - ## (do macro.Monad - ## [[funcT funcA] (typeA.with-inference - ## (analyse func))] - ## (case funcA - ## [_ (#.Symbol def-name)] - ## (do @ - ## [?macro (lang.with-error-tracking - ## (macro.find-macro def-name))] - ## (case ?macro - ## (#.Some macro) - ## (do @ - ## [expansion (: (Meta (List Code)) - ## (function (_ compiler) - ## (case (macroL.expand macro args compiler) - ## (#e.Error error) - ## ((lang.throw macro-expansion-failed error) compiler) - - ## output - ## output)))] - ## (case expansion - ## (^ (list single)) - ## (analyse single) - - ## _ - ## (lang.throw macro-call-must-have-single-expansion code))) - - ## _ - ## (functionA.analyse-apply analyse funcT funcA args))) - - ## _ - ## (functionA.analyse-apply analyse funcT funcA args))) - - _ - (lang.throw unrecognized-syntax code) - ))))))) diff --git a/stdlib/source/lux/lang/analysis/function.lux b/stdlib/source/lux/lang/analysis/function.lux deleted file mode 100644 index f6fea9bb0..000000000 --- a/stdlib/source/lux/lang/analysis/function.lux +++ /dev/null @@ -1,104 +0,0 @@ -(.module: - [lux #- function] - (lux (control monad - ["ex" exception #+ exception:]) - (data [maybe] - [text] - text/format - (coll [list "list/" Fold Monoid Monad])) - [macro] - (macro [code]) - [lang] - (lang [type] - (type ["tc" check]) - [".L" scope] - [".L" analysis #+ Analysis Analyser] - (analysis [".A" type] - [".A" inference])))) - -(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 {function Type} {arguments (List Code)}) - (ex.report [" Function" (%type function)] - ["Arguments" (|> arguments - list.enumerate - (list/map (.function (_ [idx argC]) - (format "\n " (%n idx) " " (%code argC)))) - (text.join-with ""))])) - -## [Analysers] -(def: #export (function analyse function-name arg-name body) - (-> Analyser Text Text Code (Meta Analysis)) - (do macro.Monad - [functionT macro.expected-type] - (loop [expectedT functionT] - (lang.with-stacked-errors - (.function (_ _) - (ex.construct 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 - (lang.fail (ex.construct cannot-analyse [expectedT function-name arg-name body]))) - - (^template [ ] - ( _) - (do @ - [[_ instanceT] (typeA.with-env )] - (recur (maybe.assume (type.apply (list instanceT) expectedT))))) - ([#.UnivQ tc.existential] - [#.ExQ tc.var]) - - (#.Var id) - (do @ - [?expectedT' (typeA.with-env - (tc.read id))] - (case ?expectedT' - (#.Some expectedT') - (recur expectedT') - - _ - ## Inference - (do @ - [[input-id inputT] (typeA.with-env tc.var) - [output-id outputT] (typeA.with-env tc.var) - #let [functionT (#.Function inputT outputT)] - functionA (recur functionT) - _ (typeA.with-env - (tc.check expectedT functionT))] - (wrap functionA)) - )) - - (#.Function inputT outputT) - (<| (:: @ map (.function (_ [scope bodyA]) - (#analysisL.Function (scopeL.environment scope) bodyA))) - lang.with-scope - ## Functions have access not only to their argument, but - ## also to themselves, through a local variable. - (scopeL.with-local [function-name expectedT]) - (scopeL.with-local [arg-name inputT]) - (typeA.with-type outputT) - (analyse body)) - - _ - (lang.fail "") - ))))) - -(def: #export (apply analyse functionT functionA args) - (-> Analyser Type Analysis (List Code) (Meta Analysis)) - (lang.with-stacked-errors - (.function (_ _) - (ex.construct cannot-apply [functionT args])) - (do macro.Monad - [[applyT argsA] (inferenceA.general analyse functionT args)] - (wrap (analysisL.apply [functionA argsA]))))) diff --git a/stdlib/source/lux/lang/analysis/inference.lux b/stdlib/source/lux/lang/analysis/inference.lux deleted file mode 100644 index 732a8e6e3..000000000 --- a/stdlib/source/lux/lang/analysis/inference.lux +++ /dev/null @@ -1,256 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [maybe] - [text] - text/format - (coll [list "list/" Functor])) - [macro "macro/" Monad] - [lang] - (lang [type] - (type ["tc" check]) - [analysis #+ Analysis Analyser] - (analysis [".A" type])))) - -(exception: #export (variant-tag-out-of-bounds {size Nat} {tag analysis.Tag} {type Type}) - (ex.report ["Tag" (%n tag)] - ["Variant size" (%n 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 "\n " (%n 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" (%i (.int expected))] - ["Actual" (%i (.int actual))])) - -(do-template [] - [(exception: #export ( {type Type}) - (%type type))] - - [not-a-variant-type] - [not-a-record-type] - [invalid-type-application] - ) - -(def: (replace-bound bound-idx replacementT type) - (-> Nat Type Type Type) - (case type - (#.Primitive name params) - (#.Primitive name (list/map (replace-bound bound-idx replacementT) params)) - - (^template [] - ( left right) - ( (replace-bound bound-idx replacementT left) - (replace-bound bound-idx replacementT right))) - ([#.Sum] - [#.Product] - [#.Function] - [#.Apply]) - - (#.Bound idx) - (if (n/= bound-idx idx) - replacementT - type) - - (^template [] - ( env quantified) - ( (list/map (replace-bound bound-idx replacementT) env) - (replace-bound (n/+ +2 bound-idx) replacementT quantified))) - ([#.UnivQ] - [#.ExQ]) - - _ - type)) - -(def: new-named-type - (Meta Type) - (do macro.Monad - [[_module _line _column] macro.cursor - [ex-id exT] (typeA.with-env tc.existential)] - (wrap (#.Primitive (format "{New Type @ " (%t _module) - "," (%n _line) - "," (%n _column) - "} " (%n ex-id)) - (list))))) - -## 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) - (-> Analyser Type (List Code) (Meta [Type (List Analysis)])) - (case args - #.Nil - (do macro.Monad - [_ (typeA.infer inferT)] - (wrap [inferT (list)])) - - (#.Cons argC args') - (case inferT - (#.Named name unnamedT) - (general analyse unnamedT args) - - (#.UnivQ _) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var)] - (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) - - (#.ExQ _) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var) - output (general analyse - (maybe.assume (type.apply (list varT) inferT)) - args) - bound? (typeA.with-env - (tc.bound? var-id)) - _ (if bound? - (wrap []) - (do @ - [newT new-named-type] - (typeA.with-env - (tc.check varT newT))))] - (wrap output)) - - (#.Apply inputT transT) - (case (type.apply (list inputT) transT) - (#.Some outputT) - (general analyse outputT args) - - #.None - (lang.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 macro.Monad - [[outputT' args'A] (general analyse outputT args') - argA (lang.with-stacked-errors - (function (_ _) - (ex.construct cannot-infer-argument [inputT argC])) - (typeA.with-type inputT - (analyse argC)))] - (wrap [outputT' (list& argA args'A)])) - - (#.Var infer-id) - (do macro.Monad - [?inferT' (typeA.with-env (tc.read infer-id))] - (case ?inferT' - (#.Some inferT') - (general analyse inferT' args) - - _ - (lang.throw cannot-infer [inferT args]))) - - _ - (lang.throw cannot-infer [inferT args])) - )) - -## Turns a record type into the kind of function type suitable for inference. -(def: #export (record inferT) - (-> Type (Meta Type)) - (case inferT - (#.Named name unnamedT) - (record unnamedT) - - (^template [] - ( env bodyT) - (do macro.Monad - [bodyT+ (record bodyT)] - (wrap ( env bodyT+)))) - ([#.UnivQ] - [#.ExQ]) - - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (record outputT) - - #.None - (lang.throw invalid-type-application inferT)) - - (#.Product _) - (macro/wrap (type.function (type.flatten-tuple inferT) inferT)) - - _ - (lang.throw not-a-record-type inferT))) - -## Turns a variant type into the kind of function type suitable for inference. -(def: #export (variant tag expected-size inferT) - (-> Nat Nat Type (Meta Type)) - (loop [depth +0 - currentT inferT] - (case currentT - (#.Named name unnamedT) - (do macro.Monad - [unnamedT+ (recur depth unnamedT)] - (wrap unnamedT+)) - - (^template [] - ( env bodyT) - (do macro.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) - (macro/wrap (if (n/= +0 depth) - (type.function (list caseT) currentT) - (let [replace! (replace-bound (|> depth dec (n/* +2)) inferT)] - (type.function (list (replace! caseT)) - (replace! currentT))))) - - #.None - (lang.throw variant-tag-out-of-bounds [expected-size tag inferT])) - - (n/< expected-size actual-size) - (lang.throw smaller-variant-than-expected [expected-size actual-size]) - - (n/= boundary tag) - (let [caseT (type.variant (list.drop boundary cases))] - (macro/wrap (if (n/= +0 depth) - (type.function (list caseT) currentT) - (let [replace! (replace-bound (|> depth dec (n/* +2)) inferT)] - (type.function (list (replace! caseT)) - (replace! currentT)))))) - - ## else - (lang.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 - (lang.throw invalid-type-application inferT)) - - _ - (lang.throw not-a-variant-type inferT)))) diff --git a/stdlib/source/lux/lang/analysis/primitive.lux b/stdlib/source/lux/lang/analysis/primitive.lux deleted file mode 100644 index 74596fba2..000000000 --- a/stdlib/source/lux/lang/analysis/primitive.lux +++ /dev/null @@ -1,28 +0,0 @@ -(.module: - [lux #- nat int deg] - (lux (control monad) - [macro]) - [// #+ Analysis] - (// [".A" type])) - -## [Analysers] -(do-template [ ] - [(def: #export ( value) - (-> (Meta Analysis)) - (do macro.Monad - [_ (typeA.infer )] - (wrap (#//.Primitive ( value)))))] - - [bool Bool #//.Bool] - [nat Nat #//.Nat] - [int Int #//.Int] - [deg Deg #//.Deg] - [frac Frac #//.Frac] - [text Text #//.Text] - ) - -(def: #export unit - (Meta Analysis) - (do macro.Monad - [_ (typeA.infer Any)] - (wrap (#//.Primitive #//.Unit)))) diff --git a/stdlib/source/lux/lang/analysis/reference.lux b/stdlib/source/lux/lang/analysis/reference.lux deleted file mode 100644 index cceb4db7d..000000000 --- a/stdlib/source/lux/lang/analysis/reference.lux +++ /dev/null @@ -1,56 +0,0 @@ -(.module: - lux - (lux (control monad) - [macro] - (macro [code]) - (lang (type ["tc" check]))) - [// #+ Analysis] - [//type] - [///reference] - [///scope]) - -## [Analysers] -(def: (definition def-name) - (-> Ident (Meta Analysis)) - (do macro.Monad - [[actualT def-anns _] (macro.find-def def-name)] - (case (macro.get-symbol-ann (ident-for #.alias) def-anns) - (#.Some real-def-name) - (definition real-def-name) - - _ - (do @ - [_ (//type.infer actualT)] - (:: @ map (|>> ///reference.constant #//.Reference) - (macro.normalize def-name)))))) - -(def: (variable var-name) - (-> Text (Meta (Maybe Analysis))) - (do macro.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) - (-> Ident (Meta Analysis)) - (case reference - ["" simple-name] - (do macro.Monad - [?var (variable simple-name)] - (case ?var - (#.Some varA) - (wrap varA) - - #.None - (do @ - [this-module macro.current-module-name] - (definition [this-module simple-name])))) - - _ - (definition reference))) diff --git a/stdlib/source/lux/lang/analysis/structure.lux b/stdlib/source/lux/lang/analysis/structure.lux deleted file mode 100644 index bc527cd49..000000000 --- a/stdlib/source/lux/lang/analysis/structure.lux +++ /dev/null @@ -1,358 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [ident] - [number] - [product] - [maybe] - (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dict])) - text/format) - [macro] - (macro [code]) - [lang] - (lang [type] - (type ["tc" check]) - [analysis #+ Analysis Analyser] - (analysis [".A" type] - [".A" primitive] - [".A" inference])))) - -(exception: #export (invalid-variant-type {type Type} {tag analysis.Tag} {code Code}) - (ex.report ["Type" (%type type)] - ["Tag" (%n tag)] - ["Expression" (%code code)])) - -(do-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)) - -(do-template [] - [(exception: #export ( {type Type} {tag analysis.Tag} {code Code}) - (ex.report ["Type" (%type type)] - ["Tag" (%n 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))])) - -(do-template [] - [(exception: #export ( {key Ident} {record (List [Ident 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 Ident} {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 [Ident Code])}) - (ex.report ["Expected" (|> expected .int %i)] - ["Actual" (|> actual .int %i)] - ["Type" (%type type)] - ["Expression" (%code (|> record - (list/map (function (_ [keyI valueC]) - [(code.tag keyI) valueC])) - code.record))])) - -(def: #export (sum analyse tag valueC) - (-> Analyser Nat Code (Meta Analysis)) - (do macro.Monad - [expectedT macro.expected-type] - (lang.with-stacked-errors - (function (_ _) - (ex.construct cannot-analyse-variant [expectedT tag valueC])) - (case expectedT - (#.Sum _) - (let [flat (type.flatten-variant expectedT) - type-size (list.size flat)] - (case (list.nth tag flat) - (#.Some variant-type) - (do @ - [valueA (typeA.with-type variant-type - (analyse valueC))] - (wrap (analysis.sum-analysis type-size tag valueA))) - - #.None - (lang.throw inferenceA.variant-tag-out-of-bounds [type-size tag expectedT]))) - - (#.Named name unnamedT) - (typeA.with-type unnamedT - (sum analyse tag valueC)) - - (#.Var id) - (do @ - [?expectedT' (typeA.with-env - (tc.read id))] - (case ?expectedT' - (#.Some expectedT') - (typeA.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. - (lang.throw cannot-infer-numeric-tag [expectedT tag valueC]) - )) - - (^template [ ] - ( _) - (do @ - [[instance-id instanceT] (typeA.with-env )] - (typeA.with-type (maybe.assume (type.apply (list instanceT) expectedT)) - (sum analyse tag valueC)))) - ([#.UnivQ tc.existential] - [#.ExQ tc.var]) - - (#.Apply inputT funT) - (case funT - (#.Var funT-id) - (do @ - [?funT' (typeA.with-env (tc.read funT-id))] - (case ?funT' - (#.Some funT') - (typeA.with-type (#.Apply inputT funT') - (sum analyse tag valueC)) - - _ - (lang.throw invalid-variant-type [expectedT tag valueC]))) - - _ - (case (type.apply (list inputT) funT) - #.None - (lang.throw not-a-quantified-type funT) - - (#.Some outputT) - (typeA.with-type outputT - (sum analyse tag valueC)))) - - _ - (lang.throw invalid-variant-type [expectedT tag valueC]))))) - -(def: (typed-product analyse membersC+) - (-> Analyser (List Code) (Meta Analysis)) - (do macro.Monad - [expectedT macro.expected-type] - (loop [expectedT expectedT - membersC+ membersC+] - (case [expectedT membersC+] - ## If the tuple runs out, whatever expression is the last gets - ## matched to the remaining type. - [tailT (#.Cons tailC #.Nil)] - (typeA.with-type tailT - (analyse tailC)) - - ## If the type and the code are still ongoing, match each - ## sub-expression to its corresponding type. - [(#.Product leftT rightT) (#.Cons leftC rightC)] - (do @ - [leftA (typeA.with-type leftT - (analyse leftC)) - rightA (recur rightT rightC)] - (wrap (#analysis.Structure (#analysis.Product leftA rightA)))) - - ## If, however, the type runs out but there is still enough - ## tail, the remaining elements get packaged into another - ## tuple. - ## The reason for this is that it is assumed that the type of - ## the tuple represents the expectations of the user. - ## If the type is for a 3-tuple, but a 5-tuple is provided, it - ## is assumed that the user intended the following layout: - ## [0, 1, [2, 3, 4]] - ## but that, for whatever reason, it was written in a flat - ## way. - [tailT tailC] - (|> tailC - code.tuple - analyse - (typeA.with-type tailT) - (:: @ map (|>> analysis.no-op))))))) - -(def: #export (product analyse membersC) - (-> Analyser (List Code) (Meta Analysis)) - (do macro.Monad - [expectedT macro.expected-type] - (lang.with-stacked-errors - (function (_ _) - (ex.construct cannot-analyse-tuple [expectedT membersC])) - (case expectedT - (#.Product _) - (..typed-product analyse membersC) - - (#.Named name unnamedT) - (typeA.with-type unnamedT - (product analyse membersC)) - - (#.Var id) - (do @ - [?expectedT' (typeA.with-env - (tc.read id))] - (case ?expectedT' - (#.Some expectedT') - (typeA.with-type expectedT' - (product analyse membersC)) - - _ - ## Must do inference... - (do @ - [membersTA (monad.map @ (|>> analyse typeA.with-inference) - membersC) - _ (typeA.with-env - (tc.check expectedT - (type.tuple (list/map product.left membersTA))))] - (wrap (analysis.product-analysis (list/map product.right membersTA)))))) - - (^template [ ] - ( _) - (do @ - [[instance-id instanceT] (typeA.with-env )] - (typeA.with-type (maybe.assume (type.apply (list instanceT) expectedT)) - (product analyse membersC)))) - ([#.UnivQ tc.existential] - [#.ExQ tc.var]) - - (#.Apply inputT funT) - (case funT - (#.Var funT-id) - (do @ - [?funT' (typeA.with-env (tc.read funT-id))] - (case ?funT' - (#.Some funT') - (typeA.with-type (#.Apply inputT funT') - (product analyse membersC)) - - _ - (lang.throw invalid-tuple-type [expectedT membersC]))) - - _ - (case (type.apply (list inputT) funT) - #.None - (lang.throw not-a-quantified-type funT) - - (#.Some outputT) - (typeA.with-type outputT - (product analyse membersC)))) - - _ - (lang.throw invalid-tuple-type [expectedT membersC]) - )))) - -(def: #export (tagged-sum analyse tag valueC) - (-> Analyser Ident Code (Meta Analysis)) - (do macro.Monad - [tag (macro.normalize tag) - [idx group variantT] (macro.resolve-tag tag) - expectedT macro.expected-type] - (case expectedT - (#.Var _) - (do @ - [#let [case-size (list.size group)] - inferenceT (inferenceA.variant idx case-size variantT) - [inferredT valueA+] (inferenceA.general analyse inferenceT (list valueC))] - (wrap (analysis.sum-analysis case-size idx (|> 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]) (Meta (List [Ident Code]))) - (monad.map macro.Monad - (function (_ [key val]) - (case key - [_ (#.Tag key)] - (do macro.Monad - [key (macro.normalize key)] - (wrap [key val])) - - _ - (lang.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 [Ident Code]) (Meta [(List Code) Type])) - (case record - ## empty-record = empty-tuple = unit = [] - #.Nil - (:: macro.Monad wrap [(list) Any]) - - (#.Cons [head-k head-v] _) - (do macro.Monad - [head-k (macro.normalize head-k) - [_ tag-set recordT] (macro.resolve-tag head-k) - #let [size-record (list.size record) - size-ts (list.size tag-set)] - _ (if (n/= size-ts size-record) - (wrap []) - (lang.throw record-size-mismatch [size-ts size-record recordT record])) - #let [tuple-range (list.n/range +0 (dec size-ts)) - tag->idx (dict.from-list ident.Hash (list.zip2 tag-set tuple-range))] - idx->val (monad.fold @ - (function (_ [key val] idx->val) - (do @ - [key (macro.normalize key)] - (case (dict.get key tag->idx) - #.None - (lang.throw tag-does-not-belong-to-record [key recordT]) - - (#.Some idx) - (if (dict.contains? idx idx->val) - (lang.throw cannot-repeat-tag [key record]) - (wrap (dict.put idx val idx->val)))))) - (: (Dict Nat Code) - (dict.new number.Hash)) - record) - #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val))) - tuple-range)]] - (wrap [ordered-tuple recordT])) - )) - -(def: #export (record analyse members) - (-> Analyser (List [Code Code]) (Meta Analysis)) - (do macro.Monad - [members (normalize members) - [membersC recordT] (order members)] - (case membersC - (^ (list)) - primitiveA.unit - - (^ (list singletonC)) - (analyse singletonC) - - _ - (do @ - [expectedT macro.expected-type] - (case expectedT - (#.Var _) - (do @ - [inferenceT (inferenceA.record recordT) - [inferredT membersA] (inferenceA.general analyse inferenceT membersC)] - (wrap (analysis.product-analysis membersA))) - - _ - (..product analyse membersC)))))) diff --git a/stdlib/source/lux/lang/analysis/type.lux b/stdlib/source/lux/lang/analysis/type.lux deleted file mode 100644 index a7f9b3b29..000000000 --- a/stdlib/source/lux/lang/analysis/type.lux +++ /dev/null @@ -1,60 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data ["e" error]) - [macro] - [lang] - (lang (type ["tc" check])))) - -(def: #export (with-type expected action) - (All [a] (-> Type (Meta a) (Meta a))) - (function (_ compiler) - (case (action (set@ #.expected (#.Some expected) compiler)) - (#e.Success [compiler' output]) - (let [old-expected (get@ #.expected compiler)] - (#e.Success [(set@ #.expected old-expected compiler') - output])) - - (#e.Error error) - (#e.Error error)))) - -(def: #export (with-env action) - (All [a] (-> (tc.Check a) (Meta a))) - (function (_ compiler) - (case (action (get@ #.type-context compiler)) - (#e.Error error) - ((lang.fail error) compiler) - - (#e.Success [context' output]) - (#e.Success [(set@ #.type-context context' compiler) - output])))) - -(def: #export (with-fresh-env action) - (All [a] (-> (Meta a) (Meta a))) - (function (_ compiler) - (let [old (get@ #.type-context compiler)] - (case (action (set@ #.type-context tc.fresh-context compiler)) - (#e.Success [compiler' output]) - (#e.Success [(set@ #.type-context old compiler') - output]) - - output - output)))) - -(def: #export (infer actualT) - (-> Type (Meta Any)) - (do macro.Monad - [expectedT macro.expected-type] - (with-env - (tc.check expectedT actualT)))) - -(def: #export (with-inference action) - (All [a] (-> (Meta a) (Meta [Type a]))) - (do macro.Monad - [[_ varT] (..with-env - tc.var) - output (with-type varT - action) - knownT (..with-env - (tc.clean varT))] - (wrap [knownT output]))) diff --git a/stdlib/source/lux/lang/compiler.lux b/stdlib/source/lux/lang/compiler.lux index c2f9af1e2..20278a6cd 100644 --- a/stdlib/source/lux/lang/compiler.lux +++ b/stdlib/source/lux/lang/compiler.lux @@ -4,12 +4,21 @@ ["ex" exception #+ Exception exception:] [monad #+ do]) (data [product] - [error #+ Error]) - [function])) + [error #+ Error] + [text] + text/format) + [function] + (macro ["s" syntax #+ syntax:]))) (type: #export (Operation s o) (state.State' Error s o)) +(def: #export Monad + (state.Monad error.Monad)) + +(type: #export (Compiler s i o) + (-> i (Operation s o))) + (def: #export (run state operation) (All [s o] (-> s (Operation s o) (Error o))) @@ -17,11 +26,20 @@ operation (:: error.Monad map product.right))) +(def: #export fail + (-> Text Operation) + (|>> error.fail (state.lift error.Monad))) + (def: #export (throw exception parameters) (All [e] (-> (Exception e) e Operation)) (state.lift error.Monad (ex.throw exception parameters))) +(syntax: #export (assert exception message test) + (wrap (list (` (if (~ test) + (:: ..Monad (~' wrap) []) + (..throw (~ exception) (~ message))))))) + (def: #export (localized transform) (All [s o] (-> (-> s s) @@ -39,8 +57,35 @@ (All [s o] (-> s (-> (Operation s o) (Operation s o)))) (localized (function.constant state))) -(def: #export Monad - (state.Monad error.Monad)) +(def: error-separator + (format "\n\n" + "-----------------------------------------" + "\n\n")) -(type: #export (Compiler s i o) - (-> i (Operation s o))) +(def: #export (with-stacked-errors handler action) + (All [s o] (-> (-> [] Text) (Operation s o) (Operation s o))) + (function (_ state) + (case (action state) + (#error.Error error) + (#error.Error (if (text.empty? error) + (handler []) + (format (handler []) error-separator error))) + + success + success))) + +(def: #export identity + (All [s a] (Compiler s a a)) + (function (_ input state) + (#error.Success [state input]))) + +(def: #export (compose pre post) + (All [s0 s1 i t o] + (-> (Compiler s0 i t) + (Compiler s1 t o) + (Compiler [s0 s1] i o))) + (function (_ input [pre/state post/state]) + (do error.Monad + [[pre/state' temp] (pre input pre/state) + [post/state' output] (post temp post/state)] + (wrap [[pre/state' post/state'] output])))) diff --git a/stdlib/source/lux/lang/compiler/analysis.lux b/stdlib/source/lux/lang/compiler/analysis.lux new file mode 100644 index 000000000..235e399fb --- /dev/null +++ b/stdlib/source/lux/lang/compiler/analysis.lux @@ -0,0 +1,281 @@ +(.module: + [lux #- nat int deg] + (lux (data [product] + [error] + [text "text/" Eq] + (coll [list "list/" Fold])) + [function]) + [///reference #+ Register Variable Reference] + [//]) + +(type: #export #rec Primitive + #Unit + (#Bool Bool) + (#Nat Nat) + (#Int Int) + (#Deg Deg) + (#Frac Frac) + (#Text Text)) + +(type: #export Tag Nat) + +(type: #export (Composite a) + (#Sum (Either a a)) + (#Product [a 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)) + +(type: #export Operation + (//.Operation .Lux)) + +(type: #export Compiler + (//.Compiler .Lux Code Analysis)) + +(type: #export Branch + (Branch' Analysis)) + +(type: #export Match + (Match' Analysis)) + +(do-template [ ] + [(template: #export ( content) + ( content))] + + [control/case #Case] + ) + +(do-template [ ] + [(def: #export + (-> Analysis) + (|>> #Primitive))] + + [bool Bool #Bool] + [nat Nat #Nat] + [int Int #Int] + [deg Deg #Deg] + [frac Frac #Frac] + [text Text #Text] + ) + +(type: #export (Variant a) + {#lefts Nat + #right? Bool + #value a}) + +(type: #export (Tuple a) (List a)) + +(type: #export Arity Nat) + +(type: #export (Abstraction c) [Environment Arity c]) + +(type: #export (Application c) [c (List c)]) + +(def: (last? size tag) + (-> Nat Tag Bool) + (n/= (dec size) tag)) + +(template: #export (no-op value) + (|> +1 #///reference.Local #///reference.Variable #..Reference + (#..Function (list)) + (#..Apply value))) + +(do-template [ ] + [(def: #export ( size tag value) + (-> Nat Tag ) + (let [left (function.constant (|>> #.Left #Sum )) + right (|>> #.Right #Sum )] + (if (last? size tag) + (if (n/= +1 tag) + (right value) + (list/fold left + (right value) + (list.n/range +0 (n/- +2 tag)))) + (list/fold left + (case value + ( (#Sum _)) + ( value) + + _ + value) + (list.n/range +0 tag)))))] + + [sum-analysis Analysis #Structure no-op] + [sum-pattern Pattern #Complex id] + ) + +(do-template [ ] + [(def: #export ( members) + (-> (Tuple ) ) + (case (list.reverse members) + #.Nil + ( #Unit) + + (#.Cons singleton #.Nil) + singleton + + (#.Cons last prevs) + (list/fold (function (_ left right) ( (#Product left right))) + last prevs)))] + + [product-analysis Analysis #Primitive #Structure] + [product-pattern Pattern #Simple #Complex] + ) + +(def: #export (apply [func args]) + (-> (Application Analysis) Analysis) + (list/fold (function (_ arg func) (#Apply arg func)) func args)) + +(do-template [ ] + [(def: #export ( value) + (-> (Tuple )) + (case value + ( (#Product left right)) + (#.Cons left ( right)) + + _ + (list value)))] + + [tuple Analysis #Structure] + [tuple-pattern Pattern #Complex] + ) + +(do-template [ ] + [(def: #export ( value) + (-> (Maybe (Variant ))) + (loop [lefts +0 + variantA value] + (case variantA + ( (#Sum (#.Left valueA))) + (case valueA + ( (#Sum _)) + (recur (inc lefts) valueA) + + _ + (#.Some {#lefts lefts + #right? false + #value valueA})) + + ( (#Sum (#.Right valueA))) + (#.Some {#lefts lefts + #right? true + #value valueA}) + + _ + #.None)))] + + [variant Analysis #Structure] + [variant-pattern Pattern #Complex] + ) + +(def: #export (application analysis) + (-> Analysis (Application Analysis)) + (case analysis + (#Apply head func) + (let [[func' tail] (application func)] + [func' (#.Cons head tail)]) + + _ + [analysis (list)])) + +(template: #export (pattern/unit) + (#..Simple #..Unit)) + +(do-template [ ] + [(template: #export ( content) + (#..Simple ( content)))] + + [pattern/bool #..Bool] + [pattern/nat #..Nat] + [pattern/int #..Int] + [pattern/deg #..Deg] + [pattern/frac #..Frac] + [pattern/text #..Text] + ) + +(def: #export (with-source-code source action) + (All [a] (-> Source (Operation a) (Operation a))) + (function (_ compiler) + (let [old-source (get@ #.source compiler)] + (case (action (set@ #.source source compiler)) + (#error.Error error) + (#error.Error error) + + (#error.Success [compiler' output]) + (#error.Success [(set@ #.source old-source compiler') + output]))))) + +(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 (_ compiler) + (case (action (update@ #.scopes (|>> (#.Cons fresh-scope)) compiler)) + (#error.Success [compiler' output]) + (case (get@ #.scopes compiler') + #.Nil + (#error.Error "Impossible error: Drained scopes!") + + (#.Cons head tail) + (#error.Success [(set@ #.scopes tail compiler') + [head output]])) + + (#error.Error error) + (#error.Error error)))) + +(def: #export (with-current-module name action) + (All [a] (-> Text (Operation a) (Operation a))) + (function (_ compiler) + (case (action (set@ #.current-module (#.Some name) compiler)) + (#error.Success [compiler' output]) + (#error.Success [(set@ #.current-module + (get@ #.current-module compiler) + compiler') + output]) + + (#error.Error error) + (#error.Error error)))) + +(def: #export (with-cursor cursor action) + (All [a] (-> Cursor (Operation a) (Operation a))) + (if (text/= "" (product.left cursor)) + action + (function (_ compiler) + (let [old-cursor (get@ #.cursor compiler)] + (case (action (set@ #.cursor cursor compiler)) + (#error.Success [compiler' output]) + (#error.Success [(set@ #.cursor old-cursor compiler') + output]) + + (#error.Error error) + (#error.Error error)))))) diff --git a/stdlib/source/lux/lang/compiler/analysis/case.lux b/stdlib/source/lux/lang/compiler/analysis/case.lux new file mode 100644 index 000000000..9e67a24f9 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/analysis/case.lux @@ -0,0 +1,290 @@ +(.module: + [lux #- case] + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [product] + [error] + [maybe] + text/format + (coll [list "list/" Fold Monoid Functor])) + [macro] + (macro [code])) + (//// [type] + (type ["tc" check]) + [scope]) + [///] + [// #+ Pattern Analysis Operation Compiler] + [//type] + [//structure] + [/coverage]) + +(exception: #export (cannot-match-type-with-pattern {type Type} {pattern Code}) + (ex.report ["Type" (%type type)] + ["Pattern" (%code pattern)])) + +(exception: #export (sum-type-has-no-case {case Nat} {type Type}) + (ex.report ["Case" (%n case)] + ["Type" (%type type)])) + +(exception: #export (unrecognized-pattern-syntax {pattern Code}) + (%code pattern)) + +(exception: #export (cannot-simplify-type-for-pattern-matching {type Type}) + (%type type)) + +(do-template [] + [(exception: #export ( {message Text}) + message)] + + [cannot-have-empty-branches] + [non-exhaustive-pattern-matching] + ) + +(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-type caseT) + (-> Type (Operation Type)) + (loop [envs (: (List (List Type)) + (list)) + caseT caseT] + (.case caseT + (#.Var id) + (do ///.Monad + [?caseT' (//type.with-env + (tc.read id))] + (.case ?caseT' + (#.Some caseT') + (recur envs caseT') + + _ + (///.throw cannot-simplify-type-for-pattern-matching caseT))) + + (#.Named name unnamedT) + (recur envs unnamedT) + + (#.UnivQ env unquantifiedT) + (recur (#.Cons env envs) unquantifiedT) + + (#.ExQ _) + (do ///.Monad + [[ex-id exT] (//type.with-env + tc.existential)] + (recur envs (maybe.assume (type.apply (list exT) caseT)))) + + (#.Apply inputT funcT) + (.case funcT + (#.Var funcT-id) + (do ///.Monad + [funcT' (//type.with-env + (do tc.Monad + [?funct' (tc.read funcT-id)] + (.case ?funct' + (#.Some funct') + (wrap funct') + + _ + (tc.throw cannot-simplify-type-for-pattern-matching caseT))))] + (recur envs (#.Apply inputT funcT'))) + + _ + (.case (type.apply (list inputT) funcT) + (#.Some outputT) + (recur envs outputT) + + #.None + (///.throw cannot-simplify-type-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 + (tc.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 (#.Symbol ["" 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)) + ([Bool (#.Bool pattern-value) (#//.Bool pattern-value)] + [Nat (#.Nat pattern-value) (#//.Nat pattern-value)] + [Int (#.Int pattern-value) (#//.Int pattern-value)] + [Deg (#.Deg pattern-value) (#//.Deg 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-type inputT)] + (.case inputT' + (#.Product _) + (let [sub-types (type.flatten-tuple inputT') + num-sub-types (maybe.default (list.size sub-types) + num-tags) + num-sub-patterns (list.size sub-patterns) + matches (cond (n/< num-sub-types num-sub-patterns) + (let [[prefix suffix] (list.split (dec num-sub-patterns) sub-types)] + (list.zip2 (list/compose prefix (list (type.tuple suffix))) sub-patterns)) + + (n/> num-sub-types num-sub-patterns) + (let [[prefix suffix] (list.split (dec num-sub-types) sub-patterns)] + (list.zip2 sub-types (list/compose prefix (list (code.tuple suffix))))) + + ## (n/= num-sub-types num-sub-patterns) + (list.zip2 sub-types 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]] ((:! (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 [(//.product-pattern memberP+) + thenA]))) + + _ + (///.throw cannot-match-type-with-pattern [inputT pattern]) + ))) + + [cursor (#.Record record)] + (do ///.Monad + [record (//structure.normalize record) + [members recordT] (//structure.order record) + _ (//type.with-env + (tc.check inputT recordT))] + (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-type 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 case-type) + (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 case-type (` [(~+ values)]) next))] + (wrap [(//.sum-pattern num-cases idx testP) + nextA])) + + _ + (///.throw sum-type-has-no-case [idx inputT]))) + + _ + (///.throw cannot-match-type-with-pattern [inputT pattern])))) + + (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) + (//.with-cursor cursor + (do ///.Monad + [tag (macro.normalize tag) + [idx group variantT] (macro.resolve-tag tag) + _ (//type.with-env + (tc.check inputT variantT))] + (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next))) + + _ + (///.throw unrecognized-pattern-syntax pattern) + )) + +(def: #export (case analyse inputC branches) + (-> Compiler Code (List [Code Code]) (Operation Analysis)) + (.case branches + #.Nil + (///.throw cannot-have-empty-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 error.Monad /coverage.merge outputHC outputTC) + (#error.Success coverage) + (///.assert non-exhaustive-pattern-matching "" + (/coverage.exhaustive? coverage)) + + (#error.Error error) + (///.fail error))] + (wrap (#//.Case inputA [outputH outputT]))))) diff --git a/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux new file mode 100644 index 000000000..6a965742a --- /dev/null +++ b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux @@ -0,0 +1,321 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + equality) + (data [bool "bool/" Eq] + [number] + ["e" error "error/" Monad] + [maybe] + text/format + (coll [list "list/" Fold] + (dictionary ["dict" unordered #+ Dict])))) + [//// "operation/" Monad] + [/// #+ Pattern Variant Operation]) + +(def: cases + (-> (Maybe Nat) Nat) + (|>> (maybe.default +0))) + +(def: (variant sum-side) + (-> (Either Pattern Pattern) (Variant Pattern)) + (loop [lefts +0 + variantP sum-side] + (case variantP + (#.Left valueP) + (case valueP + (#///.Complex (#///.Sum value-side)) + (recur (inc lefts) value-side) + + _ + {#///.lefts lefts + #///.right? false + #///.value valueP}) + + (#.Right valueP) + {#///.lefts lefts + #///.right? true + #///.value valueP}))) + +## 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 booleans +## and variants. +(type: #export #rec Coverage + #Partial + (#Bool Bool) + (#Variant (Maybe Nat) (Dict Nat Coverage)) + (#Seq Coverage Coverage) + (#Alt Coverage Coverage) + #Exhaustive) + +(def: #export (exhaustive? coverage) + (-> Coverage Bool) + (case coverage + (#Exhaustive _) + true + + _ + false)) + +(def: #export (determine pattern) + (-> Pattern (Operation Coverage)) + (case pattern + (^or (#///.Simple #///.Unit) + (#///.Bind _)) + (operation/wrap #Exhaustive) + + ## Primitive patterns always have partial coverage because there + ## are too many possibilities as far as values go. + (^template [] + (#///.Simple ( _)) + (operation/wrap #Partial)) + ([#///.Nat] + [#///.Int] + [#///.Deg] + [#///.Frac] + [#///.Text]) + + ## Bools are the exception, since there is only "true" and + ## "false", which means it is possible for boolean + ## pattern-matching to become exhaustive if complementary parts meet. + (#///.Simple (#///.Bool value)) + (operation/wrap (#Bool value)) + + ## Tuple patterns can be exhaustive if there is exhaustiveness for all of + ## their sub-patterns. + (#///.Complex (#///.Product [left right])) + (do ////.Monad + [left (determine left) + right (determine right)] + (case right + (#Exhaustive _) + (wrap left) + + _ + (wrap (#Seq left right)))) + + (#///.Complex (#///.Sum sum-side)) + (let [[variant-lefts variant-right? variant-value] (variant sum-side)] + ## Variant patterns can be shown to be exhaustive if all the possible + ## cases are handled exhaustively. + (do ////.Monad + [value-coverage (determine variant-value) + #let [variant-idx (if variant-right? + (inc variant-lefts) + variant-lefts)]] + (wrap (#Variant (if variant-right? + (#.Some variant-idx) + #.None) + (|> (dict.new number.Hash) + (dict.put variant-idx value-coverage)))))))) + +(def: (xor left right) + (-> Bool Bool Bool) + (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. +(def: redundant-pattern + (e.Error Coverage) + (e.fail "Redundant pattern.")) + +(def: (flatten-alt coverage) + (-> Coverage (List Coverage)) + (case coverage + (#Alt left right) + (list& left (flatten-alt right)) + + _ + (list coverage))) + +(struct: _ (Eq Coverage) + (def: (= reference sample) + (case [reference sample] + [#Exhaustive #Exhaustive] + true + + [(#Bool sideR) (#Bool sideS)] + (bool/= sideR sideS) + + [(#Variant allR casesR) (#Variant allS casesS)] + (and (n/= (cases allR) + (cases allS)) + (:: (dict.Eq =) = 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)))) + + _ + false))) + +(open: "C/" Eq) + +## 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 (e.Error Coverage)) + (case [addition so-far] + ## The addition cannot possibly improve the coverage. + [_ #Exhaustive] + redundant-pattern + + ## The addition completes the coverage. + [#Exhaustive _] + (error/wrap #Exhaustive) + + [#Partial #Partial] + (error/wrap #Partial) + + ## 2 boolean coverages are exhaustive if they compliment one another. + (^multi [(#Bool sideA) (#Bool sideSF)] + (xor sideA sideSF)) + (error/wrap #Exhaustive) + + [(#Variant allA casesA) (#Variant allSF casesSF)] + (cond (not (n/= (cases allSF) (cases allA))) + (e.fail "Variants do not match.") + + (:: (dict.Eq Eq) = casesSF casesA) + redundant-pattern + + ## else + (do e.Monad + [casesM (monad.fold @ + (function (_ [tagA coverageA] casesSF') + (case (dict.get tagA casesSF') + (#.Some coverageSF) + (do @ + [coverageM (merge coverageA coverageSF)] + (wrap (dict.put tagA coverageM casesSF'))) + + #.None + (wrap (dict.put tagA coverageA casesSF')))) + casesSF (dict.entries casesA))] + (wrap (if (let [case-coverages (dict.values casesM)] + (and (n/= (cases allSF) (list.size case-coverages)) + (list.every? exhaustive? case-coverages))) + #Exhaustive + (#Variant allSF casesM))))) + + [(#Seq leftA rightA) (#Seq leftSF rightSF)] + (case [(C/= leftSF leftA) (C/= rightSF rightA)] + ## There is nothing the addition adds to the coverage. + [true true] + redundant-pattern + + ## The 2 sequences cannot possibly be merged. + [false false] + (error/wrap (#Alt so-far addition)) + + ## Same prefix + [true false] + (do e.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 + [false true] + (do e.Monad + [leftM (merge leftA leftSF)] + (wrap (#Seq leftM rightA)))) + + ## The left part will always match, so the addition is redundant. + (^multi [(#Seq left right) single] + (C/= left single)) + redundant-pattern + + ## The right part is not necessary, since it can always match the left. + (^multi [single (#Seq left right)] + (C/= left single)) + (error/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 e.Monad + [#let [fuse-once (: (-> Coverage (List Coverage) + (e.Error [(Maybe Coverage) + (List Coverage)])) + (function (_ coverage possibilities) + (loop [alts possibilities] + (case alts + #.Nil + (wrap [#.None (list coverage)]) + + (#.Cons alt alts') + (case (merge coverage alt) + (#e.Success altM) + (case altM + (#Alt _) + (do @ + [[success alts+] (recur alts')] + (wrap [success (#.Cons alt alts+)])) + + _ + (wrap [(#.Some altM) alts'])) + + (#e.Error error) + (e.fail error)) + ))))] + [success possibilities] (fuse-once addition (flatten-alt so-far))] + (loop [success success + possibilities possibilities] + (case success + (#.Some coverage') + (do @ + [[success' possibilities'] (fuse-once coverage' possibilities)] + (recur success' possibilities')) + + #.None + (case (list.reverse possibilities) + (#.Cons last prevs) + (wrap (list/fold (function (_ left right) (#Alt left right)) + last + prevs)) + + #.Nil + (undefined))))) + + _ + (if (C/= so-far addition) + ## The addition cannot possibly improve the coverage. + redundant-pattern + ## There are now 2 alternative paths. + (error/wrap (#Alt so-far addition))))) diff --git a/stdlib/source/lux/lang/compiler/analysis/expression.lux b/stdlib/source/lux/lang/compiler/analysis/expression.lux new file mode 100644 index 000000000..879f383e8 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/analysis/expression.lux @@ -0,0 +1,121 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data ["e" error] + [product] + text/format) + [macro]) + [//// #+ Eval] + ## (//// [".L" macro] + ## [".L" extension]) + [///] + [// #+ Analysis Operation Compiler] + [//type] + [//primitive] + [//structure] + [//reference]) + +(exception: #export (macro-expansion-failed {message Text}) + message) + +(do-template [] + [(exception: #export ( {code Code}) + (%code code))] + + [macro-call-must-have-single-expansion] + [unrecognized-syntax] + ) + +(def: #export (analyser eval) + (-> Eval Compiler) + (function (compile code) + (do ///.Monad + [expectedT macro.expected-type] + (let [[cursor code'] code] + ## The cursor must be set in the compiler for the sake + ## of having useful error messages. + (//.with-cursor cursor + (case code' + (^template [ ] + ( value) + ( value)) + ([#.Bool //primitive.bool] + [#.Nat //primitive.nat] + [#.Int //primitive.int] + [#.Deg //primitive.deg] + [#.Frac //primitive.frac] + [#.Text //primitive.text]) + + (^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) + + (#.Symbol reference) + (//reference.reference reference) + + (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) + (undefined) + ## (do ///.Monad + ## [extension (extensionL.find-analysis extension-name)] + ## (extension compile eval extension-args)) + + ## (^ (#.Form (list& func args))) + ## (do ///.Monad + ## [[funcT funcA] (//type.with-inference + ## (compile func))] + ## (case funcA + ## [_ (#.Symbol def-name)] + ## (do @ + ## [?macro (///.with-error-tracking + ## (macro.find-macro def-name))] + ## (case ?macro + ## (#.Some macro) + ## (do @ + ## [expansion (: (Operation (List Code)) + ## (function (_ compiler) + ## (case (macroL.expand macro args compiler) + ## (#e.Error error) + ## ((///.throw macro-expansion-failed error) compiler) + + ## output + ## output)))] + ## (case expansion + ## (^ (list single)) + ## (compile single) + + ## _ + ## (///.throw macro-call-must-have-single-expansion code))) + + ## _ + ## (functionA.apply compile funcT funcA args))) + + ## _ + ## (functionA.apply compile funcT funcA args))) + + _ + (///.throw unrecognized-syntax code) + )))))) diff --git a/stdlib/source/lux/lang/compiler/analysis/function.lux b/stdlib/source/lux/lang/compiler/analysis/function.lux new file mode 100644 index 000000000..b6e09f11a --- /dev/null +++ b/stdlib/source/lux/lang/compiler/analysis/function.lux @@ -0,0 +1,103 @@ +(.module: + [lux #- function] + (lux (control monad + ["ex" exception #+ exception:]) + (data [maybe] + [text] + text/format + (coll [list "list/" Fold Monoid Monad])) + [macro] + (macro [code]) + (lang [type] + (type ["tc" check]) + [".L" scope])) + [///] + [// #+ Analysis Compiler] + [//type] + [//inference]) + +(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 {function Type} {arguments (List Code)}) + (ex.report [" Function" (%type function)] + ["Arguments" (|> arguments + list.enumerate + (list/map (.function (_ [idx argC]) + (format "\n " (%n idx) " " (%code argC)))) + (text.join-with ""))])) + +(def: #export (function analyse function-name arg-name body) + (-> Compiler Text Text Code (Meta Analysis)) + (do macro.Monad + [functionT macro.expected-type] + (loop [expectedT functionT] + (///.with-stacked-errors + (.function (_ _) + (ex.construct 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 tc.existential] + [#.ExQ tc.var]) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (tc.read id))] + (case ?expectedT' + (#.Some expectedT') + (recur expectedT') + + ## Inference + _ + (do @ + [[input-id inputT] (//type.with-env tc.var) + [output-id outputT] (//type.with-env tc.var) + #let [functionT (#.Function inputT outputT)] + functionA (recur functionT) + _ (//type.with-env + (tc.check expectedT functionT))] + (wrap functionA)) + )) + + (#.Function inputT outputT) + (<| (:: @ map (.function (_ [scope bodyA]) + (#//.Function (scopeL.environment scope) bodyA))) + //.with-scope + ## Functions have access not only to their argument, but + ## also to themselves, through a local variable. + (scopeL.with-local [function-name expectedT]) + (scopeL.with-local [arg-name inputT]) + (//type.with-type outputT) + (analyse body)) + + _ + (///.fail "") + ))))) + +(def: #export (apply analyse functionT functionA args) + (-> Compiler Type Analysis (List Code) (Meta Analysis)) + (///.with-stacked-errors + (.function (_ _) + (ex.construct cannot-apply [functionT args])) + (do macro.Monad + [[applyT argsA] (//inference.general analyse functionT args)] + (wrap (//.apply [functionA argsA]))))) diff --git a/stdlib/source/lux/lang/compiler/analysis/inference.lux b/stdlib/source/lux/lang/compiler/analysis/inference.lux new file mode 100644 index 000000000..abf1529d6 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/analysis/inference.lux @@ -0,0 +1,256 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + [text] + text/format + (coll [list "list/" Functor])) + [macro]) + (//// [type] + (type ["tc" check])) + [/// #+ "operation/" Monad] + [// #+ Tag Analysis Operation Compiler] + [//type]) + +(exception: #export (variant-tag-out-of-bounds {size Nat} {tag Tag} {type Type}) + (ex.report ["Tag" (%n tag)] + ["Variant size" (%i (.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 "\n " (%n 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" (%i (.int expected))] + ["Actual" (%i (.int actual))])) + +(do-template [] + [(exception: #export ( {type Type}) + (%type type))] + + [not-a-variant-type] + [not-a-record-type] + [invalid-type-application] + ) + +(def: (replace bound-idx replacement type) + (-> Nat Type Type Type) + (case type + (#.Primitive name params) + (#.Primitive name (list/map (replace bound-idx replacement) params)) + + (^template [] + ( left right) + ( (replace bound-idx replacement left) + (replace bound-idx replacement right))) + ([#.Sum] + [#.Product] + [#.Function] + [#.Apply]) + + (#.Bound idx) + (if (n/= bound-idx idx) + replacement + type) + + (^template [] + ( env quantified) + ( (list/map (replace bound-idx replacement) env) + (replace (n/+ +2 bound-idx) replacement quantified))) + ([#.UnivQ] + [#.ExQ]) + + _ + type)) + +(def: new-named-type + (Operation Type) + (do ///.Monad + [[module line column] macro.cursor + [ex-id _] (//type.with-env tc.existential)] + (wrap (#.Primitive (format "{New Type @ " (%t module) + "," (%n line) + "," (%n column) + "} " (%n ex-id)) + (list))))) + +## 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) + (-> Compiler 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 tc.var)] + (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) + + (#.ExQ _) + (do ///.Monad + [[var-id varT] (//type.with-env tc.var) + output (general analyse + (maybe.assume (type.apply (list varT) inferT)) + args) + bound? (//type.with-env + (tc.bound? var-id)) + _ (if bound? + (wrap []) + (do @ + [newT new-named-type] + (//type.with-env + (tc.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-stacked-errors + (function (_ _) + (ex.construct 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 (tc.read infer-id))] + (case ?inferT' + (#.Some inferT') + (general analyse inferT' args) + + _ + (///.throw cannot-infer [inferT args]))) + + _ + (///.throw cannot-infer [inferT args])) + )) + +## Turns a record type into the kind of function type suitable for inference. +(def: #export (record inferT) + (-> Type (Operation Type)) + (case inferT + (#.Named name unnamedT) + (record unnamedT) + + (^template [] + ( env bodyT) + (do ///.Monad + [bodyT+ (record bodyT)] + (wrap ( env bodyT+)))) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (record outputT) + + #.None + (///.throw invalid-type-application inferT)) + + (#.Product _) + (operation/wrap (type.function (type.flatten-tuple inferT) inferT)) + + _ + (///.throw not-a-record-type 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) + (operation/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))] + (operation/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/lang/compiler/analysis/primitive.lux b/stdlib/source/lux/lang/compiler/analysis/primitive.lux new file mode 100644 index 000000000..74596fba2 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/analysis/primitive.lux @@ -0,0 +1,28 @@ +(.module: + [lux #- nat int deg] + (lux (control monad) + [macro]) + [// #+ Analysis] + (// [".A" type])) + +## [Analysers] +(do-template [ ] + [(def: #export ( value) + (-> (Meta Analysis)) + (do macro.Monad + [_ (typeA.infer )] + (wrap (#//.Primitive ( value)))))] + + [bool Bool #//.Bool] + [nat Nat #//.Nat] + [int Int #//.Int] + [deg Deg #//.Deg] + [frac Frac #//.Frac] + [text Text #//.Text] + ) + +(def: #export unit + (Meta Analysis) + (do macro.Monad + [_ (typeA.infer Any)] + (wrap (#//.Primitive #//.Unit)))) diff --git a/stdlib/source/lux/lang/compiler/analysis/reference.lux b/stdlib/source/lux/lang/compiler/analysis/reference.lux new file mode 100644 index 000000000..6f4908f9d --- /dev/null +++ b/stdlib/source/lux/lang/compiler/analysis/reference.lux @@ -0,0 +1,57 @@ +(.module: + lux + (lux (control monad) + [macro] + (macro [code]) + (lang (type ["tc" check]))) + [///] + [// #+ Analysis Operation] + [//type] + [////reference] + [////scope]) + +## [Analysers] +(def: (definition def-name) + (-> Ident (Operation Analysis)) + (do ///.Monad + [[actualT def-anns _] (macro.find-def def-name)] + (case (macro.get-symbol-ann (ident-for #.alias) def-anns) + (#.Some real-def-name) + (definition real-def-name) + + _ + (do @ + [_ (//type.infer actualT)] + (:: @ map (|>> ////reference.constant #//.Reference) + (macro.normalize 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) + (-> Ident (Operation Analysis)) + (case reference + ["" simple-name] + (do ///.Monad + [?var (variable simple-name)] + (case ?var + (#.Some varA) + (wrap varA) + + #.None + (do @ + [this-module macro.current-module-name] + (definition [this-module simple-name])))) + + _ + (definition reference))) diff --git a/stdlib/source/lux/lang/compiler/analysis/structure.lux b/stdlib/source/lux/lang/compiler/analysis/structure.lux new file mode 100644 index 000000000..78b36bc32 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/analysis/structure.lux @@ -0,0 +1,358 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [ident] + [number] + [product] + [maybe] + (coll [list "list/" Functor] + (dictionary ["dict" unordered #+ Dict])) + text/format) + [macro] + (macro [code])) + (//// [type] + (type ["tc" check])) + [///] + [// #+ Tag Analysis Operation Compiler] + [//type] + [//primitive] + [//inference]) + +(exception: #export (invalid-variant-type {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%type type)] + ["Tag" (%n tag)] + ["Expression" (%code code)])) + +(do-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)) + +(do-template [] + [(exception: #export ( {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%type type)] + ["Tag" (%n 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))])) + +(do-template [] + [(exception: #export ( {key Ident} {record (List [Ident 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 Ident} {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 [Ident Code])}) + (ex.report ["Expected" (|> expected .int %i)] + ["Actual" (|> actual .int %i)] + ["Type" (%type type)] + ["Expression" (%code (|> record + (list/map (function (_ [keyI valueC]) + [(code.tag keyI) valueC])) + code.record))])) + +(def: #export (sum analyse tag valueC) + (-> Compiler Nat Code (Operation Analysis)) + (do ///.Monad + [expectedT macro.expected-type] + (///.with-stacked-errors + (function (_ _) + (ex.construct cannot-analyse-variant [expectedT tag valueC])) + (case expectedT + (#.Sum _) + (let [flat (type.flatten-variant expectedT) + type-size (list.size flat)] + (case (list.nth tag flat) + (#.Some variant-type) + (do @ + [valueA (//type.with-type variant-type + (analyse valueC))] + (wrap (//.sum-analysis type-size tag 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 + (tc.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 tc.existential] + [#.ExQ tc.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT-id) + (do @ + [?funT' (//type.with-env (tc.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) + #.None + (///.throw not-a-quantified-type funT) + + (#.Some outputT) + (//type.with-type outputT + (sum analyse tag valueC)))) + + _ + (///.throw invalid-variant-type [expectedT tag valueC]))))) + +(def: (typed-product analyse membersC+) + (-> Compiler (List Code) (Operation Analysis)) + (do ///.Monad + [expectedT macro.expected-type] + (loop [expectedT expectedT + membersC+ membersC+] + (case [expectedT membersC+] + ## If the tuple runs out, whatever expression is the last gets + ## matched to the remaining type. + [tailT (#.Cons tailC #.Nil)] + (//type.with-type tailT + (analyse tailC)) + + ## If the type and the code are still ongoing, match each + ## sub-expression to its corresponding type. + [(#.Product leftT rightT) (#.Cons leftC rightC)] + (do @ + [leftA (//type.with-type leftT + (analyse leftC)) + rightA (recur rightT rightC)] + (wrap (#//.Structure (#//.Product leftA rightA)))) + + ## If, however, the type runs out but there is still enough + ## tail, the remaining elements get packaged into another + ## tuple. + ## The reason for this is that it is assumed that the type of + ## the tuple represents the expectations of the user. + ## If the type is for a 3-tuple, but a 5-tuple is provided, it + ## is assumed that the user intended the following layout: + ## [0, 1, [2, 3, 4]] + ## but that, for whatever reason, it was written in a flat + ## way. + [tailT tailC] + (|> tailC + code.tuple + analyse + (//type.with-type tailT) + (:: @ map (|>> //.no-op))))))) + +(def: #export (product analyse membersC) + (-> Compiler (List Code) (Operation Analysis)) + (do ///.Monad + [expectedT macro.expected-type] + (///.with-stacked-errors + (function (_ _) + (ex.construct 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 + (tc.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 + (tc.check expectedT + (type.tuple (list/map product.left membersTA))))] + (wrap (//.product-analysis (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 tc.existential] + [#.ExQ tc.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT-id) + (do @ + [?funT' (//type.with-env (tc.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) + #.None + (///.throw not-a-quantified-type funT) + + (#.Some outputT) + (//type.with-type outputT + (product analyse membersC)))) + + _ + (///.throw invalid-tuple-type [expectedT membersC]) + )))) + +(def: #export (tagged-sum analyse tag valueC) + (-> Compiler Ident Code (Operation Analysis)) + (do ///.Monad + [tag (macro.normalize tag) + [idx group variantT] (macro.resolve-tag tag) + expectedT 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))] + (wrap (//.sum-analysis case-size idx (|> 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 [Ident Code]))) + (monad.map ///.Monad + (function (_ [key val]) + (case key + [_ (#.Tag key)] + (do ///.Monad + [key (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 [Ident 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 (macro.normalize head-k) + [_ tag-set recordT] (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.n/range +0 (dec size-ts)) + tag->idx (dict.from-list ident.Hash (list.zip2 tag-set tuple-range))] + idx->val (monad.fold @ + (function (_ [key val] idx->val) + (do @ + [key (macro.normalize key)] + (case (dict.get key tag->idx) + #.None + (///.throw tag-does-not-belong-to-record [key recordT]) + + (#.Some idx) + (if (dict.contains? idx idx->val) + (///.throw cannot-repeat-tag [key record]) + (wrap (dict.put idx val idx->val)))))) + (: (Dict Nat Code) + (dict.new number.Hash)) + record) + #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val))) + tuple-range)]] + (wrap [ordered-tuple recordT])) + )) + +(def: #export (record analyse members) + (-> Compiler (List [Code Code]) (Operation Analysis)) + (do ///.Monad + [members (normalize members) + [membersC recordT] (order members)] + (case membersC + (^ (list)) + //primitive.unit + + (^ (list singletonC)) + (analyse singletonC) + + _ + (do @ + [expectedT macro.expected-type] + (case expectedT + (#.Var _) + (do @ + [inferenceT (//inference.record recordT) + [inferredT membersA] (//inference.general analyse inferenceT membersC)] + (wrap (//.product-analysis membersA))) + + _ + (..product analyse membersC)))))) diff --git a/stdlib/source/lux/lang/compiler/analysis/type.lux b/stdlib/source/lux/lang/compiler/analysis/type.lux new file mode 100644 index 000000000..9fcfb2743 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/analysis/type.lux @@ -0,0 +1,61 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [error]) + [macro] + (lang (type ["tc" check]))) + [///] + [// #+ Operation]) + +(def: #export (with-type expected action) + (All [a] (-> Type (Operation a) (Operation a))) + (function (_ compiler) + (case (action (set@ #.expected (#.Some expected) compiler)) + (#error.Success [compiler' output]) + (let [old-expected (get@ #.expected compiler)] + (#error.Success [(set@ #.expected old-expected compiler') + output])) + + (#error.Error error) + (#error.Error error)))) + +(def: #export (with-env action) + (All [a] (-> (tc.Check a) (Operation a))) + (function (_ compiler) + (case (action (get@ #.type-context compiler)) + (#error.Error error) + ((///.fail error) compiler) + + (#error.Success [context' output]) + (#error.Success [(set@ #.type-context context' compiler) + output])))) + +(def: #export (with-fresh-env action) + (All [a] (-> (Operation a) (Operation a))) + (function (_ compiler) + (let [old (get@ #.type-context compiler)] + (case (action (set@ #.type-context tc.fresh-context compiler)) + (#error.Success [compiler' output]) + (#error.Success [(set@ #.type-context old compiler') + output]) + + output + output)))) + +(def: #export (infer actualT) + (-> Type (Operation Any)) + (do ///.Monad + [expectedT macro.expected-type] + (with-env + (tc.check expectedT actualT)))) + +(def: #export (with-inference action) + (All [a] (-> (Operation a) (Operation [Type a]))) + (do ///.Monad + [[_ varT] (..with-env + tc.var) + output (with-type varT + action) + knownT (..with-env + (tc.clean varT))] + (wrap [knownT output]))) diff --git a/stdlib/source/lux/lang/compiler/extension.lux b/stdlib/source/lux/lang/compiler/extension.lux new file mode 100644 index 000000000..28dcd4637 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/extension.lux @@ -0,0 +1,68 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [error #+ Error] + [text] + (coll (dictionary ["dict" unordered #+ Dict])))) + [// #+ Eval] + [//compiler #+ Operation Compiler] + [//analysis #+ Analyser] + [//synthesis #+ Synthesizer] + [//translation #+ Translator]) + +(type: #export (Extension i) + (#Base i) + (#Extension [Text (List (Extension i))])) + +(with-expansions [ (as-is (Dict Text (-> Text (Handler s i o))))] + (type: #export (Handler s i o) + (-> (Compiler [s ] (Extension i) (Extension o)) + (Compiler [s ] (List (Extension i)) (Extension o)))) + + (type: #export (Bundle s i o) + )) + +(do-template [] + [(exception: #export ( {name Text}) + (ex.report ["Name" name]))] + + [unknown-extension] + [cannot-overwrite-existing-extension] + ) + +(def: #export (extend compiler) + (All [s i o] + (-> (Compiler s i o) + (Compiler [s (Bundle s i o)] + (Extension i) + (Extension o)))) + (function (compiler' input (^@ stateE [stateB bundle])) + (case input + (#Base input') + (do error.Monad + [[stateB' output] (compiler input' stateB)] + (wrap [[stateB' bundle] (#Base output)])) + + (#Extension name parameters) + (case (dict.get name bundle) + (#.Some handler) + (do error.Monad + [[stateE' output] (handler name compiler' parameters stateE)] + (wrap [stateE' output])) + + #.None + (ex.throw unknown-extension name))))) + +(def: #export (install name handler) + (All [s i o] + (-> Text (-> Text (Handler s i o)) + (Operation [s (Bundle s i o)] Any))) + (function (_ (^@ stateE [_ bundle])) + (if (dict.contains? name bundle) + (ex.throw cannot-overwrite-existing-extension name) + (ex.return [stateE (dict.put name handler bundle)])))) + +(def: #export fresh + Bundle + (dict.new text.Hash)) diff --git a/stdlib/source/lux/lang/compiler/extension/analysis.lux b/stdlib/source/lux/lang/compiler/extension/analysis.lux new file mode 100644 index 000000000..77439643e --- /dev/null +++ b/stdlib/source/lux/lang/compiler/extension/analysis.lux @@ -0,0 +1,18 @@ +(.module: + lux + (lux (data [text] + (coll [list "list/" Functor] + (dictionary ["dict" unordered #+ Dict])))) + [///analysis #+ Analysis State] + [///synthesis #+ Synthesis] + [//] + [/common] + [/host]) + +(def: #export defaults + (//.Bundle State Analysis Synthesis) + (|> /common.extensions + (dict.merge /host.extensions) + dict.entries + (list/map (function (_ [name proc]) [name (proc name)])) + (dict.from-list text.Hash))) diff --git a/stdlib/source/lux/lang/compiler/extension/analysis/common.lux b/stdlib/source/lux/lang/compiler/extension/analysis/common.lux new file mode 100644 index 000000000..6bd1a93bf --- /dev/null +++ b/stdlib/source/lux/lang/compiler/extension/analysis/common.lux @@ -0,0 +1,396 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + [thread #+ Box]) + (concurrency [atom #+ Atom]) + (data [text] + text/format + (coll [list "list/" Functor] + [array] + (dictionary ["dict" unordered #+ Dict]))) + [lang] + (lang (type ["tc" check]) + (analysis [".A" type] + [".A" case] + [".A" function])) + [io #+ IO]) + (//// [compiler] + [analysis #+ Analysis]) + [///] + [///bundle]) + +(type: Handler + (///.Handler .Lux .Code Analysis)) + +## [Utils] +(def: (simple extension inputsT+ outputT) + (-> Text (List Type) Type ..Handler) + (let [num-expected (list.size inputsT+)] + (function (_ analyse args) + (let [num-actual (list.size args)] + (if (n/= num-expected num-actual) + (do compiler.Monad + [_ (typeA.infer outputT) + argsA (monad.map @ + (function (_ [argT argC]) + (typeA.with-type argT + (analyse argC))) + (list.zip2 inputsT+ args))] + (wrap (#///.Extension extension argsA))) + (lang.throw ///bundle.incorrect-arity [extension num-expected num-actual])))))) + +(def: #export (nullary valueT extension) + (-> Type Text ..Handler) + (simple extension (list) valueT)) + +(def: #export (unary inputT outputT extension) + (-> Type Type Text ..Handler) + (simple extension (list inputT) outputT)) + +(def: #export (binary subjectT paramT outputT extension) + (-> Type Type Type Text ..Handler) + (simple extension (list subjectT paramT) outputT)) + +(def: #export (trinary subjectT param0T param1T outputT extension) + (-> Type Type Type Type Text ..Handler) + (simple extension (list subjectT param0T param1T) outputT)) + +## [Analysers] +## "lux is" represents reference/pointer equality. +(def: (lux//is extension) + (-> Text ..Handler) + (function (_ analyse args) + (do compiler.Monad + [[var-id varT] (typeA.with-env tc.var)] + ((binary varT varT Bool extension) + analyse args)))) + +## "lux try" provides a simple way to interact with the host platform's +## error-handling facilities. +(def: (lux//try extension) + (-> Text ..Handler) + (function (_ analyse args) + (case args + (^ (list opC)) + (do compiler.Monad + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (Either Text varT))) + opA (typeA.with-type (type (IO varT)) + (analyse opC))] + (wrap (#///.Extension extension (list opA)))) + + _ + (lang.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + +(def: (lux//in-module extension) + (-> Text ..Handler) + (function (_ analyse argsC+) + (case argsC+ + (^ (list [_ (#.Text module-name)] exprC)) + (lang.with-current-module module-name + (analyse exprC)) + + _ + (lang.throw ///bundle.invalid-syntax [extension])))) + +## (do-template [ ] +## [(def: ( extension) +## (-> Text ..Handler) +## (function (_ analyse args) +## (case args +## (^ (list typeC valueC)) +## (do compiler.Monad +## [actualT (eval Type typeC) +## _ (typeA.infer (:! Type actualT))] +## (typeA.with-type +## (analyse valueC))) + +## _ +## (lang.throw ///bundle.incorrect-arity [extension +2 (list.size args)]))))] + +## [lux//check (:! Type actualT)] +## [lux//coerce Any] +## ) + +(def: (lux//check//type extension) + (-> Text ..Handler) + (function (_ analyse args) + (case args + (^ (list valueC)) + (do compiler.Monad + [_ (typeA.infer Type) + valueA (typeA.with-type Type + (analyse valueC))] + (wrap valueA)) + + _ + (lang.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + +(def: bundle/lux + ///.Bundle + (|> ///.fresh + (///bundle.install "is" lux//is) + (///bundle.install "try" lux//try) + (///bundle.install "check" lux//check) + (///bundle.install "coerce" lux//coerce) + (///bundle.install "check type" lux//check//type) + (///bundle.install "in-module" lux//in-module))) + +(def: bundle/io + ///.Bundle + (<| (///bundle.prefix "io") + (|> ///.fresh + (///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: bundle/bit + ///.Bundle + (<| (///bundle.prefix "bit") + (|> ///.fresh + (///bundle.install "and" (binary Nat Nat Nat)) + (///bundle.install "or" (binary Nat Nat Nat)) + (///bundle.install "xor" (binary Nat Nat Nat)) + (///bundle.install "left-shift" (binary Nat Nat Nat)) + (///bundle.install "logical-right-shift" (binary Nat Nat Nat)) + (///bundle.install "arithmetic-right-shift" (binary Int Nat Int)) + ))) + +(def: bundle/int + ///.Bundle + (<| (///bundle.prefix "int") + (|> ///.fresh + (///bundle.install "+" (binary Int Int Int)) + (///bundle.install "-" (binary Int Int Int)) + (///bundle.install "*" (binary Int Int Int)) + (///bundle.install "/" (binary Int Int Int)) + (///bundle.install "%" (binary Int Int Int)) + (///bundle.install "=" (binary Int Int Bool)) + (///bundle.install "<" (binary Int Int Bool)) + (///bundle.install "min" (nullary Int)) + (///bundle.install "max" (nullary Int)) + (///bundle.install "to-nat" (unary Int Nat)) + (///bundle.install "to-frac" (unary Int Frac)) + (///bundle.install "char" (unary Int Text))))) + +(def: bundle/deg + ///.Bundle + (<| (///bundle.prefix "deg") + (|> ///.fresh + (///bundle.install "+" (binary Deg Deg Deg)) + (///bundle.install "-" (binary Deg Deg Deg)) + (///bundle.install "*" (binary Deg Deg Deg)) + (///bundle.install "/" (binary Deg Deg Deg)) + (///bundle.install "%" (binary Deg Deg Deg)) + (///bundle.install "=" (binary Deg Deg Bool)) + (///bundle.install "<" (binary Deg Deg Bool)) + (///bundle.install "scale" (binary Deg Nat Deg)) + (///bundle.install "reciprocal" (binary Deg Nat Deg)) + (///bundle.install "min" (nullary Deg)) + (///bundle.install "max" (nullary Deg)) + (///bundle.install "to-frac" (unary Deg Frac))))) + +(def: bundle/frac + ///.Bundle + (<| (///bundle.prefix "frac") + (|> ///.fresh + (///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 Bool)) + (///bundle.install "<" (binary Frac Frac Bool)) + (///bundle.install "smallest" (nullary Frac)) + (///bundle.install "min" (nullary Frac)) + (///bundle.install "max" (nullary Frac)) + (///bundle.install "not-a-number" (nullary Frac)) + (///bundle.install "positive-infinity" (nullary Frac)) + (///bundle.install "negative-infinity" (nullary Frac)) + (///bundle.install "to-deg" (unary Frac Deg)) + (///bundle.install "to-int" (unary Frac Int)) + (///bundle.install "encode" (unary Frac Text)) + (///bundle.install "decode" (unary Text (type (Maybe Frac))))))) + +(def: bundle/text + ///.Bundle + (<| (///bundle.prefix "text") + (|> ///.fresh + (///bundle.install "=" (binary Text Text Bool)) + (///bundle.install "<" (binary Text Text Bool)) + (///bundle.install "concat" (binary Text Text Text)) + (///bundle.install "index" (trinary Text Text Nat (type (Maybe Nat)))) + (///bundle.install "size" (unary Text Nat)) + (///bundle.install "hash" (unary Text Nat)) + (///bundle.install "replace-once" (trinary Text Text Text Text)) + (///bundle.install "replace-all" (trinary Text Text Text Text)) + (///bundle.install "char" (binary Text Nat (type (Maybe Nat)))) + (///bundle.install "clip" (trinary Text Nat Nat (type (Maybe Text)))) + ))) + +(def: (array//get extension) + (-> Text ..Handler) + (function (_ analyse args) + (do compiler.Monad + [[var-id varT] (typeA.with-env tc.var)] + ((binary (type (Array varT)) Nat (type (Maybe varT)) extension) + analyse args)))) + +(def: (array//put extension) + (-> Text ..Handler) + (function (_ analyse args) + (do compiler.Monad + [[var-id varT] (typeA.with-env tc.var)] + ((trinary (type (Array varT)) Nat varT (type (Array varT)) extension) + analyse args)))) + +(def: (array//remove extension) + (-> Text ..Handler) + (function (_ analyse args) + (do compiler.Monad + [[var-id varT] (typeA.with-env tc.var)] + ((binary (type (Array varT)) Nat (type (Array varT)) extension) + analyse args)))) + +(def: bundle/array + ///.Bundle + (<| (///bundle.prefix "array") + (|> ///.fresh + (///bundle.install "new" (unary Nat Array)) + (///bundle.install "get" array//get) + (///bundle.install "put" array//put) + (///bundle.install "remove" array//remove) + (///bundle.install "size" (unary (type (Ex [a] (Array a))) Nat)) + ))) + +(def: bundle/math + ///.Bundle + (<| (///bundle.prefix "math") + (|> ///.fresh + (///bundle.install "cos" (unary Frac Frac)) + (///bundle.install "sin" (unary Frac Frac)) + (///bundle.install "tan" (unary Frac Frac)) + (///bundle.install "acos" (unary Frac Frac)) + (///bundle.install "asin" (unary Frac Frac)) + (///bundle.install "atan" (unary Frac Frac)) + (///bundle.install "cosh" (unary Frac Frac)) + (///bundle.install "sinh" (unary Frac Frac)) + (///bundle.install "tanh" (unary Frac Frac)) + (///bundle.install "exp" (unary Frac Frac)) + (///bundle.install "log" (unary Frac Frac)) + (///bundle.install "ceil" (unary Frac Frac)) + (///bundle.install "floor" (unary Frac Frac)) + (///bundle.install "round" (unary Frac Frac)) + (///bundle.install "atan2" (binary Frac Frac Frac)) + (///bundle.install "pow" (binary Frac Frac Frac)) + ))) + +(def: (atom-new extension) + (-> Text ..Handler) + (function (_ analyse args) + (case args + (^ (list initC)) + (do compiler.Monad + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (Atom varT))) + initA (typeA.with-type varT + (analyse initC))] + (wrap (#///.Extension extension (list initA)))) + + _ + (lang.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + +(def: (atom-read extension) + (-> Text ..Handler) + (function (_ analyse args) + (do compiler.Monad + [[var-id varT] (typeA.with-env tc.var)] + ((unary (type (Atom varT)) varT extension) + analyse args)))) + +(def: (atom//compare-and-swap extension) + (-> Text ..Handler) + (function (_ analyse args) + (do compiler.Monad + [[var-id varT] (typeA.with-env tc.var)] + ((trinary (type (Atom varT)) varT varT Bool extension) + analyse args)))) + +(def: bundle/atom + ///.Bundle + (<| (///bundle.prefix "atom") + (|> ///.fresh + (///bundle.install "new" atom-new) + (///bundle.install "read" atom-read) + (///bundle.install "compare-and-swap" atom//compare-and-swap) + ))) + +(def: (box//new extension) + (-> Text ..Handler) + (function (_ analyse args) + (case args + (^ (list initC)) + (do compiler.Monad + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (All [!] (Box ! varT)))) + initA (typeA.with-type varT + (analyse initC))] + (wrap (#///.Extension extension (list initA)))) + + _ + (lang.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + +(def: (box//read extension) + (-> Text ..Handler) + (function (_ analyse args) + (do compiler.Monad + [[thread-id threadT] (typeA.with-env tc.var) + [var-id varT] (typeA.with-env tc.var)] + ((unary (type (Box threadT varT)) varT extension) + analyse args)))) + +(def: (box//write extension) + (-> Text ..Handler) + (function (_ analyse args) + (do compiler.Monad + [[thread-id threadT] (typeA.with-env tc.var) + [var-id varT] (typeA.with-env tc.var)] + ((binary varT (type (Box threadT varT)) Any extension) + analyse args)))) + +(def: bundle/box + ///.Bundle + (<| (///bundle.prefix "box") + (|> ///.fresh + (///bundle.install "new" box//new) + (///bundle.install "read" box//read) + (///bundle.install "write" box//write) + ))) + +(def: bundle/process + ///.Bundle + (<| (///bundle.prefix "process") + (|> ///.fresh + (///bundle.install "parallelism" (nullary Nat)) + (///bundle.install "schedule" (binary Nat (type (IO Any)) Any)) + ))) + +(def: #export bundle + ///.Bundle + (<| (///bundle.prefix "lux") + (|> ///.fresh + (dict.merge bundle/lux) + (dict.merge bundle/bit) + (dict.merge bundle/int) + (dict.merge bundle/deg) + (dict.merge bundle/frac) + (dict.merge bundle/text) + (dict.merge bundle/array) + (dict.merge bundle/math) + (dict.merge bundle/atom) + (dict.merge bundle/box) + (dict.merge bundle/process) + (dict.merge bundle/io)) + )) diff --git a/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux new file mode 100644 index 000000000..56da166c5 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux @@ -0,0 +1,1224 @@ +(.module: + [lux #- char int] + (lux (control [monad #+ do] + ["p" parser] + ["ex" exception #+ exception:]) + (concurrency ["A" atom]) + (data ["e" error] + [maybe] + [product] + [bool "bool/" Eq] + [text "text/" Eq] + (text format + ["l" lexer]) + (coll [list "list/" Fold Functor Monoid] + [array] + (dictionary ["dict" unordered #+ Dict]))) + [macro "macro/" Monad] + (macro [code] + ["s" syntax]) + [lang] + (lang [type] + (type ["tc" check]) + [".L" analysis #+ Analysis] + (analysis [".A" type] + [".A" inference])) + [host]) + ["/" //common] + [///] + ) + +(host.import #long java/lang/reflect/Type + (getTypeName [] String)) + +(def: jvm-type-name + (-> java/lang/reflect/Type Text) + (java/lang/reflect/Type::getTypeName [])) + +(exception: #export (jvm-type-is-not-a-class {jvm-type java/lang/reflect/Type}) + (jvm-type-name jvm-type)) + +(do-template [] + [(exception: #export ( {type Type}) + (%type type))] + + [non-object] + [non-array] + [non-jvm-type] + ) + +(do-template [] + [(exception: #export ( {name Text}) + name)] + + [non-interface] + [non-throwable] + ) + +(do-template [] + [(exception: #export ( {message Text}) + message)] + + [Unknown-Class] + [Primitives-Cannot-Have-Type-Parameters] + [Primitives-Are-Not-Objects] + [Invalid-Type-For-Array-Element] + + [Unknown-Field] + [Mistaken-Field-Owner] + [Not-Virtual-Field] + [Not-Static-Field] + [Cannot-Set-Final-Field] + + [No-Candidates] + [Too-Many-Candidates] + + [Cannot-Cast] + + [Cannot-Possibly-Be-Instance] + + [Cannot-Convert-To-Class] + [Cannot-Convert-To-Parameter] + [Cannot-Convert-To-Lux-Type] + [Unknown-Type-Var] + [Type-Parameter-Mismatch] + [Cannot-Correspond-Type-With-Class] + ) + +(do-template [ ] + [(def: #export Type (#.Primitive (list)))] + + ## Boxes + [Boolean "java.lang.Boolean"] + [Byte "java.lang.Byte"] + [Short "java.lang.Short"] + [Integer "java.lang.Integer"] + [Long "java.lang.Long"] + [Float "java.lang.Float"] + [Double "java.lang.Double"] + [Character "java.lang.Character"] + [String "java.lang.String"] + + ## Primitives + [boolean "boolean"] + [byte "byte"] + [short "short"] + [int "int"] + [long "long"] + [float "float"] + [double "double"] + [char "char"] + ) + +(def: conversion-procs + /.Bundle + (<| (/.prefix "convert") + (|> (dict.new text.Hash) + (/.install "double-to-float" (/.unary Double Float)) + (/.install "double-to-int" (/.unary Double Integer)) + (/.install "double-to-long" (/.unary Double Long)) + (/.install "float-to-double" (/.unary Float Double)) + (/.install "float-to-int" (/.unary Float Integer)) + (/.install "float-to-long" (/.unary Float Long)) + (/.install "int-to-byte" (/.unary Integer Byte)) + (/.install "int-to-char" (/.unary Integer Character)) + (/.install "int-to-double" (/.unary Integer Double)) + (/.install "int-to-float" (/.unary Integer Float)) + (/.install "int-to-long" (/.unary Integer Long)) + (/.install "int-to-short" (/.unary Integer Short)) + (/.install "long-to-double" (/.unary Long Double)) + (/.install "long-to-float" (/.unary Long Float)) + (/.install "long-to-int" (/.unary Long Integer)) + (/.install "long-to-short" (/.unary Long Short)) + (/.install "long-to-byte" (/.unary Long Byte)) + (/.install "char-to-byte" (/.unary Character Byte)) + (/.install "char-to-short" (/.unary Character Short)) + (/.install "char-to-int" (/.unary Character Integer)) + (/.install "char-to-long" (/.unary Character Long)) + (/.install "byte-to-long" (/.unary Byte Long)) + (/.install "short-to-long" (/.unary Short Long)) + ))) + +(do-template [ ] + [(def: + /.Bundle + (<| (/.prefix ) + (|> (dict.new text.Hash) + (/.install "+" (/.binary )) + (/.install "-" (/.binary )) + (/.install "*" (/.binary )) + (/.install "/" (/.binary )) + (/.install "%" (/.binary )) + (/.install "=" (/.binary Boolean)) + (/.install "<" (/.binary Boolean)) + (/.install "and" (/.binary )) + (/.install "or" (/.binary )) + (/.install "xor" (/.binary )) + (/.install "shl" (/.binary Integer )) + (/.install "shr" (/.binary Integer )) + (/.install "ushr" (/.binary Integer )) + )))] + + [int-procs "int" Integer] + [long-procs "long" Long] + ) + +(do-template [ ] + [(def: + /.Bundle + (<| (/.prefix ) + (|> (dict.new text.Hash) + (/.install "+" (/.binary )) + (/.install "-" (/.binary )) + (/.install "*" (/.binary )) + (/.install "/" (/.binary )) + (/.install "%" (/.binary )) + (/.install "=" (/.binary Boolean)) + (/.install "<" (/.binary Boolean)) + )))] + + [float-procs "float" Float] + [double-procs "double" Double] + ) + +(def: char-procs + /.Bundle + (<| (/.prefix "char") + (|> (dict.new text.Hash) + (/.install "=" (/.binary Character Character Boolean)) + (/.install "<" (/.binary Character Character Boolean)) + ))) + +(def: #export boxes + (Dict Text Text) + (|> (list ["boolean" "java.lang.Boolean"] + ["byte" "java.lang.Byte"] + ["short" "java.lang.Short"] + ["int" "java.lang.Integer"] + ["long" "java.lang.Long"] + ["float" "java.lang.Float"] + ["double" "java.lang.Double"] + ["char" "java.lang.Character"]) + (dict.from-list text.Hash))) + +(def: (array//length proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list arrayC)) + (do macro.Monad + [_ (typeA.infer Nat) + [var-id varT] (typeA.with-env tc.var) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC))] + (wrap (#analysisL.Extension proc (list arrayA)))) + + _ + (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + +(def: (array//new proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list lengthC)) + (do macro.Monad + [lengthA (typeA.with-type Nat + (analyse lengthC)) + expectedT macro.expected-type + [level elem-class] (: (Meta [Nat Text]) + (loop [analysisT expectedT + level +0] + (case analysisT + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (recur outputT level) + + #.None + (lang.throw non-array expectedT)) + + (^ (#.Primitive "#Array" (list elemT))) + (recur elemT (inc level)) + + (#.Primitive class _) + (wrap [level class]) + + _ + (lang.throw non-array expectedT)))) + _ (if (n/> +0 level) + (wrap []) + (lang.throw non-array expectedT))] + (wrap (#analysisL.Extension proc (list (analysisL.nat (dec level)) + (analysisL.text elem-class) + lengthA)))) + + _ + (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + +(def: (check-jvm objectT) + (-> Type (Meta Text)) + (case objectT + (#.Primitive name _) + (macro/wrap name) + + (#.Named name unnamed) + (check-jvm unnamed) + + (#.Var id) + (macro/wrap "java.lang.Object") + + (^template [] + ( env unquantified) + (check-jvm unquantified)) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (check-jvm outputT) + + #.None + (lang.throw non-object objectT)) + + _ + (lang.throw non-object objectT))) + +(def: (check-object objectT) + (-> Type (Meta Text)) + (do macro.Monad + [name (check-jvm objectT)] + (if (dict.contains? name boxes) + (lang.throw Primitives-Are-Not-Objects name) + (macro/wrap name)))) + +(def: (box-array-element-type elemT) + (-> Type (Meta [Type Text])) + (case elemT + (#.Primitive name #.Nil) + (let [boxed-name (|> (dict.get name boxes) + (maybe.default name))] + (macro/wrap [(#.Primitive boxed-name #.Nil) + boxed-name])) + + (#.Primitive name _) + (if (dict.contains? name boxes) + (lang.throw Primitives-Cannot-Have-Type-Parameters name) + (macro/wrap [elemT name])) + + _ + (lang.throw Invalid-Type-For-Array-Element (%type elemT)))) + +(def: (array//read proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list arrayC idxC)) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer varT) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC)) + ?elemT (typeA.with-env + (tc.read var-id)) + [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (typeA.with-type Nat + (analyse idxC))] + (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA arrayA)))) + + _ + (lang.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + +(def: (array//write proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list arrayC idxC valueC)) + (do macro.Monad + [[var-id varT] (typeA.with-env tc.var) + _ (typeA.infer (type (Array varT))) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC)) + ?elemT (typeA.with-env + (tc.read var-id)) + [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (typeA.with-type Nat + (analyse idxC)) + valueA (typeA.with-type valueT + (analyse valueC))] + (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA valueA arrayA)))) + + _ + (lang.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) + +(def: array-procs + /.Bundle + (<| (/.prefix "array") + (|> (dict.new text.Hash) + (/.install "length" array//length) + (/.install "new" array//new) + (/.install "read" array//read) + (/.install "write" array//write) + ))) + +(def: (object//null proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list)) + (do macro.Monad + [expectedT macro.expected-type + _ (check-object expectedT)] + (wrap (#analysisL.Extension proc (list)))) + + _ + (lang.throw /.incorrect-extension-arity [proc +0 (list.size args)])))) + +(def: (object//null? proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list objectC)) + (do macro.Monad + [_ (typeA.infer Bool) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (check-object objectT)] + (wrap (#analysisL.Extension proc (list objectA)))) + + _ + (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + +(def: (object//synchronized proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list monitorC exprC)) + (do macro.Monad + [[monitorT monitorA] (typeA.with-inference + (analyse monitorC)) + _ (check-object monitorT) + exprA (analyse exprC)] + (wrap (#analysisL.Extension proc (list monitorA exprA)))) + + _ + (lang.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + +(host.import java/lang/Object + (equals [Object] boolean)) + +(host.import java/lang/ClassLoader) + +(host.import java/lang/reflect/GenericArrayType + (getGenericComponentType [] java/lang/reflect/Type)) + +(host.import java/lang/reflect/ParameterizedType + (getRawType [] java/lang/reflect/Type) + (getActualTypeArguments [] (Array java/lang/reflect/Type))) + +(host.import (java/lang/reflect/TypeVariable d) + (getName [] String) + (getBounds [] (Array java/lang/reflect/Type))) + +(host.import (java/lang/reflect/WildcardType d) + (getLowerBounds [] (Array java/lang/reflect/Type)) + (getUpperBounds [] (Array java/lang/reflect/Type))) + +(host.import java/lang/reflect/Modifier + (#static isStatic [int] boolean) + (#static isFinal [int] boolean) + (#static isInterface [int] boolean) + (#static isAbstract [int] boolean)) + +(host.import java/lang/reflect/Field + (getDeclaringClass [] (java/lang/Class Object)) + (getModifiers [] int) + (getGenericType [] java/lang/reflect/Type)) + +(host.import java/lang/reflect/Method + (getName [] String) + (getModifiers [] int) + (getDeclaringClass [] (Class Object)) + (getTypeParameters [] (Array (TypeVariable Method))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericReturnType [] java/lang/reflect/Type) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) + +(host.import (java/lang/reflect/Constructor c) + (getModifiers [] int) + (getDeclaringClass [] (Class c)) + (getTypeParameters [] (Array (TypeVariable (Constructor c)))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) + +(host.import (java/lang/Class c) + (getName [] String) + (getModifiers [] int) + (#static forName [String] #try (Class Object)) + (isAssignableFrom [(Class Object)] boolean) + (getTypeParameters [] (Array (TypeVariable (Class c)))) + (getGenericInterfaces [] (Array java/lang/reflect/Type)) + (getGenericSuperclass [] java/lang/reflect/Type) + (getDeclaredField [String] #try Field) + (getConstructors [] (Array (Constructor Object))) + (getDeclaredMethods [] (Array Method))) + +(def: (load-class name) + (-> Text (Meta (Class Object))) + (do macro.Monad + [] + (case (Class::forName [name]) + (#e.Success [class]) + (wrap class) + + (#e.Error error) + (lang.throw Unknown-Class name)))) + +(def: (sub-class? super sub) + (-> Text Text (Meta Bool)) + (do macro.Monad + [super (load-class super) + sub (load-class sub)] + (wrap (Class::isAssignableFrom [sub] super)))) + +(def: (object//throw proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list exceptionC)) + (do macro.Monad + [_ (typeA.infer Nothing) + [exceptionT exceptionA] (typeA.with-inference + (analyse exceptionC)) + exception-class (check-object exceptionT) + ? (sub-class? "java.lang.Throwable" exception-class) + _ (: (Meta Any) + (if ? + (wrap []) + (lang.throw non-throwable exception-class)))] + (wrap (#analysisL.Extension proc (list exceptionA)))) + + _ + (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + +(def: (object//class proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC)) + (case classC + [_ (#.Text class)] + (do macro.Monad + [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) + _ (load-class class)] + (wrap (#analysisL.Extension proc (list (analysisL.text class))))) + + _ + (lang.throw /.invalid-syntax [proc args])) + + _ + (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + +(def: (object//instance? proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC objectC)) + (case classC + [_ (#.Text class)] + (do macro.Monad + [_ (typeA.infer Bool) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + object-class (check-object objectT) + ? (sub-class? class object-class)] + (if ? + (wrap (#analysisL.Extension proc (list (analysisL.text class)))) + (lang.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class)))) + + _ + (lang.throw /.invalid-syntax [proc args])) + + _ + (lang.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + +(def: (java-type-to-class type) + (-> java/lang/reflect/Type (Meta Text)) + (cond (host.instance? Class type) + (macro/wrap (Class::getName [] (:! Class type))) + + (host.instance? ParameterizedType type) + (java-type-to-class (ParameterizedType::getRawType [] (:! ParameterizedType type))) + + ## else + (lang.throw Cannot-Convert-To-Class (jvm-type-name type)))) + +(type: Mappings + (Dict Text Type)) + +(def: fresh-mappings Mappings (dict.new text.Hash)) + +(def: (java-type-to-lux-type mappings java-type) + (-> Mappings java/lang/reflect/Type (Meta Type)) + (cond (host.instance? TypeVariable java-type) + (let [var-name (TypeVariable::getName [] (:! TypeVariable java-type))] + (case (dict.get var-name mappings) + (#.Some var-type) + (macro/wrap var-type) + + #.None + (lang.throw Unknown-Type-Var var-name))) + + (host.instance? WildcardType java-type) + (let [java-type (:! WildcardType java-type)] + (case [(array.read +0 (WildcardType::getUpperBounds [] java-type)) + (array.read +0 (WildcardType::getLowerBounds [] java-type))] + (^or [(#.Some bound) _] [_ (#.Some bound)]) + (java-type-to-lux-type mappings bound) + + _ + (macro/wrap Any))) + + (host.instance? Class java-type) + (let [java-type (:! (Class Object) java-type) + class-name (Class::getName [] java-type)] + (macro/wrap (case (array.size (Class::getTypeParameters [] java-type)) + +0 + (#.Primitive class-name (list)) + + arity + (|> (list.n/range +0 (dec arity)) + list.reverse + (list/map (|>> (n/* +2) inc #.Bound)) + (#.Primitive class-name) + (type.univ-q arity))))) + + (host.instance? ParameterizedType java-type) + (let [java-type (:! ParameterizedType java-type) + raw (ParameterizedType::getRawType [] java-type)] + (if (host.instance? Class raw) + (do macro.Monad + [paramsT (|> java-type + (ParameterizedType::getActualTypeArguments []) + array.to-list + (monad.map @ (java-type-to-lux-type mappings)))] + (macro/wrap (#.Primitive (Class::getName [] (:! (Class Object) raw)) + paramsT))) + (lang.throw jvm-type-is-not-a-class raw))) + + (host.instance? GenericArrayType java-type) + (do macro.Monad + [innerT (|> (:! GenericArrayType java-type) + (GenericArrayType::getGenericComponentType []) + (java-type-to-lux-type mappings))] + (wrap (#.Primitive "#Array" (list innerT)))) + + ## else + (lang.throw Cannot-Convert-To-Lux-Type (jvm-type-name java-type)))) + +(def: (correspond-type-params class type) + (-> (Class Object) Type (Meta Mappings)) + (case type + (#.Primitive name params) + (let [class-name (Class::getName [] class) + class-params (array.to-list (Class::getTypeParameters [] class)) + num-class-params (list.size class-params) + num-type-params (list.size params)] + (cond (not (text/= class-name name)) + (lang.throw Cannot-Correspond-Type-With-Class + (format "Class = " class-name "\n" + "Type = " (%type type))) + + (not (n/= num-class-params num-type-params)) + (lang.throw Type-Parameter-Mismatch + (format "Expected: " (%i (.int num-class-params)) "\n" + " Actual: " (%i (.int num-type-params)) "\n" + " Class: " class-name "\n" + " Type: " (%type type))) + + ## else + (macro/wrap (|> params + (list.zip2 (list/map (TypeVariable::getName []) class-params)) + (dict.from-list text.Hash))) + )) + + _ + (lang.throw non-jvm-type type))) + +(def: (object//cast proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list valueC)) + (do macro.Monad + [toT macro.expected-type + to-name (check-jvm toT) + [valueT valueA] (typeA.with-inference + (analyse valueC)) + from-name (check-jvm valueT) + can-cast? (: (Meta Bool) + (case [from-name to-name] + (^template [ ] + (^or [ ] + [ ]) + (do @ + [_ (typeA.infer (#.Primitive to-name (list)))] + (wrap true))) + (["boolean" "java.lang.Boolean"] + ["byte" "java.lang.Byte"] + ["short" "java.lang.Short"] + ["int" "java.lang.Integer"] + ["long" "java.lang.Long"] + ["float" "java.lang.Float"] + ["double" "java.lang.Double"] + ["char" "java.lang.Character"]) + + _ + (do @ + [_ (lang.assert Primitives-Are-Not-Objects from-name + (not (dict.contains? from-name boxes))) + _ (lang.assert Primitives-Are-Not-Objects to-name + (not (dict.contains? to-name boxes))) + to-class (load-class to-name)] + (loop [[current-name currentT] [from-name valueT]] + (if (text/= to-name current-name) + (do @ + [_ (typeA.infer toT)] + (wrap true)) + (do @ + [current-class (load-class current-name) + _ (lang.assert Cannot-Cast (format "From class/primitive: " current-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n") + (Class::isAssignableFrom [current-class] to-class)) + candiate-parents (monad.map @ + (function (_ java-type) + (do @ + [class-name (java-type-to-class java-type) + class (load-class class-name)] + (wrap [[class-name java-type] (Class::isAssignableFrom [class] to-class)]))) + (list& (Class::getGenericSuperclass [] current-class) + (array.to-list (Class::getGenericInterfaces [] current-class))))] + (case (|> candiate-parents + (list.filter product.right) + (list/map product.left)) + (#.Cons [next-name nextJT] _) + (do @ + [mapping (correspond-type-params current-class currentT) + nextT (java-type-to-lux-type mapping nextJT)] + (recur [next-name nextT])) + + #.Nil + (lang.throw Cannot-Cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n"))) + ))))))] + (if can-cast? + (wrap (#analysisL.Extension proc (list (analysisL.text from-name) + (analysisL.text to-name) + valueA))) + (lang.throw Cannot-Cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n")))) + + _ + (lang.throw /.invalid-syntax [proc args])))) + +(def: object-procs + /.Bundle + (<| (/.prefix "object") + (|> (dict.new text.Hash) + (/.install "null" object//null) + (/.install "null?" object//null?) + (/.install "synchronized" object//synchronized) + (/.install "throw" object//throw) + (/.install "class" object//class) + (/.install "instance?" object//instance?) + (/.install "cast" object//cast) + ))) + +(def: (find-field class-name field-name) + (-> Text Text (Meta [(Class Object) Field])) + (do macro.Monad + [class (load-class class-name)] + (case (Class::getDeclaredField [field-name] class) + (#e.Success field) + (let [owner (Field::getDeclaringClass [] field)] + (if (is? owner class) + (wrap [class field]) + (lang.throw Mistaken-Field-Owner + (format " Field: " field-name "\n" + " Owner Class: " (Class::getName [] owner) "\n" + "Target Class: " class-name "\n")))) + + (#e.Error _) + (lang.throw Unknown-Field (format class-name "#" field-name))))) + +(def: (static-field class-name field-name) + (-> Text Text (Meta [Type Bool])) + (do macro.Monad + [[class fieldJ] (find-field class-name field-name) + #let [modifiers (Field::getModifiers [] fieldJ)]] + (if (Modifier::isStatic [modifiers]) + (let [fieldJT (Field::getGenericType [] fieldJ)] + (do @ + [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] + (wrap [fieldT (Modifier::isFinal [modifiers])]))) + (lang.throw Not-Static-Field (format class-name "#" field-name))))) + +(def: (virtual-field class-name field-name objectT) + (-> Text Text Type (Meta [Type Bool])) + (do macro.Monad + [[class fieldJ] (find-field class-name field-name) + #let [modifiers (Field::getModifiers [] fieldJ)]] + (if (not (Modifier::isStatic [modifiers])) + (do @ + [#let [fieldJT (Field::getGenericType [] fieldJ) + var-names (|> class + (Class::getTypeParameters []) + array.to-list + (list/map (TypeVariable::getName [])))] + mappings (: (Meta Mappings) + (case objectT + (#.Primitive _class-name _class-params) + (do @ + [#let [num-params (list.size _class-params) + num-vars (list.size var-names)] + _ (lang.assert Type-Parameter-Mismatch + (format "Expected: " (%i (.int num-params)) "\n" + " Actual: " (%i (.int num-vars)) "\n" + " Class: " _class-name "\n" + " Type: " (%type objectT)) + (n/= num-params num-vars))] + (wrap (|> (list.zip2 var-names _class-params) + (dict.from-list text.Hash)))) + + _ + (lang.throw non-object objectT))) + fieldT (java-type-to-lux-type mappings fieldJT)] + (wrap [fieldT (Modifier::isFinal [modifiers])])) + (lang.throw Not-Virtual-Field (format class-name "#" field-name))))) + +(def: (static//get proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC fieldC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad + [[fieldT final?] (static-field class field)] + (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field))))) + + _ + (lang.throw /.invalid-syntax [proc args])) + + _ + (lang.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + +(def: (static//put proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC fieldC valueC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad + [_ (typeA.infer Any) + [fieldT final?] (static-field class field) + _ (lang.assert Cannot-Set-Final-Field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA)))) + + _ + (lang.throw /.invalid-syntax [proc args])) + + _ + (lang.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) + +(def: (virtual//get proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC fieldC objectC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + [fieldT final?] (virtual-field class field objectT)] + (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) objectA)))) + + _ + (lang.throw /.invalid-syntax [proc args])) + + _ + (lang.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) + +(def: (virtual//put proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case args + (^ (list classC fieldC valueC objectC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do macro.Monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (typeA.infer objectT) + [fieldT final?] (virtual-field class field objectT) + _ (lang.assert Cannot-Set-Final-Field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA objectA)))) + + _ + (lang.throw /.invalid-syntax [proc args])) + + _ + (lang.throw /.incorrect-extension-arity [proc +4 (list.size args)])))) + +(def: (java-type-to-parameter type) + (-> java/lang/reflect/Type (Meta Text)) + (cond (host.instance? Class type) + (macro/wrap (Class::getName [] (:! Class type))) + + (host.instance? ParameterizedType type) + (java-type-to-parameter (ParameterizedType::getRawType [] (:! ParameterizedType type))) + + (or (host.instance? TypeVariable type) + (host.instance? WildcardType type)) + (macro/wrap "java.lang.Object") + + (host.instance? GenericArrayType type) + (do macro.Monad + [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:! GenericArrayType type)))] + (wrap (format componentP "[]"))) + + ## else + (lang.throw Cannot-Convert-To-Parameter (jvm-type-name type)))) + +(type: Method-Type + #Static + #Abstract + #Virtual + #Special + #Interface) + +(def: (check-method class method-name method-type arg-classes method) + (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool)) + (do macro.Monad + [parameters (|> (Method::getGenericParameterTypes [] method) + array.to-list + (monad.map @ java-type-to-parameter)) + #let [modifiers (Method::getModifiers [] method)]] + (wrap (and (Object::equals [class] (Method::getDeclaringClass [] method)) + (text/= method-name (Method::getName [] method)) + (case #Static + #Special + (Modifier::isStatic [modifiers]) + + _ + true) + (case method-type + #Special + (not (or (Modifier::isInterface [(Class::getModifiers [] class)]) + (Modifier::isAbstract [modifiers]))) + + _ + true) + (n/= (list.size arg-classes) (list.size parameters)) + (list/fold (function (_ [expectedJC actualJC] prev) + (and prev + (text/= expectedJC actualJC))) + true + (list.zip2 arg-classes parameters)))))) + +(def: (check-constructor class arg-classes constructor) + (-> (Class Object) (List Text) (Constructor Object) (Meta Bool)) + (do macro.Monad + [parameters (|> (Constructor::getGenericParameterTypes [] constructor) + array.to-list + (monad.map @ java-type-to-parameter))] + (wrap (and (Object::equals [class] (Constructor::getDeclaringClass [] constructor)) + (n/= (list.size arg-classes) (list.size parameters)) + (list/fold (function (_ [expectedJC actualJC] prev) + (and prev + (text/= expectedJC actualJC))) + true + (list.zip2 arg-classes parameters)))))) + +(def: idx-to-bound + (-> Nat Type) + (|>> (n/* +2) inc #.Bound)) + +(def: (type-vars amount offset) + (-> Nat Nat (List Type)) + (if (n/= +0 amount) + (list) + (|> (list.n/range offset (|> amount dec (n/+ offset))) + (list/map idx-to-bound)))) + +(def: (method-to-type method-type method) + (-> Method-Type Method (Meta [Type (List Type)])) + (let [owner (Method::getDeclaringClass [] method) + owner-name (Class::getName [] owner) + owner-tvars (case method-type + #Static + (list) + + _ + (|> (Class::getTypeParameters [] owner) + array.to-list + (list/map (TypeVariable::getName [])))) + method-tvars (|> (Method::getTypeParameters [] method) + array.to-list + (list/map (TypeVariable::getName []))) + num-owner-tvars (list.size owner-tvars) + num-method-tvars (list.size method-tvars) + all-tvars (list/compose owner-tvars method-tvars) + num-all-tvars (list.size all-tvars) + owner-tvarsT (type-vars num-owner-tvars +0) + method-tvarsT (type-vars num-method-tvars num-owner-tvars) + mappings (: Mappings + (if (list.empty? all-tvars) + fresh-mappings + (|> (list/compose owner-tvarsT method-tvarsT) + list.reverse + (list.zip2 all-tvars) + (dict.from-list text.Hash))))] + (do macro.Monad + [inputsT (|> (Method::getGenericParameterTypes [] method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + outputT (java-type-to-lux-type mappings (Method::getGenericReturnType [] method)) + exceptionsT (|> (Method::getGenericExceptionTypes [] method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [methodT (<| (type.univ-q num-all-tvars) + (type.function (case method-type + #Static + inputsT + + _ + (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) + inputsT))) + outputT)]] + (wrap [methodT exceptionsT])))) + +(def: (methods class-name method-name method-type arg-classes) + (-> Text Text Method-Type (List Text) (Meta [Type (List Type)])) + (do macro.Monad + [class (load-class class-name) + candidates (|> class + (Class::getDeclaredMethods []) + array.to-list + (monad.map @ (function (_ method) + (do @ + [passes? (check-method class method-name method-type arg-classes method)] + (wrap [passes? method])))))] + (case (list.filter product.left candidates) + #.Nil + (lang.throw No-Candidates (format class-name "#" method-name)) + + (#.Cons candidate #.Nil) + (|> candidate product.right (method-to-type method-type)) + + _ + (lang.throw Too-Many-Candidates (format class-name "#" method-name))))) + +(def: (constructor-to-type constructor) + (-> (Constructor Object) (Meta [Type (List Type)])) + (let [owner (Constructor::getDeclaringClass [] constructor) + owner-name (Class::getName [] owner) + owner-tvars (|> (Class::getTypeParameters [] owner) + array.to-list + (list/map (TypeVariable::getName []))) + constructor-tvars (|> (Constructor::getTypeParameters [] constructor) + array.to-list + (list/map (TypeVariable::getName []))) + num-owner-tvars (list.size owner-tvars) + all-tvars (list/compose owner-tvars constructor-tvars) + num-all-tvars (list.size all-tvars) + owner-tvarsT (type-vars num-owner-tvars +0) + constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) + mappings (: Mappings + (if (list.empty? all-tvars) + fresh-mappings + (|> (list/compose owner-tvarsT constructor-tvarsT) + list.reverse + (list.zip2 all-tvars) + (dict.from-list text.Hash))))] + (do macro.Monad + [inputsT (|> (Constructor::getGenericParameterTypes [] constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + exceptionsT (|> (Constructor::getGenericExceptionTypes [] constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT)) + constructorT (<| (type.univ-q num-all-tvars) + (type.function inputsT) + objectT)]] + (wrap [constructorT exceptionsT])))) + +(def: (constructor-methods class-name arg-classes) + (-> Text (List Text) (Meta [Type (List Type)])) + (do macro.Monad + [class (load-class class-name) + candidates (|> class + (Class::getConstructors []) + array.to-list + (monad.map @ (function (_ constructor) + (do @ + [passes? (check-constructor class arg-classes constructor)] + (wrap [passes? constructor])))))] + (case (list.filter product.left candidates) + #.Nil + (lang.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")")) + + (#.Cons candidate #.Nil) + (|> candidate product.right constructor-to-type) + + _ + (lang.throw Too-Many-Candidates class-name)))) + +(def: (decorate-inputs typesT inputsA) + (-> (List Text) (List Analysis) (List Analysis)) + (|> inputsA + (list.zip2 (list/map analysisL.text typesT)) + (list/map (function (_ [type value]) + (analysisL.product-analysis (list type value)))))) + +(def: (invoke//static proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [Text Text (List [Text Code])]) + (s.run args ($_ p.seq s.text s.text (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class method argsTC]) + (do macro.Monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (methods class method #Static argsT) + [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) + outputJC (check-jvm outputT)] + (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) + (analysisL.text outputJC) (decorate-inputs argsT argsA))))) + + _ + (lang.throw /.invalid-syntax [proc args])))) + +(def: (invoke//virtual proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class method objectC argsTC]) + (do macro.Monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (methods class 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))] + outputJC (check-jvm outputT)] + (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) + (analysisL.text outputJC) objectA (decorate-inputs argsT argsA))))) + + _ + (lang.throw /.invalid-syntax [proc args])))) + +(def: (invoke//special proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Any]]) + (p.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))) s.end!))) + (#e.Success [_ [class method objectC argsTC _]]) + (do macro.Monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (methods class method #Special argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) + (analysisL.text outputJC) (decorate-inputs argsT argsA))))) + + _ + (lang.throw /.invalid-syntax [proc args])))) + +(def: (invoke//interface proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class-name method objectC argsTC]) + (do macro.Monad + [#let [argsT (list/map product.left argsTC)] + class (load-class class-name) + _ (lang.assert non-interface class-name + (Modifier::isInterface [(Class::getModifiers [] class)])) + [methodT exceptionsT] (methods class-name method #Interface argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#analysisL.Extension proc + (list& (analysisL.text class-name) (analysisL.text method) (analysisL.text outputJC) + (decorate-inputs argsT argsA))))) + + _ + (lang.throw /.invalid-syntax [proc args])))) + +(def: (invoke//constructor proc) + (-> Text ///.Analysis) + (function (_ analyse eval args) + (case (: (e.Error [Text (List [Text Code])]) + (s.run args ($_ p.seq s.text (p.some (s.tuple (p.seq s.text s.any)))))) + (#e.Success [class argsTC]) + (do macro.Monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (constructor-methods class argsT) + [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] + (wrap (#analysisL.Extension proc (list& (analysisL.text class) (decorate-inputs argsT argsA))))) + + _ + (lang.throw /.invalid-syntax [proc args])))) + +(def: member-procs + /.Bundle + (<| (/.prefix "member") + (|> (dict.new text.Hash) + (dict.merge (<| (/.prefix "static") + (|> (dict.new text.Hash) + (/.install "get" static//get) + (/.install "put" static//put)))) + (dict.merge (<| (/.prefix "virtual") + (|> (dict.new text.Hash) + (/.install "get" virtual//get) + (/.install "put" virtual//put)))) + (dict.merge (<| (/.prefix "invoke") + (|> (dict.new text.Hash) + (/.install "static" invoke//static) + (/.install "virtual" invoke//virtual) + (/.install "special" invoke//special) + (/.install "interface" invoke//interface) + (/.install "constructor" invoke//constructor) + ))) + ))) + +(def: #export extensions + /.Bundle + (<| (/.prefix "jvm") + (|> (dict.new text.Hash) + (dict.merge conversion-procs) + (dict.merge int-procs) + (dict.merge long-procs) + (dict.merge float-procs) + (dict.merge double-procs) + (dict.merge char-procs) + (dict.merge array-procs) + (dict.merge object-procs) + (dict.merge member-procs) + ))) diff --git a/stdlib/source/lux/lang/compiler/extension/bundle.lux b/stdlib/source/lux/lang/compiler/extension/bundle.lux new file mode 100644 index 000000000..ff4bd66ad --- /dev/null +++ b/stdlib/source/lux/lang/compiler/extension/bundle.lux @@ -0,0 +1,31 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [text] + text/format + (coll [list "list/" Functor] + (dictionary ["dict" unordered #+ Dict])))) + [//]) + +(exception: #export (incorrect-arity {name Text} {arity Nat} {args Nat}) + (ex.report ["Extension" (%t name)] + ["Expected arity" (|> arity .int %i)] + ["Actual arity" (|> args .int %i)])) + +(exception: #export (invalid-syntax {name Text}) + (ex.report ["Extension" name])) + +## [Utils] +(def: #export (install name anonymous) + (All [s i o] + (-> Text (-> Text (//.Handler s i o)) + (-> (//.Bundle s i o) (//.Bundle s i o)))) + (dict.put name anonymous)) + +(def: #export (prefix prefix) + (All [s i o] + (-> Text (-> (//.Bundle s i o) (//.Bundle s i o)))) + (|>> dict.entries + (list/map (function (_ [key val]) [(format prefix " " key) val])) + (dict.from-list text.Hash))) diff --git a/stdlib/source/lux/lang/compiler/extension/synthesis.lux b/stdlib/source/lux/lang/compiler/extension/synthesis.lux new file mode 100644 index 000000000..c48f3e3a5 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/extension/synthesis.lux @@ -0,0 +1,9 @@ +(.module: + lux + (lux (data [text] + (coll (dictionary ["dict" unordered #+ Dict])))) + [//]) + +(def: #export defaults + (Dict Text //.Synthesis) + (dict.new text.Hash)) diff --git a/stdlib/source/lux/lang/compiler/extension/translation.lux b/stdlib/source/lux/lang/compiler/extension/translation.lux new file mode 100644 index 000000000..bc95ed1f4 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/extension/translation.lux @@ -0,0 +1,9 @@ +(.module: + lux + (lux (data [text] + (coll (dictionary ["dict" unordered #+ Dict])))) + [//]) + +(def: #export defaults + (Dict Text //.Translation) + (dict.new text.Hash)) diff --git a/stdlib/source/lux/lang/compiler/init.lux b/stdlib/source/lux/lang/compiler/init.lux new file mode 100644 index 000000000..92a066b7e --- /dev/null +++ b/stdlib/source/lux/lang/compiler/init.lux @@ -0,0 +1,51 @@ +(.module: + lux + [///] + [///host]) + +(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: #export type-context + Type-Context + {#.ex-counter +0 + #.var-counter +0 + #.var-bindings (list)}) + +(`` (def: #export info + Info + {#.target (for {(~~ (static ///host.common-lisp)) ///host.common-lisp + (~~ (static ///host.js)) ///host.js + (~~ (static ///host.jvm)) ///host.jvm + (~~ (static ///host.lua)) ///host.lua + (~~ (static ///host.php)) ///host.php + (~~ (static ///host.python)) ///host.python + (~~ (static ///host.r)) ///host.r + (~~ (static ///host.ruby)) ///host.ruby + (~~ (static ///host.scheme)) ///host.scheme}) + #.version ///.version + #.mode #.Build})) + +(def: #export (compiler host) + (-> 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/lang/compiler/synthesis.lux b/stdlib/source/lux/lang/compiler/synthesis.lux new file mode 100644 index 000000000..eece3c7ab --- /dev/null +++ b/stdlib/source/lux/lang/compiler/synthesis.lux @@ -0,0 +1,241 @@ +(.module: + [lux #- i64 Scope] + (lux (control [monad #+ do]) + (data [error #+ Error] + (coll (dictionary ["dict" unordered #+ Dict])))) + [///reference #+ Register Variable Reference] + [// #+ Operation Compiler] + [//analysis #+ Environment Arity Analysis]) + +(type: #export Resolver (Dict Variable Variable)) + +(type: #export State + {#scope-arity Arity + #resolver Resolver + #direct? Bool + #locals Nat}) + +(def: #export fresh-resolver + Resolver + (dict.new ///reference.Hash)) + +(def: #export init + State + {#scope-arity +0 + #resolver fresh-resolver + #direct? false + #locals +0}) + +(type: #export Primitive + (#Bool Bool) + (#I64 I64) + (#F64 Frac) + (#Text Text)) + +(type: #export (Structure a) + (#Variant (//analysis.Variant a)) + (#Tuple (//analysis.Tuple a))) + +(type: #export Side + (Either Nat Nat)) + +(type: #export Member + (Either Nat Nat)) + +(type: #export Access + (#Side Side) + (#Member Member)) + +(type: #export (Path' s) + #Pop + (#Test Primitive) + (#Access Access) + (#Bind Register) + (#Alt (Path' s) (Path' s)) + (#Seq (Path' s) (Path' s)) + (#Then s)) + +(type: #export (Abstraction' s) + {#environment Environment + #arity Arity + #body s}) + +(type: #export (Branch s) + (#Case s (Path' s)) + (#Let s Register s) + (#If s s s)) + +(type: #export (Scope s) + {#start Register + #inits (List s) + #iteration s}) + +(type: #export (Loop s) + (#Scope (Scope s)) + (#Recur (List s))) + +(type: #export (Function s) + (#Abstraction (Abstraction' s)) + (#Apply s (List s))) + +(type: #export (Control s) + (#Branch (Branch s)) + (#Loop (Loop s)) + (#Function (Function s))) + +(type: #export #rec Synthesis + (#Primitive Primitive) + (#Structure (Structure Synthesis)) + (#Reference Reference) + (#Control (Control Synthesis))) + +(type: #export Path + (Path' Synthesis)) + +(def: #export path/pop + Path + #Pop) + +(do-template [ ] + [(template: #export ( content) + (#..Test ( content)))] + + [path/bool #..Bool] + [path/i64 #..I64] + [path/f64 #..F64] + [path/text #..Text] + ) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Access + + content))] + + [path/side #..Side] + [path/member #..Member] + ) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Access + + + content))] + + [side/left #..Side #.Left] + [side/right #..Side #.Right] + [member/left #..Member #.Left] + [member/right #..Member #.Right] + ) + +(do-template [ ] + [(template: #export ( content) + ( content))] + + [path/alt #..Alt] + [path/seq #..Seq] + [path/then #..Then] + ) + +(type: #export Abstraction + (Abstraction' Synthesis)) + +(def: #export unit Text "") + +(type: #export Synthesizer + (Compiler ..State Analysis Synthesis)) + +(do-template [ ] + [(def: #export + (All [a] (-> (Operation ..State a) (Operation ..State a))) + (//.localized (set@ #direct? )))] + + [indirectly false] + [directly true] + ) + +(do-template [ ] + [(def: #export ( value) + (-> (All [a] (-> (Operation ..State a) (Operation ..State a)))) + (//.localized (set@ value)))] + + [with-scope-arity Arity #scope-arity] + [with-resolver Resolver #resolver] + [with-locals Nat #locals] + ) + +(def: #export (with-abstraction arity resolver) + (All [o] + (-> Arity Resolver + (-> (Operation ..State o) (Operation ..State o)))) + (//.with-state {#scope-arity arity + #resolver resolver + #direct? true + #locals arity})) + +(do-template [ ] + [(def: #export + (Operation ..State ) + (function (_ state) + (#error.Success [state (get@ state)])))] + + [scope-arity #scope-arity Arity] + [resolver #resolver Resolver] + [direct? #direct? Bool] + [locals #locals Nat] + ) + +(def: #export with-new-local + (All [a] (-> (Operation ..State a) (Operation ..State a))) + (<<| (do //.Monad + [locals ..locals]) + (..with-locals (inc locals)))) + +(do-template [ ] + [(template: #export ( content) + (#..Primitive ( content)))] + + [bool #..Bool] + [i64 #..I64] + [f64 #..F64] + [text #..Text] + ) + +(do-template [ ] + [(template: #export ( content) + (<| #..Structure + + content))] + + [variant #..Variant] + [tuple #..Tuple] + ) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Reference + + content))] + + [variable/local ///reference.local] + [variable/foreign ///reference.foreign] + ) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Control + + + content))] + + [branch/case #..Branch #..Case] + [branch/let #..Branch #..Let] + [branch/if #..Branch #..If] + + [loop/scope #..Loop #..Scope] + [loop/recur #..Loop #..Recur] + + [function/abstraction #..Function #..Abstraction] + [function/apply #..Function #..Apply] + ) diff --git a/stdlib/source/lux/lang/compiler/synthesis/case.lux b/stdlib/source/lux/lang/compiler/synthesis/case.lux new file mode 100644 index 000000000..b7f224168 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/synthesis/case.lux @@ -0,0 +1,177 @@ +(.module: + lux + (lux (control [equality #+ Eq] + pipe + [monad #+ do]) + (data [product] + [bool "bool/" Eq] + [text "text/" Eq] + text/format + [number "frac/" Eq] + (coll [list "list/" Fold Monoid]))) + [///reference] + [///compiler #+ Operation "operation/" Monad] + [///analysis #+ Pattern Match Analysis] + [// #+ Path Synthesis] + [//function]) + +(def: (path' pattern bodyC) + (-> Pattern (Operation //.State Path) (Operation //.State Path)) + (case pattern + (#///analysis.Simple simple) + (case simple + #///analysis.Unit + bodyC + + (^template [ ] + ( value) + (operation/map (|>> (#//.Seq (#//.Test (|> value )))) + bodyC)) + ([#///analysis.Bool #//.Bool] + [#///analysis.Nat (<| #//.I64 .i64)] + [#///analysis.Int (<| #//.I64 .i64)] + [#///analysis.Deg (<| #//.I64 .i64)] + [#///analysis.Frac #//.F64] + [#///analysis.Text #//.Text])) + + (#///analysis.Bind register) + (<| (do ///compiler.Monad + [arity //.scope-arity]) + (:: @ map (|>> (#//.Seq (#//.Bind (if (//function.nested? arity) + (n/+ (dec arity) register) + register))))) + //.with-new-local + bodyC) + + (#///analysis.Complex _) + (case (///analysis.variant-pattern pattern) + (#.Some [lefts right? value-pattern]) + (operation/map (|>> (#//.Seq (#//.Access (#//.Side (if right? + (#.Right lefts) + (#.Left lefts)))))) + (path' value-pattern bodyC)) + + #.None + (let [tuple (///analysis.tuple-pattern pattern) + tuple/last (dec (list.size tuple))] + (list/fold (function (_ [tuple/idx tuple/member] thenC) + (case tuple/member + (#///analysis.Simple #///analysis.Unit) + thenC + + _ + (let [last? (n/= tuple/last tuple/idx)] + (|> (if (or last? + (is? bodyC thenC)) + thenC + (operation/map (|>> (#//.Seq #//.Pop)) thenC)) + (path' tuple/member) + (operation/map (|>> (#//.Seq (#//.Access (#//.Member (if last? + (#.Right (dec tuple/idx)) + (#.Left tuple/idx))))))))))) + bodyC + (list.reverse (list.enumerate tuple))))))) + +(def: #export (path synthesize pattern bodyA) + (-> //.Synthesizer Pattern Analysis (Operation //.State Path)) + (path' pattern (operation/map (|>> #//.Then) (synthesize bodyA)))) + +(def: #export (weave leftP rightP) + (-> Path Path Path) + (with-expansions [ (as-is (#//.Alt leftP rightP))] + (case [leftP rightP] + [(#//.Seq preL postL) + (#//.Seq preR postR)] + (case (weave preL preR) + (#//.Alt _) + + + weavedP + (#//.Seq weavedP (weave postL postR))) + + [#//.Pop #//.Pop] + rightP + + (^template [ ] + [(#//.Test ( leftV)) + (#//.Test ( rightV))] + (if ( leftV rightV) + rightP + )) + ([#//.Bool bool/=] + [#//.I64 (:! (Eq I64) i/=)] + [#//.F64 frac/=] + [#//.Text text/=]) + + (^template [ ] + [(#//.Access ( ( leftL))) + (#//.Access ( ( rightL)))] + (if (n/= leftL rightL) + rightP + )) + ([#//.Side #.Left] + [#//.Side #.Right] + [#//.Member #.Left] + [#//.Member #.Right]) + + [(#//.Bind leftR) (#//.Bind rightR)] + (if (n/= leftR rightR) + rightP + ) + + _ + ))) + +(def: #export (synthesize synthesize^ inputA [headB tailB+]) + (-> //.Synthesizer Analysis Match (Operation //.State Synthesis)) + (do ///compiler.Monad + [inputS (synthesize^ inputA)] + (with-expansions [ + (as-is (^multi (^ (#///analysis.Reference (///reference.local outputR))) + (n/= inputR outputR)) + (wrap inputS)) + + + (as-is [[(#///analysis.Bind inputR) headB/bodyA] + #.Nil] + (case headB/bodyA + + + _ + (do @ + [arity //.scope-arity + headB/bodyS (//.with-new-local + (synthesize^ headB/bodyA))] + (wrap (//.branch/let [inputS + (if (//function.nested? arity) + (n/+ (dec arity) inputR) + inputR) + headB/bodyS]))))) + + + (as-is (^or (^ [[(///analysis.pattern/bool true) thenA] + (list [(///analysis.pattern/bool false) elseA])]) + (^ [[(///analysis.pattern/bool false) elseA] + (list [(///analysis.pattern/bool true) thenA])])) + (do @ + [thenS (synthesize^ thenA) + elseS (synthesize^ elseA)] + (wrap (//.branch/if [inputS thenS elseS])))) + + + (as-is _ + (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) + list.reverse + (case> (#.Cons [lastP lastA] prevsPA) + [[lastP lastA] prevsPA] + + _ + (undefined)))] + (do @ + [lastSP (path synthesize^ lastP lastA) + prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] + (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))))] + (case [headB tailB+] + + + )))) diff --git a/stdlib/source/lux/lang/compiler/synthesis/expression.lux b/stdlib/source/lux/lang/compiler/synthesis/expression.lux new file mode 100644 index 000000000..52ea33805 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/synthesis/expression.lux @@ -0,0 +1,99 @@ +(.module: + [lux #- primitive] + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + (coll [list "list/" Functor] + (dictionary ["dict" unordered #+ Dict])))) + [///reference] + [///compiler "operation/" Monad] + [///analysis #+ Analysis] + [///extension #+ Extension] + [// #+ Synthesis] + [//function] + [//case]) + +(exception: #export (unknown-synthesis-extension {name Text}) + name) + +(def: (primitive analysis) + (-> ///analysis.Primitive //.Primitive) + (case analysis + #///analysis.Unit + (#//.Text //.unit) + + (^template [ ] + ( value) + ( value)) + ([#///analysis.Bool #//.Bool] + [#///analysis.Frac #//.F64] + [#///analysis.Text #//.Text]) + + (^template [ ] + ( value) + ( (.i64 value))) + ([#///analysis.Nat #//.I64] + [#///analysis.Int #//.I64] + [#///analysis.Deg #//.I64]))) + +(def: #export (synthesizer extensions) + (-> (Extension ///extension.Synthesis) //.Synthesizer) + (function (synthesize analysis) + (case analysis + (#///analysis.Primitive analysis') + (operation/wrap (#//.Primitive (..primitive analysis'))) + + (#///analysis.Structure composite) + (case (///analysis.variant analysis) + (#.Some variant) + (do ///compiler.Monad + [valueS (synthesize (get@ #///analysis.value variant))] + (wrap (#//.Structure (#//.Variant (set@ #///analysis.value valueS variant))))) + + _ + (do ///compiler.Monad + [tupleS (monad.map @ synthesize (///analysis.tuple analysis))] + (wrap (#//.Structure (#//.Tuple tupleS))))) + + (#///analysis.Apply _) + (//function.apply (|>> synthesize //.indirectly) analysis) + + (#///analysis.Function environmentA bodyA) + (//function.function synthesize environmentA bodyA) + + (#///analysis.Extension name args) + (case (dict.get name extensions) + #.None + (///compiler.throw unknown-synthesis-extension name) + + (#.Some extension) + (extension (|>> synthesize //.indirectly) args)) + + (#///analysis.Reference reference) + (case reference + (#///reference.Constant constant) + (operation/wrap (#//.Reference reference)) + + (#///reference.Variable var) + (do ///compiler.Monad + [resolver //.resolver] + (case var + (#///reference.Local register) + (do @ + [arity //.scope-arity] + (wrap (if (//function.nested? arity) + (if (n/= +0 register) + (|> (dec arity) + (list.n/range +1) + (list/map (|>> //.variable/local)) + [(//.variable/local +0)] + //.function/apply) + (#//.Reference (#///reference.Variable (//function.adjust arity false var)))) + (#//.Reference (#///reference.Variable var))))) + + (#///reference.Foreign register) + (wrap (|> resolver (dict.get var) (maybe.default var) #///reference.Variable #//.Reference))))) + + (#///analysis.Case inputA branchesAB+) + (//case.synthesize (|>> synthesize //.indirectly) inputA branchesAB+) + ))) diff --git a/stdlib/source/lux/lang/compiler/synthesis/function.lux b/stdlib/source/lux/lang/compiler/synthesis/function.lux new file mode 100644 index 000000000..35b9e047e --- /dev/null +++ b/stdlib/source/lux/lang/compiler/synthesis/function.lux @@ -0,0 +1,130 @@ +(.module: + [lux #- function] + (lux (control [monad #+ do] + [state] + pipe + ["ex" exception #+ exception:]) + (data [maybe "maybe/" Monad] + [error] + (coll [list "list/" Functor Monoid Fold] + (dictionary ["dict" unordered #+ Dict])))) + [///reference #+ Variable] + [///compiler #+ Operation] + [///analysis #+ Environment Arity Analysis] + [// #+ Synthesis Synthesizer] + [//loop]) + +(def: #export nested? + (-> Arity Bool) + (n/> +1)) + +(def: #export (adjust up-arity after? var) + (-> Arity Bool Variable Variable) + (case var + (#///reference.Local register) + (if (and after? (n/>= up-arity register)) + (#///reference.Local (n/+ (dec up-arity) register)) + var) + + _ + var)) + +(def: (unfold apply) + (-> Analysis [Analysis (List Analysis)]) + (loop [apply apply + args (list)] + (case apply + (#///analysis.Apply arg func) + (recur func (#.Cons arg args)) + + _ + [apply args]))) + +(def: #export (apply synthesize) + (-> Synthesizer Synthesizer) + (.function (_ exprA) + (let [[funcA argsA] (unfold exprA)] + (do (state.Monad error.Monad) + [funcS (synthesize funcA) + argsS (monad.map @ synthesize argsA) + locals //.locals] + (case funcS + (^ (//.function/abstraction functionS)) + (wrap (|> functionS + (//loop.loop (get@ #//.environment functionS) locals argsS) + (maybe.default (//.function/apply [funcS argsS])))) + + (^ (//.function/apply [funcS' argsS'])) + (wrap (//.function/apply [funcS' (list/compose argsS' argsS)])) + + _ + (wrap (//.function/apply [funcS argsS]))))))) + +(def: (prepare up down) + (-> Arity Arity (//loop.Transform Synthesis)) + (.function (_ body) + (if (nested? up) + (#.Some body) + (//loop.recursion down body)))) + +(exception: #export (cannot-prepare-function-body {_ []}) + "") + +(def: return + (All [a] (-> (Maybe a) (Operation //.State a))) + (|>> (case> (#.Some output) + (:: ///compiler.Monad wrap output) + + #.None + (///compiler.throw cannot-prepare-function-body [])))) + +(def: #export (function synthesize environment body) + (-> Synthesizer Environment Analysis (Operation //.State Synthesis)) + (do ///compiler.Monad + [direct? //.direct? + arity //.scope-arity + resolver //.resolver + #let [function-arity (if direct? + (inc arity) + +1) + up-environment (if (nested? arity) + (list/map (.function (_ closure) + (case (dict.get closure resolver) + (#.Some resolved) + (adjust arity true resolved) + + #.None + (adjust arity false closure))) + environment) + environment) + down-environment (: (List Variable) + (case environment + #.Nil + (list) + + _ + (|> (list.size environment) dec (list.n/range +0) + (list/map (|>> #///reference.Foreign))))) + resolver' (if (and (nested? function-arity) + direct?) + (list/fold (.function (_ [from to] resolver') + (dict.put from to resolver')) + //.fresh-resolver + (list.zip2 down-environment up-environment)) + (list/fold (.function (_ var resolver') + (dict.put var var resolver')) + //.fresh-resolver + down-environment))] + bodyS (//.with-abstraction function-arity resolver' + (synthesize body))] + (case bodyS + (^ (//.function/abstraction [env' down-arity' bodyS'])) + (let [arity' (inc down-arity')] + (|> (prepare function-arity arity' bodyS') + (maybe/map (|>> [up-environment arity'] //.function/abstraction)) + ..return)) + + _ + (|> (prepare function-arity +1 bodyS) + (maybe/map (|>> [up-environment +1] //.function/abstraction)) + ..return)))) diff --git a/stdlib/source/lux/lang/compiler/synthesis/loop.lux b/stdlib/source/lux/lang/compiler/synthesis/loop.lux new file mode 100644 index 000000000..eb57eb7ad --- /dev/null +++ b/stdlib/source/lux/lang/compiler/synthesis/loop.lux @@ -0,0 +1,285 @@ +(.module: + [lux #- loop] + (lux (control [monad #+ do] + ["p" parser]) + (data [maybe "maybe/" Monad] + (coll [list "list/" Functor])) + (macro [code] + [syntax])) + [///] + [///reference #+ Register Variable] + [///analysis #+ Environment] + [// #+ Path Abstraction Synthesis]) + +(type: #export (Transform a) + (-> a (Maybe a))) + +(def: (some? maybe) + (All [a] (-> (Maybe a) Bool)) + (case maybe + (#.Some _) true + #.None false)) + +(template: #export (self) + (#//.Reference (///reference.local +0))) + +(template: (recursive-apply args) + (#//.Apply (self) args)) + +(def: proper Bool true) +(def: improper Bool false) + +(def: (proper? exprS) + (-> Synthesis Bool) + (case exprS + (^ (self)) + improper + + (#//.Structure structure) + (case structure + (#//.Variant variantS) + (proper? (get@ #///analysis.value variantS)) + + (#//.Tuple membersS+) + (list.every? proper? membersS+)) + + (#//.Control controlS) + (case controlS + (#//.Branch branchS) + (case branchS + (#//.Case inputS pathS) + (and (proper? inputS) + (.loop [pathS pathS] + (case pathS + (^or (#//.Alt leftS rightS) (#//.Seq leftS rightS)) + (and (recur leftS) (recur rightS)) + + (#//.Then bodyS) + (proper? bodyS) + + _ + proper))) + + (#//.Let inputS register bodyS) + (and (proper? inputS) + (proper? bodyS)) + + (#//.If inputS thenS elseS) + (and (proper? inputS) + (proper? thenS) + (proper? elseS))) + + (#//.Loop loopS) + (case loopS + (#//.Scope scopeS) + (and (list.every? proper? (get@ #//.inits scopeS)) + (proper? (get@ #//.iteration scopeS))) + + (#//.Recur argsS) + (list.every? proper? argsS)) + + (#//.Function functionS) + (case functionS + (#//.Abstraction environment arity bodyS) + (list.every? ///reference.self? environment) + + (#//.Apply funcS argsS) + (and (proper? funcS) + (list.every? proper? argsS)))) + + (#//.Extension [name argsS]) + (list.every? proper? argsS) + + _ + proper)) + +(def: (path-recursion synthesis-recursion) + (-> (Transform Synthesis) (Transform Path)) + (function (recur pathS) + (case pathS + (#//.Alt leftS rightS) + (let [leftS' (recur leftS) + rightS' (recur rightS)] + (if (or (some? leftS') + (some? rightS')) + (#.Some (#//.Alt (maybe.default leftS leftS') + (maybe.default rightS rightS'))) + #.None)) + + (#//.Seq leftS rightS) + (maybe/map (|>> (#//.Seq leftS)) (recur rightS)) + + (#//.Then bodyS) + (maybe/map (|>> #//.Then) (synthesis-recursion bodyS)) + + _ + #.None))) + +(def: #export (recursion arity) + (-> Nat (Transform Synthesis)) + (function (recur exprS) + (case exprS + (#//.Control controlS) + (case controlS + (#//.Branch branchS) + (case branchS + (#//.Case inputS pathS) + (|> pathS + (path-recursion recur) + (maybe/map (|>> (#//.Case inputS) #//.Branch #//.Control))) + + (#//.Let inputS register bodyS) + (maybe/map (|>> (#//.Let inputS register) #//.Branch #//.Control) + (recur bodyS)) + + (#//.If inputS thenS elseS) + (let [thenS' (recur thenS) + elseS' (recur elseS)] + (if (or (some? thenS') + (some? elseS')) + (#.Some (|> (#//.If inputS + (maybe.default thenS thenS') + (maybe.default elseS elseS')) + #//.Branch #//.Control)) + #.None))) + + (^ (#//.Function (recursive-apply argsS))) + (if (n/= arity (list.size argsS)) + (#.Some (|> argsS #//.Recur #//.Loop #//.Control)) + #.None) + + _ + #.None) + + _ + #.None))) + +(def: (resolve environment) + (-> Environment (Transform Variable)) + (function (_ variable) + (case variable + (#///reference.Foreign register) + (list.nth register environment) + + _ + (#.Some variable)))) + +(def: (adjust-path adjust-synthesis offset) + (-> (Transform Synthesis) Register (Transform Path)) + (function (recur pathS) + (case pathS + (#//.Bind register) + (#.Some (#//.Bind (n/+ offset register))) + + (^template [] + ( leftS rightS) + (do maybe.Monad + [leftS' (recur leftS) + rightS' (recur rightS)] + (wrap ( leftS' rightS')))) + ([#//.Alt] [#//.Seq]) + + (#//.Then bodyS) + (|> bodyS adjust-synthesis (maybe/map (|>> #//.Then))) + + _ + (#.Some pathS)))) + +(def: (adjust scope-environment offset) + (-> Environment Register (Transform Synthesis)) + (function (recur exprS) + (case exprS + (#//.Structure structureS) + (case structureS + (#//.Variant variantS) + (do maybe.Monad + [valueS' (|> variantS (get@ #///analysis.value) recur)] + (wrap (|> variantS + (set@ #///analysis.value valueS') + #//.Variant + #//.Structure))) + + (#//.Tuple membersS+) + (|> membersS+ + (monad.map maybe.Monad recur) + (maybe/map (|>> #//.Tuple #//.Structure)))) + + (#//.Reference reference) + (case reference + (^ (///reference.constant constant)) + (#.Some exprS) + + (^ (///reference.local register)) + (#.Some (#//.Reference (///reference.local (n/+ offset register)))) + + (^ (///reference.foreign register)) + (|> scope-environment + (list.nth register) + (maybe/map (|>> #///reference.Variable #//.Reference)))) + + (^ (//.branch/case [inputS pathS])) + (do maybe.Monad + [inputS' (recur inputS) + pathS' (adjust-path recur offset pathS)] + (wrap (|> pathS' [inputS'] //.branch/case))) + + (^ (//.branch/let [inputS register bodyS])) + (do maybe.Monad + [inputS' (recur inputS) + bodyS' (recur bodyS)] + (wrap (//.branch/let [inputS' register bodyS']))) + + (^ (//.branch/if [inputS thenS elseS])) + (do maybe.Monad + [inputS' (recur inputS) + thenS' (recur thenS) + elseS' (recur elseS)] + (wrap (//.branch/if [inputS' thenS' elseS']))) + + (^ (//.loop/scope scopeS)) + (do maybe.Monad + [inits' (|> scopeS + (get@ #//.inits) + (monad.map maybe.Monad recur)) + iteration' (recur (get@ #//.iteration scopeS))] + (wrap (//.loop/scope {#//.start (|> scopeS (get@ #//.start) (n/+ offset)) + #//.inits inits' + #//.iteration iteration'}))) + + (^ (//.loop/recur argsS)) + (|> argsS + (monad.map maybe.Monad recur) + (maybe/map (|>> //.loop/recur))) + + + (^ (//.function/abstraction [environment arity bodyS])) + (do maybe.Monad + [environment' (monad.map maybe.Monad + (resolve scope-environment) + environment)] + (wrap (//.function/abstraction [environment' arity bodyS]))) + + (^ (//.function/apply [function arguments])) + (do maybe.Monad + [function' (recur function) + arguments' (monad.map maybe.Monad recur arguments)] + (wrap (//.function/apply [function' arguments']))) + + (#//.Extension [name argsS]) + (|> argsS + (monad.map maybe.Monad recur) + (maybe/map (|>> [name] #//.Extension))) + + _ + (#.Some exprS)))) + +(def: #export (loop environment num-locals inits functionS) + (-> Environment Nat (List Synthesis) Abstraction (Maybe Synthesis)) + (let [bodyS (get@ #//.body functionS)] + (if (and (n/= (list.size inits) + (get@ #//.arity functionS)) + (proper? bodyS)) + (|> bodyS + (adjust environment num-locals) + (maybe/map (|>> [(inc num-locals) inits] //.loop/scope))) + #.None))) diff --git a/stdlib/source/lux/lang/compiler/translation.lux b/stdlib/source/lux/lang/compiler/translation.lux new file mode 100644 index 000000000..c117bc019 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/translation.lux @@ -0,0 +1,164 @@ +(.module: + lux + (lux (control ["ex" exception #+ exception:] + [monad #+ do]) + (data [maybe "maybe/" Functor] + [error #+ Error] + [text] + text/format + (coll [sequence #+ Sequence] + (dictionary ["dict" unordered #+ Dict]))) + (world [file #+ File])) + [//name] + [//reference #+ Register] + [//compiler #+ Operation Compiler] + [//synthesis #+ Synthesis]) + +(do-template [] + [(exception: #export () + "")] + + [no-active-buffer] + [no-anchor] + ) + +(exception: #export (cannot-interpret {message Text}) + message) + +(type: #export Context + {#scope-name Text + #inner-functions Nat}) + +(sig: #export (Host code) + (: (-> code (Error Any)) + execute!) + (: (-> code (Error Any)) + evaluate!)) + +(type: #export (Buffer code) (Sequence [Ident code])) + +(type: #export (Artifacts code) (Dict File (Buffer code))) + +(type: #export (State anchor code) + {#context Context + #anchor (Maybe anchor) + #host (Host code) + #buffer (Maybe (Buffer code)) + #artifacts (Artifacts code)}) + +(type: #export (Translator anchor code) + (Compiler (State anchor code) Synthesis code)) + +(def: #export (init host) + (All [anchor code] (-> (Host code) (..State anchor code))) + {#context {#scope-name "" + #inner-functions +0} + #anchor #.None + #host host + #buffer #.None + #artifacts (dict.new text.Hash)}) + +(def: #export (with-context expr) + (All [anchor code output] + (-> (Operation (..State anchor code) output) + (Operation (..State anchor code) [Text output]))) + (function (_ state) + (let [[old-scope old-inner] (get@ #context state) + new-scope (format old-scope "c___" (%i (.int old-inner)))] + (case (expr (set@ #context [new-scope +0] state)) + (#error.Success [state' output]) + (#error.Success [(set@ #context [old-scope (inc old-inner)] state') + [new-scope output]]) + + (#error.Error error) + (#error.Error error))))) + +(def: #export context + (All [anchor code] (Operation (..State anchor code) Text)) + (function (_ state) + (#error.Success [state + (|> state + (get@ #context) + (get@ #scope-name))]))) + +(do-template [ + + ] + [(def: #export + (All [anchor code output] ) + (function (_ body) + (function (_ state) + (case (body (set@ (#.Some ) state)) + (#error.Success [state' output]) + (#error.Success [(set@ (get@ state) state') + output]) + + (#error.Error error) + (#error.Error error))))) + + (def: #export + (All [anchor code] (Operation (..State anchor code) )) + (function (_ state) + (case (get@ state) + (#.Some output) + (#error.Success [state output]) + + #.None + (ex.throw []))))] + + [#anchor + (with-anchor anchor) + (-> anchor (Operation (..State anchor code) output) + (Operation (..State anchor code) output)) + anchor + anchor anchor no-anchor] + + [#buffer + with-buffer + (-> (Operation (..State anchor code) output) + (Operation (..State anchor code) output)) + sequence.empty + buffer (Buffer code) no-active-buffer] + ) + +(def: #export artifacts + (All [anchor code] + (Operation (..State anchor code) (Artifacts code))) + (function (_ state) + (#error.Success [state (get@ #artifacts state)]))) + +(do-template [] + [(def: #export ( code) + (All [anchor code] + (-> code (Operation (..State anchor code) Any))) + (function (_ state) + (case (:: (get@ #host state) code) + (#error.Error error) + (ex.throw cannot-interpret error) + + (#error.Success output) + (#error.Success [state output]))))] + + [execute!] + [evaluate!] + ) + +(def: #export (save! name code) + (All [anchor code] + (-> Ident code (Operation (..State anchor code) Any))) + (do //compiler.Monad + [_ (execute! code)] + (function (_ state) + (#error.Success [(update@ #buffer + (maybe/map (sequence.add [name code])) + state) + []])))) + +(def: #export (save-buffer! target) + (All [anchor code] + (-> File (Operation (..State anchor code) Any))) + (do //compiler.Monad + [buffer ..buffer] + (function (_ state) + (#error.Success [(update@ #artifacts (dict.put target buffer) state) + []])))) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux new file mode 100644 index 000000000..e5d12a005 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux @@ -0,0 +1,170 @@ +(.module: + [lux #- case let if] + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [number] + [text] + text/format + (coll [list "list/" Functor Fold] + (set ["set" unordered #+ Set])))) + (//// [reference #+ Register] + (host ["_" scheme #+ Expression Computation Var]) + [compiler #+ "operation/" Monad] + [synthesis #+ Synthesis Path]) + [//runtime #+ Operation Translator] + [//reference]) + +(def: #export (let translate [valueS register bodyS]) + (-> Translator [Synthesis Register Synthesis] + (Operation Computation)) + (do compiler.Monad + [valueO (translate valueS) + bodyO (translate bodyS)] + (wrap (_.let (list [(//reference.local' register) valueO]) + bodyO)))) + +(def: #export (record-get translate valueS pathP) + (-> Translator Synthesis (List [Nat Bool]) + (Operation Expression)) + (do compiler.Monad + [valueO (translate valueS)] + (wrap (list/fold (function (_ [idx tail?] source) + (.let [method (.if tail? + //runtime.product//right + //runtime.product//left)] + (method source (_.int (:! Int idx))))) + valueO + pathP)))) + +(def: #export (if translate [testS thenS elseS]) + (-> Translator [Synthesis Synthesis Synthesis] + (Operation Computation)) + (do compiler.Monad + [testO (translate testS) + thenO (translate thenS) + elseO (translate elseS)] + (wrap (_.if testO thenO elseO)))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) + +(def: @cursor (_.var "lux_pm_cursor")) + +(def: top _.length/1) + +(def: (push! value var) + (-> Expression Var Computation) + (_.set! var (_.cons/2 value var))) + +(def: (pop! var) + (-> Var Computation) + (_.set! var var)) + +(def: (push-cursor! value) + (-> Expression Computation) + (push! value @cursor)) + +(def: save-cursor! + Computation + (push! @cursor @savepoint)) + +(def: restore-cursor! + Computation + (_.set! @cursor (_.car/1 @savepoint))) + +(def: cursor-top + Computation + (_.car/1 @cursor)) + +(def: pop-cursor! + Computation + (pop! @cursor)) + +(def: pm-error (_.string "PM-ERROR")) + +(def: fail-pm! (_.raise/1 pm-error)) + +(def: @temp (_.var "lux_pm_temp")) + +(exception: #export (unrecognized-path) + "") + +(def: $alt_error (_.var "alt_error")) + +(def: (pm-catch handler) + (-> Expression Computation) + (_.lambda [(list $alt_error) #.None] + (_.if (|> $alt_error (_.eqv?/2 pm-error)) + handler + (_.raise/1 $alt_error)))) + +(def: (pattern-matching' translate pathP) + (-> Translator Path (Operation Expression)) + (.case pathP + (^ (synthesis.path/then bodyS)) + (translate bodyS) + + #synthesis.Pop + (operation/wrap pop-cursor!) + + (#synthesis.Bind register) + (operation/wrap (_.define (//reference.local' register) [(list) #.None] + cursor-top)) + + (^template [ <=>] + (^ ( value)) + (operation/wrap (_.when (|> value (<=> cursor-top) _.not/1) + fail-pm!))) + ([synthesis.path/bool _.bool _.eqv?/2] + [synthesis.path/i64 _.int _.=/2] + [synthesis.path/f64 _.float _.=/2] + [synthesis.path/text _.string _.eqv?/2]) + + (^template [ ] + (^ ( idx)) + (operation/wrap (_.let (list [@temp (|> idx .int _.int (//runtime.sum//get cursor-top ))]) + (_.if (_.null?/1 @temp) + fail-pm! + (push-cursor! @temp))))) + ([synthesis.side/left _.nil (<|)] + [synthesis.side/right (_.string "") inc]) + + (^template [ ] + (^ ( idx)) + (operation/wrap (|> idx .int _.int ( cursor-top) push-cursor!))) + ([synthesis.member/left //runtime.product//left (<|)] + [synthesis.member/right //runtime.product//right inc]) + + (^template [ ] + (^ ( [leftP rightP])) + (do compiler.Monad + [leftO (pattern-matching' translate leftP) + rightO (pattern-matching' translate rightP)] + (wrap ))) + ([synthesis.path/seq (_.begin (list leftO + rightO))] + [synthesis.path/alt (_.with-exception-handler + (pm-catch (_.begin (list restore-cursor! + rightO))) + (_.lambda [(list) #.None] + (_.begin (list save-cursor! + leftO))))]) + + _ + (compiler.throw unrecognized-path []))) + +(def: (pattern-matching translate pathP) + (-> Translator Path (Operation Computation)) + (do compiler.Monad + [pattern-matching! (pattern-matching' translate pathP)] + (wrap (_.with-exception-handler + (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) + (_.lambda [(list) #.None] + pattern-matching!))))) + +(def: #export (case translate [valueS pathP]) + (-> Translator [Synthesis Path] (Operation Computation)) + (do compiler.Monad + [valueO (translate valueS)] + (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] + [@savepoint (_.list/* (list))]))) + (pattern-matching translate pathP)))) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux new file mode 100644 index 000000000..96bb17126 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux @@ -0,0 +1,53 @@ +(.module: + lux + (lux (control [monad #+ do])) + (//// [compiler] + [synthesis] + [extension]) + [//runtime #+ Translator] + [//primitive] + [//structure] + [//reference] + [//function] + [//case]) + +(def: #export (translate synthesis) + Translator + (case synthesis + (^template [ ] + (^ ( value)) + ( value)) + ([synthesis.bool //primitive.bool] + [synthesis.i64 //primitive.i64] + [synthesis.f64 //primitive.f64] + [synthesis.text //primitive.text]) + + (^ (synthesis.variant variantS)) + (//structure.variant translate variantS) + + (^ (synthesis.tuple members)) + (//structure.tuple translate members) + + (#synthesis.Reference reference) + (//reference.reference reference) + + (^ (synthesis.function/apply application)) + (//function.apply translate application) + + (^ (synthesis.function/abstraction abstraction)) + (//function.function translate abstraction) + + (^ (synthesis.branch/case case)) + (//case.case translate case) + + (^ (synthesis.branch/let let)) + (//case.let translate let) + + (^ (synthesis.branch/if if)) + (//case.if translate if) + + (#synthesis.Extension [extension argsS]) + (do compiler.Monad + [extension (extension.find-translation extension)] + (extension argsS)) + )) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux new file mode 100644 index 000000000..6475caf68 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux @@ -0,0 +1,32 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + text/format + (coll (dictionary ["dict" unordered #+ Dict])))) + (//// [reference #+ Register Variable] + (host ["_" scheme #+ Computation]) + [compiler "operation/" Monad] + [synthesis #+ Synthesis]) + [//runtime #+ Operation Translator] + [/common] + ## [/host] + ) + +(exception: #export (unknown-extension {message Text}) + message) + +(def: extensions + /common.Bundle + (|> /common.extensions + ## (dict.merge /host.extensions) + )) + +(def: #export (extension translate name args) + (-> Translator Text (List Synthesis) + (Operation Computation)) + (<| (maybe.default (compiler.throw unknown-extension (%t name))) + (do maybe.Monad + [ext (dict.get name extensions)] + (wrap (ext translate args))))) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux new file mode 100644 index 000000000..140045aaf --- /dev/null +++ b/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux @@ -0,0 +1,389 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data ["e" error] + [product] + [text] + text/format + [number #+ hex] + (coll [list "list/" Functor] + (dictionary ["dict" unordered #+ Dict]))) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (///// (host ["_" scheme #+ Expression Computation]) + [compiler] + [synthesis #+ Synthesis]) + [///runtime #+ Operation Translator]) + +## [Types] +(type: #export Extension + (-> Translator (List Synthesis) (Operation Computation))) + +(type: #export Bundle + (Dict Text Extension)) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector +0 Expression) Computation)) +(type: #export Unary (-> (Vector +1 Expression) Computation)) +(type: #export Binary (-> (Vector +2 Expression) Computation)) +(type: #export Trinary (-> (Vector +3 Expression) Computation)) +(type: #export Variadic (-> (List Expression) Computation)) + +## [Utils] +(def: #export (install name unnamed) + (-> Text (-> Text Extension) + (-> Bundle Bundle)) + (dict.put name (unnamed name))) + +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict.entries + (list/map (function (_ [key val]) [(format prefix " " key) val])) + (dict.from-list text.Hash))) + +(exception: #export (wrong-arity {extension Text} {expected Nat} {actual Nat}) + (ex.report ["Extension" (%t extension)] + ["Expected" (|> expected .int %i)] + ["Actual" (|> actual .int %i)])) + +(syntax: (arity: {name s.local-symbol} {arity s.nat}) + (with-gensyms [g!_ g!extension g!name g!translate g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!extension)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) + (-> Text ..Extension)) + (function ((~ g!_) (~ g!name)) + (function ((~ g!_) (~ g!translate) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do compiler.Monad + [(~+ (|> g!input+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!translate) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + + (~' _) + (compiler.throw wrong-arity [(~ g!name) +1 (list.size (~ g!inputs))]))))))))))) + +(arity: nullary +0) +(arity: unary +1) +(arity: binary +2) +(arity: trinary +3) + +(def: #export (variadic extension) + (-> Variadic (-> Text Extension)) + (function (_ extension-name) + (function (_ translate inputsS) + (do compiler.Monad + [inputsI (monad.map @ translate inputsS)] + (wrap (extension inputsI)))))) + +## [Extensions] +## [[Lux]] +(def: extensions/lux + Bundle + (|> (dict.new text.Hash) + (install "is?" (binary (product.uncurry _.eq?/2))) + (install "try" (unary ///runtime.lux//try)))) + +## [[Bits]] +(do-template [ ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [bit//and _.bit-and/2] + [bit//or _.bit-or/2] + [bit//xor _.bit-xor/2] + ) + +(def: (bit//left-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (_.remainder/2 (_.int 64) paramO) + subjectO)) + +(def: (bit//arithmetic-right-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int 64)) (_.*/2 (_.int -1))) + subjectO)) + +(def: (bit//logical-right-shift [subjectO paramO]) + Binary + (///runtime.bit//logical-right-shift (_.remainder/2 (_.int 64) paramO) subjectO)) + +(def: extensions/bit + Bundle + (<| (prefix "bit") + (|> (dict.new text.Hash) + (install "and" (binary bit//and)) + (install "or" (binary bit//or)) + (install "xor" (binary bit//xor)) + (install "left-shift" (binary bit//left-shift)) + (install "logical-right-shift" (binary bit//logical-right-shift)) + (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) + ))) + +## [[Arrays]] +(def: (array//new size0) + Unary + (_.make-vector/2 size0 _.nil)) + +(def: (array//get [arrayO idxO]) + Binary + (///runtime.array//get arrayO idxO)) + +(def: (array//put [arrayO idxO elemO]) + Trinary + (///runtime.array//put arrayO idxO elemO)) + +(def: (array//remove [arrayO idxO]) + Binary + (///runtime.array//put arrayO idxO _.nil)) + +(def: extensions/array + Bundle + (<| (prefix "array") + (|> (dict.new text.Hash) + (install "new" (unary array//new)) + (install "get" (binary array//get)) + (install "put" (trinary array//put)) + (install "remove" (binary array//remove)) + (install "size" (unary _.vector-length/1)) + ))) + +## [[Numbers]] +(host.import java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(do-template [ ] + [(def: ( _) + Nullary + ( ))] + + [frac//smallest Double::MIN_VALUE _.float] + [frac//min (f/* -1.0 Double::MAX_VALUE) _.float] + [frac//max Double::MAX_VALUE _.float] + ) + +(do-template [ ] + [(def: ( _) + Nullary + (_.float ))] + + [frac//not-a-number number.not-a-number] + [frac//positive-infinity number.positive-infinity] + [frac//negative-infinity number.negative-infinity] + ) + +(do-template [ ] + [(def: ( [subjectO paramO]) + Binary + (|> subjectO ( paramO)))] + + [int//+ _.+/2] + [int//- _.-/2] + [int//* _.*/2] + [int/// _.quotient/2] + [int//% _.remainder/2] + ) + +(do-template [ ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [frac//+ _.+/2] + [frac//- _.-/2] + [frac//* _.*/2] + [frac/// _.//2] + [frac//% _.mod/2] + [frac//= _.=/2] + [frac//< _. ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [int//= _.=/2] + [int//< _.> _.integer->char/1 _.string/1)) + +(def: extensions/int + Bundle + (<| (prefix "int") + (|> (dict.new text.Hash) + (install "+" (binary int//+)) + (install "-" (binary int//-)) + (install "*" (binary int//*)) + (install "/" (binary int///)) + (install "%" (binary int//%)) + (install "=" (binary int//=)) + (install "<" (binary int//<)) + (install "to-frac" (unary (|>> (_.//2 (_.float 1.0))))) + (install "char" (unary int//char))))) + +(def: extensions/frac + Bundle + (<| (prefix "frac") + (|> (dict.new text.Hash) + (install "+" (binary frac//+)) + (install "-" (binary frac//-)) + (install "*" (binary frac//*)) + (install "/" (binary frac///)) + (install "%" (binary frac//%)) + (install "=" (binary frac//=)) + (install "<" (binary frac//<)) + (install "smallest" (nullary frac//smallest)) + (install "min" (nullary frac//min)) + (install "max" (nullary frac//max)) + (install "not-a-number" (nullary frac//not-a-number)) + (install "positive-infinity" (nullary frac//positive-infinity)) + (install "negative-infinity" (nullary frac//negative-infinity)) + (install "to-int" (unary _.exact/1)) + (install "encode" (unary _.number->string/1)) + (install "decode" (unary ///runtime.frac//decode))))) + +## [[Text]] +(def: (text//char [subjectO paramO]) + Binary + (_.string/1 (_.string-ref/2 subjectO paramO))) + +(def: (text//clip [subjectO startO endO]) + Trinary + (_.substring/3 subjectO startO endO)) + +(def: extensions/text + Bundle + (<| (prefix "text") + (|> (dict.new text.Hash) + (install "=" (binary text//=)) + (install "<" (binary text//<)) + (install "concat" (binary (product.uncurry _.string-append/2))) + (install "size" (unary _.string-length/1)) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip))))) + +## [[Math]] +(def: (math//pow [subject param]) + Binary + (_.expt/2 param subject)) + +(def: math-func + (-> Text Unary) + (|>> _.global _.apply/1)) + +(def: extensions/math + Bundle + (<| (prefix "math") + (|> (dict.new text.Hash) + (install "cos" (unary (math-func "cos"))) + (install "sin" (unary (math-func "sin"))) + (install "tan" (unary (math-func "tan"))) + (install "acos" (unary (math-func "acos"))) + (install "asin" (unary (math-func "asin"))) + (install "atan" (unary (math-func "atan"))) + (install "exp" (unary (math-func "exp"))) + (install "log" (unary (math-func "log"))) + (install "ceil" (unary (math-func "ceiling"))) + (install "floor" (unary (math-func "floor"))) + (install "pow" (binary math//pow)) + ))) + +## [[IO]] +(def: (io//log input) + Unary + (_.begin (list (_.display/1 input) + _.newline/0))) + +(def: (void code) + (-> Expression Computation) + (_.begin (list code (_.string synthesis.unit)))) + +(def: extensions/io + Bundle + (<| (prefix "io") + (|> (dict.new text.Hash) + (install "log" (unary (|>> io//log ..void))) + (install "error" (unary _.raise/1)) + (install "exit" (unary _.exit/1)) + (install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string synthesis.unit)))))))) + +## [[Atoms]] +(def: atom//new + Unary + (|>> (list) _.vector/*)) + +(def: (atom//read atom) + Unary + (_.vector-ref/2 atom (_.int 0))) + +(def: (atom//compare-and-swap [atomO oldO newO]) + Trinary + (///runtime.atom//compare-and-swap atomO oldO newO)) + +(def: extensions/atom + Bundle + (<| (prefix "atom") + (|> (dict.new text.Hash) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "compare-and-swap" (trinary atom//compare-and-swap))))) + +## [[Box]] +(def: (box//write [valueO boxO]) + Binary + (///runtime.box//write valueO boxO)) + +(def: extensions/box + Bundle + (<| (prefix "box") + (|> (dict.new text.Hash) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "write" (binary box//write))))) + +## [[Processes]] +(def: (process//parallelism-level []) + Nullary + (_.int 1)) + +(def: extensions/process + Bundle + (<| (prefix "process") + (|> (dict.new text.Hash) + (install "parallelism-level" (nullary process//parallelism-level)) + (install "schedule" (binary (product.uncurry ///runtime.process//schedule))) + ))) + +## [Bundles] +(def: #export extensions + Bundle + (<| (prefix "lux") + (|> extensions/lux + (dict.merge extensions/bit) + (dict.merge extensions/int) + (dict.merge extensions/frac) + (dict.merge extensions/text) + (dict.merge extensions/array) + (dict.merge extensions/math) + (dict.merge extensions/io) + (dict.merge extensions/atom) + (dict.merge extensions/box) + (dict.merge extensions/process) + ))) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux new file mode 100644 index 000000000..11c64076c --- /dev/null +++ b/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux @@ -0,0 +1,85 @@ +(.module: + [lux #- function] + (lux (control [monad #+ do] + pipe) + (data [product] + text/format + (coll [list "list/" Functor]))) + (//// [reference #+ Register Variable] + [name] + [compiler "operation/" Monad] + [analysis #+ Variant Tuple Environment Arity Abstraction Application Analysis] + [synthesis #+ Synthesis] + (host ["_" scheme #+ Expression Computation Var])) + [///] + [//runtime #+ Operation Translator] + [//primitive] + [//reference]) + +(def: #export (apply translate [functionS argsS+]) + (-> Translator (Application Synthesis) (Operation Computation)) + (do compiler.Monad + [functionO (translate functionS) + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* functionO argsO+)))) + +(def: (with-closure function-name inits function-definition) + (-> Text (List Expression) Computation (Operation Computation)) + (let [@closure (_.var (format function-name "___CLOSURE"))] + (operation/wrap + (case inits + #.Nil + function-definition + + _ + (_.letrec (list [@closure + (_.lambda [(|> (list.enumerate inits) + (list/map (|>> product.left //reference.foreign'))) + #.None] + function-definition)]) + (_.apply/* @closure inits)))))) + +(def: @curried (_.var "curried")) +(def: @missing (_.var "missing")) + +(def: input + (|>> inc //reference.local')) + +(def: #export (function translate [environment arity bodyS]) + (-> Translator (Abstraction Synthesis) (Operation Computation)) + (do compiler.Monad + [[function-name bodyO] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.var function-name) + (translate bodyS)))) + closureO+ (monad.map @ //reference.variable environment) + #let [arityO (|> arity .int _.int) + @num-args (_.var "num_args") + @function (_.var function-name) + apply-poly (.function (_ args func) + (_.apply/2 (_.global "apply") func args))]] + (with-closure function-name closureO+ + (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] + (_.let (list [@num-args (_.length/1 @curried)]) + (<| (_.if (|> @num-args (_.=/2 arityO)) + (<| (_.let (list [(//reference.local' +0) @function])) + (_.let-values (list [[(|> (list.n/range +0 (dec arity)) + (list/map ..input)) + #.None] + (_.apply/2 (_.global "apply") (_.global "values") @curried)])) + bodyO)) + (_.if (|> @num-args (_.>/2 arityO)) + (let [arity-args (//runtime.slice (_.int 0) arityO @curried) + output-func-args (//runtime.slice arityO + (|> @num-args (_.-/2 arityO)) + @curried)] + (|> @function + (apply-poly arity-args) + (apply-poly output-func-args)))) + ## (|> @num-args (_. @function + (apply-poly (_.append/2 @curried @missing)))))))]) + @function)) + )) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux new file mode 100644 index 000000000..6f305336e --- /dev/null +++ b/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux @@ -0,0 +1,39 @@ +(.module: + [lux #- loop] + (lux (control [monad #+ do]) + (data [product] + [text] + text/format + (coll [list "list/" Functor])) + [macro]) + [////] + (//// [name] + (host ["_" scheme #+ Computation Var]) + [compiler "operation/" Monad] + [synthesis #+ Synthesis]) + [///] + [//runtime #+ Operation Translator] + [//reference]) + +(def: @loop (_.var "loop")) + +(def: #export (loop translate offset initsS+ bodyS) + (-> Translator Nat (List Synthesis) Synthesis + (Operation Computation)) + (do compiler.Monad + [initsO+ (monad.map @ translate initsS+) + bodyO (///.with-anchor @loop + (translate bodyS))] + (wrap (_.letrec (list [@loop (_.lambda [(|> initsS+ + list.enumerate + (list/map (|>> product.left (n/+ offset) //reference.local'))) + #.None] + bodyO)]) + (_.apply/* @loop initsO+))))) + +(def: #export (recur translate argsS+) + (-> Translator (List Synthesis) (Operation Computation)) + (do compiler.Monad + [@loop ///.anchor + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* @loop argsO+)))) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux new file mode 100644 index 000000000..ac775fa82 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux @@ -0,0 +1,22 @@ +(.module: + [lux #- i64] + [/// #+ State] + (//// [compiler #+ "operation/" Monad] + (host ["_" scheme #+ Expression])) + [//runtime #+ Operation]) + +(def: #export bool + (-> Bool (Operation Expression)) + (|>> _.bool operation/wrap)) + +(def: #export i64 + (-> (I64 Any) (Operation Expression)) + (|>> .int _.int operation/wrap)) + +(def: #export f64 + (-> Frac (Operation Expression)) + (|>> _.float operation/wrap)) + +(def: #export text + (-> Text (Operation Expression)) + (|>> _.string operation/wrap)) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux new file mode 100644 index 000000000..453d4edb6 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux @@ -0,0 +1,54 @@ +(.module: + lux + (lux (control pipe) + (data text/format)) + (//// [reference #+ Register Variable Reference] + [name] + [compiler "operation/" Monad] + [analysis #+ Variant Tuple] + [synthesis #+ Synthesis] + (host ["_" scheme #+ Expression Var])) + [//runtime #+ Operation Translator] + [//primitive]) + +(do-template [ ] + [(def: #export + (-> Register Var) + (|>> .int %i (format ) _.var))] + + [local' "l"] + [foreign' "f"] + ) + +(def: #export variable' + (-> Variable Var) + (|>> (case> (#reference.Local register) + (local' register) + + (#reference.Foreign register) + (foreign' register)))) + +(def: #export variable + (-> Variable (Operation Var)) + (|>> ..variable' + operation/wrap)) + +(def: #export constant' + (-> Ident Var) + (|>> name.definition _.var)) + +(def: #export constant + (-> Ident (Operation Var)) + (|>> constant' operation/wrap)) + +(def: #export reference' + (-> Reference Expression) + (|>> (case> (#reference.Constant value) + (..constant' value) + + (#reference.Variable value) + (..variable' value)))) + +(def: #export reference + (-> Reference (Operation Expression)) + (|>> reference' operation/wrap)) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux new file mode 100644 index 000000000..b30aff3a2 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux @@ -0,0 +1,362 @@ +(.module: + lux + (lux (control ["p" parser "p/" Monad] + [monad #+ do]) + (data [number #+ hex] + text/format + (coll [list "list/" Monad])) + [function] + (macro [code] + ["s" syntax #+ syntax:])) + [/// #+ State] + (//// [name] + [compiler] + [analysis #+ Variant] + [synthesis] + (host ["_" scheme #+ Expression Computation Var]))) + +(type: #export Operation + (compiler.Operation (State Var Expression))) + +(type: #export Translator + (///.Translator Var Expression)) + +(def: prefix Text "LuxRuntime") + +(def: unit (_.string synthesis.unit)) + +(def: #export variant-tag "lux-variant") + +(def: (flag value) + (-> Bool Computation) + (if value + (_.string "") + _.nil)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Computation) + (<| (_.cons/2 (_.symbol ..variant-tag)) + (_.cons/2 tag) + (_.cons/2 last?) + value)) + +(def: #export (variant [lefts right? value]) + (-> (Variant Expression) Computation) + (variant' (_.int (.int lefts)) (flag right?) value)) + +(def: #export none + Computation + (variant [+0 false ..unit])) + +(def: #export some + (-> Expression Computation) + (|>> [+0 true] ..variant)) + +(def: #export left + (-> Expression Computation) + (|>> [+0 false] ..variant)) + +(def: #export right + (-> Expression Computation) + (|>> [+0 true] ..variant)) + +(def: declaration + (s.Syntax [Text (List Text)]) + (p.either (p.seq s.local-symbol (p/wrap (list))) + (s.form (p.seq s.local-symbol (p.some s.local-symbol))))) + +(syntax: (runtime: {[name args] declaration} + definition) + (let [implementation (code.local-symbol (format "@@" name)) + runtime (format prefix "__" (name.normalize name)) + @runtime (` (_.var (~ (code.text runtime)))) + argsC+ (list/map code.local-symbol args) + argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`)) + args) + declaration (` ((~ (code.local-symbol name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) + _.Computation))] + (wrap (list (` (def: (~' #export) (~ declaration) + (~ type) + (~ (case argsC+ + #.Nil + @runtime + + _ + (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) + (` (def: (~ implementation) + _.Computation + (~ (case argsC+ + #.Nil + (` (_.define (~ @runtime) [(list) #.None] (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function (_ [left right]) + (list left right))) + list/join))] + (_.define (~ @runtime) [(list (~+ argsLC+)) #.None] + (~ definition)))))))))))) + +(runtime: (slice offset length list) + (<| (_.if (_.null?/1 list) + list) + (_.if (|> offset (_.>/2 (_.int 0))) + (slice (|> offset (_.-/2 (_.int 1))) + length + (_.cdr/1 list))) + (_.if (|> length (_.>/2 (_.int 0))) + (_.cons/2 (_.car/1 list) + (slice offset + (|> length (_.-/2 (_.int 1))) + (_.cdr/1 list)))) + _.nil)) + +(syntax: #export (with-vars {vars (s.tuple (p.many s.local-symbol))} + body) + (wrap (list (` (let [(~+ (|> vars + (list/map (function (_ var) + (list (code.local-symbol var) + (` (_.var (~ (code.text (format "LRV__" (name.normalize var))))))))) + list/join))] + (~ body)))))) + +(runtime: (lux//try op) + (with-vars [error] + (_.with-exception-handler + (_.lambda [(list error) #.None] + (..left error)) + (_.lambda [(list) #.None] + (..right (_.apply/* op (list ..unit))))))) + +(runtime: (lux//program-args program-args) + (with-vars [@loop @input @output] + (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] + (_.if (_.eqv?/2 _.nil @input) + @output + (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) + (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) + +(def: runtime//lux + Computation + (_.begin (list @@lux//try + @@lux//program-args))) + +(def: minimum-index-length + (-> Expression Computation) + (|>> (_.+/2 (_.int 1)))) + +(def: product-element + (-> Expression Expression Computation) + (function.flip _.vector-ref/2)) + +(def: (product-tail product) + (-> Expression Computation) + (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int 1))))) + +(def: (updated-index min-length product) + (-> Expression Expression Computation) + (|> min-length (_.-/2 (_.length/1 product)))) + +(runtime: (product//left product index) + (let [@index_min_length (_.var "index_min_length")] + (_.begin + (list (_.define @index_min_length [(list) #.None] + (minimum-index-length index)) + (_.if (|> product _.length/1 (_.>/2 @index_min_length)) + ## No need for recursion + (product-element index product) + ## Needs recursion + (product//left (product-tail product) + (updated-index @index_min_length product))))))) + +(runtime: (product//right product index) + (let [@index_min_length (_.var "index_min_length") + @product_length (_.var "product_length") + @slice (_.var "slice") + last-element? (|> @product_length (_.=/2 @index_min_length)) + needs-recursion? (|> @product_length (_. @product_length (_.-/2 index)))) + (_.vector-copy!/5 @slice (_.int 0) product index @product_length) + @slice))))))) + +(runtime: (sum//get sum last? wanted-tag) + (with-vars [variant-tag sum-tag sum-flag sum-value] + (let [no-match _.nil + is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) + test-recursion (_.if is-last? + ## Must recurse. + (sum//get sum-value + (|> wanted-tag (_.-/2 sum-tag)) + last?) + no-match)] + (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None] + (_.apply/* (_.global "apply") (list (_.global "values") sum))])) + (_.if (|> wanted-tag (_.=/2 sum-tag)) + (_.if (|> sum-flag (_.eqv?/2 last?)) + sum-value + test-recursion)) + (_.if (|> wanted-tag (_.>/2 sum-tag)) + test-recursion) + (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) + (|> wanted-tag (_. sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) + no-match)))) + +(def: runtime//adt + Computation + (_.begin (list @@product//left + @@product//right + @@sum//get))) + +(runtime: (bit//logical-right-shift shift input) + (_.if (_.=/2 (_.int 0) shift) + input + (|> input + (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) + (_.bit-and/2 (_.int (hex "7FFFFFFFFFFFFFFF")))))) + +(def: runtime//bit + Computation + (_.begin (list @@bit//logical-right-shift))) + +(runtime: (frac//decode input) + (with-vars [@output] + (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) + (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) + (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) + ..none + (..some @output))))) + +(def: runtime//frac + Computation + (_.begin + (list @@frac//decode))) + +(def: (check-index-out-of-bounds array idx body) + (-> Expression Expression Expression Computation) + (_.if (|> idx (_.<=/2 (_.length/1 array))) + body + (_.raise/1 (_.string "Array index out of bounds!")))) + +(runtime: (array//get array idx) + (with-vars [@temp] + (<| (check-index-out-of-bounds array idx) + (_.let (list [@temp (_.vector-ref/2 array idx)]) + (_.if (|> @temp (_.eqv?/2 _.nil)) + ..none + (..some @temp)))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds array idx) + (_.begin + (list (_.vector-set!/3 array idx value) + array)))) + +(def: runtime//array + Computation + (_.begin + (list @@array//get + @@array//put))) + +(runtime: (atom//compare-and-swap atom old new) + (with-vars [@temp] + (_.let (list [@temp (_.vector-ref/2 atom (_.int 0))]) + (_.if (_.eq?/2 old @temp) + (_.begin + (list (_.vector-set!/3 atom (_.int 0) new) + (_.bool true))) + (_.bool false))))) + +(def: runtime//atom + Computation + @@atom//compare-and-swap) + +(runtime: (box//write value box) + (_.begin + (list + (_.vector-set!/3 box (_.int 0) value) + ..unit))) + +(def: runtime//box + Computation + (_.begin (list @@box//write))) + +(runtime: (io//current-time _) + (|> (_.apply/* (_.global "current-second") (list)) + (_.*/2 (_.int 1_000)) + _.exact/1)) + +(def: runtime//io + (_.begin (list @@io//current-time))) + +(def: process//incoming + Var + (_.var (name.normalize "process//incoming"))) + +(runtime: (process//loop _) + (_.when (_.not/1 (_.null?/1 process//incoming)) + (with-vars [queue process] + (_.let (list [queue process//incoming]) + (_.begin (list (_.set! process//incoming (_.list/* (list))) + (_.map/2 (_.lambda [(list process) #.None] + (_.apply/1 process ..unit)) + queue) + (process//loop ..unit))))))) + +(runtime: (process//schedule milli-seconds procedure) + (let [process//future (function (_ process) + (_.set! process//incoming (_.cons/2 process process//incoming)))] + (_.begin + (list + (_.if (_.=/2 (_.int 0) milli-seconds) + (process//future procedure) + (with-vars [@start @process @now @ignored] + (_.let (list [@start (io//current-time ..unit)]) + (_.letrec (list [@process (_.lambda [(list) (#.Some @ignored)] + (_.let (list [@now (io//current-time ..unit)]) + (_.if (|> @now (_.-/2 @start) (_.>=/2 milli-seconds)) + (_.apply/1 procedure ..unit) + (process//future @process))))]) + (process//future @process))))) + ..unit)))) + +(def: runtime//process + Computation + (_.begin (list (_.define process//incoming [(list) #.None] (_.list/* (list))) + @@process//loop + @@process//schedule))) + +(def: runtime + Computation + (_.begin (list @@slice + runtime//lux + runtime//bit + runtime//adt + runtime//frac + runtime//array + runtime//atom + runtime//box + runtime//io + runtime//process + ))) + +(def: #export translate + (Operation Any) + (///.with-buffer + (do compiler.Monad + [_ (///.save! ["" ..prefix] ..runtime)] + (///.save-buffer! "")))) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux new file mode 100644 index 000000000..a11434594 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux @@ -0,0 +1,29 @@ +(.module: + lux + (lux (control [monad #+ do])) + (//// [compiler] + [analysis #+ Variant Tuple] + [synthesis #+ Synthesis] + (host ["_" scheme #+ Expression])) + [//runtime #+ Operation Translator] + [//primitive]) + +(def: #export (tuple translate elemsS+) + (-> Translator (Tuple Synthesis) (Operation Expression)) + (case elemsS+ + #.Nil + (//primitive.text synthesis.unit) + + (#.Cons singletonS #.Nil) + (translate singletonS) + + _ + (do compiler.Monad + [elemsT+ (monad.map @ translate elemsS+)] + (wrap (_.vector/* elemsT+))))) + +(def: #export (variant translate [lefts right? valueS]) + (-> Translator (Variant Synthesis) (Operation Expression)) + (do compiler.Monad + [valueT (translate valueS)] + (wrap (//runtime.variant [lefts right? valueT])))) diff --git a/stdlib/source/lux/lang/extension.lux b/stdlib/source/lux/lang/extension.lux deleted file mode 100644 index 7edac52c3..000000000 --- a/stdlib/source/lux/lang/extension.lux +++ /dev/null @@ -1,131 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data ["e" error] - [text] - (coll (dictionary ["dict" unordered #+ Dict])))) - [// #+ Eval] - [//compiler #+ Operation Compiler] - [//analysis #+ Analyser] - [//synthesis #+ Synthesizer] - [//translation #+ Translator]) - -(do-template [] - [(exception: #export ( {extension Text}) - extension)] - - [unknown-analysis] - [unknown-synthesis] - [unknown-translation] - [unknown-statement] - - [cannot-define-analysis-more-than-once] - [cannot-define-synthesis-more-than-once] - [cannot-define-translation-more-than-once] - [cannot-define-statement-more-than-once] - ) - -(type: #export Analysis - (-> Analyser Eval - (Compiler .Lux - (List Code) - //analysis.Analysis))) - -(type: #export Synthesis - (-> Synthesizer - (Compiler //synthesis.State - (List //analysis.Analysis) - //synthesis.Synthesis))) - -(type: #export (Translation anchor code) - (-> (Translator anchor code) - (Compiler (//translation.State anchor code) - (List //synthesis.Synthesis) - code))) - -(type: #export Statement - (-> (List Code) (Meta Any))) - -(type: #export (Extension e) - (Dict Text e)) - -(type: #export Extensions - {#analysis (Extension Analysis) - #synthesis (Extension Synthesis) - #translation (Extension Translation) - #statement (Extension Statement)}) - -(def: #export fresh - Extensions - {#analysis (dict.new text.Hash) - #synthesis (dict.new text.Hash) - #translation (dict.new text.Hash) - #statement (dict.new text.Hash)}) - -(def: get - (Meta Extensions) - (function (_ compiler) - (#e.Success [compiler - (|> compiler (get@ #.extensions) (:! Extensions))]))) - -(def: (set extensions) - (-> Extensions (Meta Any)) - (function (_ compiler) - (#e.Success [(set@ #.extensions (:! Nothing extensions) compiler) - []]))) - -(do-template [ ] - [(def: #export ( name) - (-> Text (Meta )) - (do //compiler.Monad - [extensions ..get] - (case (dict.get name (get@ extensions)) - (#.Some extension) - (wrap extension) - - #.None - (//compiler.throw name))))] - - [find-analysis Analysis #analysis unknown-analysis] - [find-synthesis Synthesis #synthesis unknown-synthesis] - [find-translation Translation #translation unknown-translation] - [find-statement Statement #statement unknown-statement] - ) - -(def: #export empty - (All [e] (Extension e)) - (dict.new text.Hash)) - -(do-template [ ] - [(def: #export - (All (Operation (Extension ))) - (|> ..get - (:: //compiler.Monad map (get@ ))))] - - [[] all-analyses .Lux - Analysis #analysis] - [[] all-syntheses //synthesis.State - Synthesis #synthesis] - [[anchor code] all-translations (//translation.State anchor code) - Translation #translation] - [[] all-statements Any - Statement #statement] - ) - -(do-template [ ] - [(def: #export ( name extension) - (-> Text (Meta Any)) - (do //compiler.Monad - [extensions ..get - _ (if (not (dict.contains? name (get@ extensions))) - (wrap []) - (//compiler.throw name)) - _ (..set (update@ (dict.put name extension) extensions))] - (wrap [])))] - - [install-analysis Analysis #analysis cannot-define-analysis-more-than-once] - [install-synthesis Synthesis #synthesis cannot-define-synthesis-more-than-once] - [install-translation Translation #translation cannot-define-translation-more-than-once] - [install-statement Statement #statement cannot-define-statement-more-than-once] - ) diff --git a/stdlib/source/lux/lang/extension/analysis.lux b/stdlib/source/lux/lang/extension/analysis.lux deleted file mode 100644 index b412e28df..000000000 --- a/stdlib/source/lux/lang/extension/analysis.lux +++ /dev/null @@ -1,16 +0,0 @@ -(.module: - lux - (lux (data [text] - (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dict])))) - [//] - [/common] - [/host]) - -(def: #export defaults - (//.Extension //.Analysis) - (|> /common.extensions - (dict.merge /host.extensions) - dict.entries - (list/map (function (_ [name proc]) [name (proc name)])) - (dict.from-list text.Hash))) diff --git a/stdlib/source/lux/lang/extension/analysis/common.lux b/stdlib/source/lux/lang/extension/analysis/common.lux deleted file mode 100644 index 3faae601b..000000000 --- a/stdlib/source/lux/lang/extension/analysis/common.lux +++ /dev/null @@ -1,444 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - [thread]) - (concurrency [atom #+ Atom]) - (data [text] - text/format - (coll [list "list/" Functor] - [array] - (dictionary ["dict" unordered #+ Dict]))) - [macro] - (macro [code]) - [lang] - (lang (type ["tc" check]) - [".L" analysis] - (analysis [".A" type] - [".A" case] - [".A" function])) - [io]) - [///]) - -(exception: #export (incorrect-extension-arity {name Text} {arity Nat} {args Nat}) - (ex.report ["Extension" (%t name)] - ["Expected arity" (|> arity .int %i)] - ["Actual arity" (|> args .int %i)])) - -(exception: #export (invalid-syntax {name Text} {arguments (List Code)}) - (ex.report ["Extension" name] - ["Inputs" (|> arguments - list.enumerate - (list/map (function (_ [idx argC]) - (format "\n " (%n idx) " " (%code argC)))) - (text.join-with ""))])) - -## [Utils] -(type: #export Bundle - (Dict Text (-> Text ///.Analysis))) - -(def: #export (install name unnamed) - (-> Text (-> Text ///.Analysis) - (-> Bundle Bundle)) - (dict.put name unnamed)) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict.entries - (list/map (function (_ [key val]) [(format prefix " " key) val])) - (dict.from-list text.Hash))) - -(def: (simple proc inputsT+ outputT) - (-> Text (List Type) Type ///.Analysis) - (let [num-expected (list.size inputsT+)] - (function (_ analyse eval args) - (let [num-actual (list.size args)] - (if (n/= num-expected num-actual) - (do macro.Monad - [_ (typeA.infer outputT) - argsA (monad.map @ - (function (_ [argT argC]) - (typeA.with-type argT - (analyse argC))) - (list.zip2 inputsT+ args))] - (wrap (#analysisL.Extension proc argsA))) - (lang.throw incorrect-extension-arity [proc num-expected num-actual])))))) - -(def: #export (nullary valueT proc) - (-> Type Text ///.Analysis) - (simple proc (list) valueT)) - -(def: #export (unary inputT outputT proc) - (-> Type Type Text ///.Analysis) - (simple proc (list inputT) outputT)) - -(def: #export (binary subjectT paramT outputT proc) - (-> Type Type Type Text ///.Analysis) - (simple proc (list subjectT paramT) outputT)) - -(def: #export (trinary subjectT param0T param1T outputT proc) - (-> Type Type Type Type Text ///.Analysis) - (simple proc (list subjectT param0T param1T) outputT)) - -## [Analysers] -## "lux is" represents reference/pointer equality. -(def: (lux//is proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var)] - ((binary varT varT Bool proc) - analyse eval args)))) - -## "lux try" provides a simple way to interact with the host platform's -## error-handling facilities. -(def: (lux//try proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list opC)) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var) - _ (typeA.infer (type (Either Text varT))) - opA (typeA.with-type (type (io.IO varT)) - (analyse opC))] - (wrap (#analysisL.Extension proc (list opA)))) - - _ - (lang.throw incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (lux//function proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list [_ (#.Symbol ["" func-name])] - [_ (#.Symbol ["" arg-name])] - body)) - (functionA.function analyse func-name arg-name body) - - _ - (lang.throw incorrect-extension-arity [proc +3 (list.size args)])))) - -(def: (lux//case proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list input [_ (#.Record branches)])) - (caseA.case analyse input branches) - - _ - (lang.throw incorrect-extension-arity [proc +2 (list.size args)])))) - -(def: (lux//in-module proc) - (-> Text ///.Analysis) - (function (_ analyse eval argsC+) - (case argsC+ - (^ (list [_ (#.Text module-name)] exprC)) - (lang.with-current-module module-name - (analyse exprC)) - - _ - (lang.throw invalid-syntax [proc argsC+])))) - -(do-template [ ] - [(def: ( proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list typeC valueC)) - (do macro.Monad - [actualT (eval Type typeC) - _ (typeA.infer (:! Type actualT))] - (typeA.with-type - (analyse valueC))) - - _ - (lang.throw incorrect-extension-arity [proc +2 (list.size args)]))))] - - [lux//check (:! Type actualT)] - [lux//coerce Any] - ) - -(def: (lux//check//type proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list valueC)) - (do macro.Monad - [_ (typeA.infer Type) - valueA (typeA.with-type Type - (analyse valueC))] - (wrap valueA)) - - _ - (lang.throw incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: lux-procs - Bundle - (|> (dict.new text.Hash) - (install "is" lux//is) - (install "try" lux//try) - (install "function" lux//function) - (install "case" lux//case) - (install "check" lux//check) - (install "coerce" lux//coerce) - (install "check type" lux//check//type) - (install "in-module" lux//in-module))) - -(def: io-procs - Bundle - (<| (prefix "io") - (|> (dict.new text.Hash) - (install "log" (unary Text Any)) - (install "error" (unary Text Nothing)) - (install "exit" (unary Int Nothing)) - (install "current-time" (nullary Int))))) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash) - (install "and" (binary Nat Nat Nat)) - (install "or" (binary Nat Nat Nat)) - (install "xor" (binary Nat Nat Nat)) - (install "left-shift" (binary Nat Nat Nat)) - (install "logical-right-shift" (binary Nat Nat Nat)) - (install "arithmetic-right-shift" (binary Int Nat Int)) - ))) - -(def: int-procs - Bundle - (<| (prefix "int") - (|> (dict.new text.Hash) - (install "+" (binary Int Int Int)) - (install "-" (binary Int Int Int)) - (install "*" (binary Int Int Int)) - (install "/" (binary Int Int Int)) - (install "%" (binary Int Int Int)) - (install "=" (binary Int Int Bool)) - (install "<" (binary Int Int Bool)) - (install "min" (nullary Int)) - (install "max" (nullary Int)) - (install "to-nat" (unary Int Nat)) - (install "to-frac" (unary Int Frac)) - (install "char" (unary Int Text))))) - -(def: deg-procs - Bundle - (<| (prefix "deg") - (|> (dict.new text.Hash) - (install "+" (binary Deg Deg Deg)) - (install "-" (binary Deg Deg Deg)) - (install "*" (binary Deg Deg Deg)) - (install "/" (binary Deg Deg Deg)) - (install "%" (binary Deg Deg Deg)) - (install "=" (binary Deg Deg Bool)) - (install "<" (binary Deg Deg Bool)) - (install "scale" (binary Deg Nat Deg)) - (install "reciprocal" (binary Deg Nat Deg)) - (install "min" (nullary Deg)) - (install "max" (nullary Deg)) - (install "to-frac" (unary Deg Frac))))) - -(def: frac-procs - Bundle - (<| (prefix "frac") - (|> (dict.new text.Hash) - (install "+" (binary Frac Frac Frac)) - (install "-" (binary Frac Frac Frac)) - (install "*" (binary Frac Frac Frac)) - (install "/" (binary Frac Frac Frac)) - (install "%" (binary Frac Frac Frac)) - (install "=" (binary Frac Frac Bool)) - (install "<" (binary Frac Frac Bool)) - (install "smallest" (nullary Frac)) - (install "min" (nullary Frac)) - (install "max" (nullary Frac)) - (install "not-a-number" (nullary Frac)) - (install "positive-infinity" (nullary Frac)) - (install "negative-infinity" (nullary Frac)) - (install "to-deg" (unary Frac Deg)) - (install "to-int" (unary Frac Int)) - (install "encode" (unary Frac Text)) - (install "decode" (unary Text (type (Maybe Frac))))))) - -(def: text-procs - Bundle - (<| (prefix "text") - (|> (dict.new text.Hash) - (install "=" (binary Text Text Bool)) - (install "<" (binary Text Text Bool)) - (install "concat" (binary Text Text Text)) - (install "index" (trinary Text Text Nat (type (Maybe Nat)))) - (install "size" (unary Text Nat)) - (install "hash" (unary Text Nat)) - (install "replace-once" (trinary Text Text Text Text)) - (install "replace-all" (trinary Text Text Text Text)) - (install "char" (binary Text Nat (type (Maybe Nat)))) - (install "clip" (trinary Text Nat Nat (type (Maybe Text)))) - ))) - -(def: (array//get proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var)] - ((binary (type (Array varT)) Nat (type (Maybe varT)) proc) - analyse eval args)))) - -(def: (array//put proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var)] - ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc) - analyse eval args)))) - -(def: (array//remove proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var)] - ((binary (type (Array varT)) Nat (type (Array varT)) proc) - analyse eval args)))) - -(def: array-procs - Bundle - (<| (prefix "array") - (|> (dict.new text.Hash) - (install "new" (unary Nat Array)) - (install "get" array//get) - (install "put" array//put) - (install "remove" array//remove) - (install "size" (unary (type (Ex [a] (Array a))) Nat)) - ))) - -(def: math-procs - Bundle - (<| (prefix "math") - (|> (dict.new text.Hash) - (install "cos" (unary Frac Frac)) - (install "sin" (unary Frac Frac)) - (install "tan" (unary Frac Frac)) - (install "acos" (unary Frac Frac)) - (install "asin" (unary Frac Frac)) - (install "atan" (unary Frac Frac)) - (install "cosh" (unary Frac Frac)) - (install "sinh" (unary Frac Frac)) - (install "tanh" (unary Frac Frac)) - (install "exp" (unary Frac Frac)) - (install "log" (unary Frac Frac)) - (install "ceil" (unary Frac Frac)) - (install "floor" (unary Frac Frac)) - (install "round" (unary Frac Frac)) - (install "atan2" (binary Frac Frac Frac)) - (install "pow" (binary Frac Frac Frac)) - ))) - -(def: (atom-new proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list initC)) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var) - _ (typeA.infer (type (Atom varT))) - initA (typeA.with-type varT - (analyse initC))] - (wrap (#analysisL.Extension proc (list initA)))) - - _ - (lang.throw incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (atom-read proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var)] - ((unary (type (Atom varT)) varT proc) - analyse eval args)))) - -(def: (atom//compare-and-swap proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var)] - ((trinary (type (Atom varT)) varT varT Bool proc) - analyse eval args)))) - -(def: atom-procs - Bundle - (<| (prefix "atom") - (|> (dict.new text.Hash) - (install "new" atom-new) - (install "read" atom-read) - (install "compare-and-swap" atom//compare-and-swap) - ))) - -(def: (box//new proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list initC)) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var) - _ (typeA.infer (type (All [!] (thread.Box ! varT)))) - initA (typeA.with-type varT - (analyse initC))] - (wrap (#analysisL.Extension proc (list initA)))) - - _ - (lang.throw incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (box//read proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad - [[thread-id threadT] (typeA.with-env tc.var) - [var-id varT] (typeA.with-env tc.var)] - ((unary (type (thread.Box threadT varT)) varT proc) - analyse eval args)))) - -(def: (box//write proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (do macro.Monad - [[thread-id threadT] (typeA.with-env tc.var) - [var-id varT] (typeA.with-env tc.var)] - ((binary varT (type (thread.Box threadT varT)) Any proc) - analyse eval args)))) - -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash) - (install "new" box//new) - (install "read" box//read) - (install "write" box//write) - ))) - -(def: process-procs - Bundle - (<| (prefix "process") - (|> (dict.new text.Hash) - (install "parallelism-level" (nullary Nat)) - (install "schedule" (binary Nat (type (io.IO Any)) Any)) - ))) - -(def: #export extensions - Bundle - (<| (prefix "lux") - (|> (dict.new text.Hash) - (dict.merge lux-procs) - (dict.merge bit-procs) - (dict.merge int-procs) - (dict.merge deg-procs) - (dict.merge frac-procs) - (dict.merge text-procs) - (dict.merge array-procs) - (dict.merge math-procs) - (dict.merge atom-procs) - (dict.merge box-procs) - (dict.merge process-procs) - (dict.merge io-procs)))) diff --git a/stdlib/source/lux/lang/extension/analysis/host.jvm.lux b/stdlib/source/lux/lang/extension/analysis/host.jvm.lux deleted file mode 100644 index 56da166c5..000000000 --- a/stdlib/source/lux/lang/extension/analysis/host.jvm.lux +++ /dev/null @@ -1,1224 +0,0 @@ -(.module: - [lux #- char int] - (lux (control [monad #+ do] - ["p" parser] - ["ex" exception #+ exception:]) - (concurrency ["A" atom]) - (data ["e" error] - [maybe] - [product] - [bool "bool/" Eq] - [text "text/" Eq] - (text format - ["l" lexer]) - (coll [list "list/" Fold Functor Monoid] - [array] - (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad] - (macro [code] - ["s" syntax]) - [lang] - (lang [type] - (type ["tc" check]) - [".L" analysis #+ Analysis] - (analysis [".A" type] - [".A" inference])) - [host]) - ["/" //common] - [///] - ) - -(host.import #long java/lang/reflect/Type - (getTypeName [] String)) - -(def: jvm-type-name - (-> java/lang/reflect/Type Text) - (java/lang/reflect/Type::getTypeName [])) - -(exception: #export (jvm-type-is-not-a-class {jvm-type java/lang/reflect/Type}) - (jvm-type-name jvm-type)) - -(do-template [] - [(exception: #export ( {type Type}) - (%type type))] - - [non-object] - [non-array] - [non-jvm-type] - ) - -(do-template [] - [(exception: #export ( {name Text}) - name)] - - [non-interface] - [non-throwable] - ) - -(do-template [] - [(exception: #export ( {message Text}) - message)] - - [Unknown-Class] - [Primitives-Cannot-Have-Type-Parameters] - [Primitives-Are-Not-Objects] - [Invalid-Type-For-Array-Element] - - [Unknown-Field] - [Mistaken-Field-Owner] - [Not-Virtual-Field] - [Not-Static-Field] - [Cannot-Set-Final-Field] - - [No-Candidates] - [Too-Many-Candidates] - - [Cannot-Cast] - - [Cannot-Possibly-Be-Instance] - - [Cannot-Convert-To-Class] - [Cannot-Convert-To-Parameter] - [Cannot-Convert-To-Lux-Type] - [Unknown-Type-Var] - [Type-Parameter-Mismatch] - [Cannot-Correspond-Type-With-Class] - ) - -(do-template [ ] - [(def: #export Type (#.Primitive (list)))] - - ## Boxes - [Boolean "java.lang.Boolean"] - [Byte "java.lang.Byte"] - [Short "java.lang.Short"] - [Integer "java.lang.Integer"] - [Long "java.lang.Long"] - [Float "java.lang.Float"] - [Double "java.lang.Double"] - [Character "java.lang.Character"] - [String "java.lang.String"] - - ## Primitives - [boolean "boolean"] - [byte "byte"] - [short "short"] - [int "int"] - [long "long"] - [float "float"] - [double "double"] - [char "char"] - ) - -(def: conversion-procs - /.Bundle - (<| (/.prefix "convert") - (|> (dict.new text.Hash) - (/.install "double-to-float" (/.unary Double Float)) - (/.install "double-to-int" (/.unary Double Integer)) - (/.install "double-to-long" (/.unary Double Long)) - (/.install "float-to-double" (/.unary Float Double)) - (/.install "float-to-int" (/.unary Float Integer)) - (/.install "float-to-long" (/.unary Float Long)) - (/.install "int-to-byte" (/.unary Integer Byte)) - (/.install "int-to-char" (/.unary Integer Character)) - (/.install "int-to-double" (/.unary Integer Double)) - (/.install "int-to-float" (/.unary Integer Float)) - (/.install "int-to-long" (/.unary Integer Long)) - (/.install "int-to-short" (/.unary Integer Short)) - (/.install "long-to-double" (/.unary Long Double)) - (/.install "long-to-float" (/.unary Long Float)) - (/.install "long-to-int" (/.unary Long Integer)) - (/.install "long-to-short" (/.unary Long Short)) - (/.install "long-to-byte" (/.unary Long Byte)) - (/.install "char-to-byte" (/.unary Character Byte)) - (/.install "char-to-short" (/.unary Character Short)) - (/.install "char-to-int" (/.unary Character Integer)) - (/.install "char-to-long" (/.unary Character Long)) - (/.install "byte-to-long" (/.unary Byte Long)) - (/.install "short-to-long" (/.unary Short Long)) - ))) - -(do-template [ ] - [(def: - /.Bundle - (<| (/.prefix ) - (|> (dict.new text.Hash) - (/.install "+" (/.binary )) - (/.install "-" (/.binary )) - (/.install "*" (/.binary )) - (/.install "/" (/.binary )) - (/.install "%" (/.binary )) - (/.install "=" (/.binary Boolean)) - (/.install "<" (/.binary Boolean)) - (/.install "and" (/.binary )) - (/.install "or" (/.binary )) - (/.install "xor" (/.binary )) - (/.install "shl" (/.binary Integer )) - (/.install "shr" (/.binary Integer )) - (/.install "ushr" (/.binary Integer )) - )))] - - [int-procs "int" Integer] - [long-procs "long" Long] - ) - -(do-template [ ] - [(def: - /.Bundle - (<| (/.prefix ) - (|> (dict.new text.Hash) - (/.install "+" (/.binary )) - (/.install "-" (/.binary )) - (/.install "*" (/.binary )) - (/.install "/" (/.binary )) - (/.install "%" (/.binary )) - (/.install "=" (/.binary Boolean)) - (/.install "<" (/.binary Boolean)) - )))] - - [float-procs "float" Float] - [double-procs "double" Double] - ) - -(def: char-procs - /.Bundle - (<| (/.prefix "char") - (|> (dict.new text.Hash) - (/.install "=" (/.binary Character Character Boolean)) - (/.install "<" (/.binary Character Character Boolean)) - ))) - -(def: #export boxes - (Dict Text Text) - (|> (list ["boolean" "java.lang.Boolean"] - ["byte" "java.lang.Byte"] - ["short" "java.lang.Short"] - ["int" "java.lang.Integer"] - ["long" "java.lang.Long"] - ["float" "java.lang.Float"] - ["double" "java.lang.Double"] - ["char" "java.lang.Character"]) - (dict.from-list text.Hash))) - -(def: (array//length proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list arrayC)) - (do macro.Monad - [_ (typeA.infer Nat) - [var-id varT] (typeA.with-env tc.var) - arrayA (typeA.with-type (type (Array varT)) - (analyse arrayC))] - (wrap (#analysisL.Extension proc (list arrayA)))) - - _ - (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (array//new proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list lengthC)) - (do macro.Monad - [lengthA (typeA.with-type Nat - (analyse lengthC)) - expectedT macro.expected-type - [level elem-class] (: (Meta [Nat Text]) - (loop [analysisT expectedT - level +0] - (case analysisT - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (recur outputT level) - - #.None - (lang.throw non-array expectedT)) - - (^ (#.Primitive "#Array" (list elemT))) - (recur elemT (inc level)) - - (#.Primitive class _) - (wrap [level class]) - - _ - (lang.throw non-array expectedT)))) - _ (if (n/> +0 level) - (wrap []) - (lang.throw non-array expectedT))] - (wrap (#analysisL.Extension proc (list (analysisL.nat (dec level)) - (analysisL.text elem-class) - lengthA)))) - - _ - (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (check-jvm objectT) - (-> Type (Meta Text)) - (case objectT - (#.Primitive name _) - (macro/wrap name) - - (#.Named name unnamed) - (check-jvm unnamed) - - (#.Var id) - (macro/wrap "java.lang.Object") - - (^template [] - ( env unquantified) - (check-jvm unquantified)) - ([#.UnivQ] - [#.ExQ]) - - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (check-jvm outputT) - - #.None - (lang.throw non-object objectT)) - - _ - (lang.throw non-object objectT))) - -(def: (check-object objectT) - (-> Type (Meta Text)) - (do macro.Monad - [name (check-jvm objectT)] - (if (dict.contains? name boxes) - (lang.throw Primitives-Are-Not-Objects name) - (macro/wrap name)))) - -(def: (box-array-element-type elemT) - (-> Type (Meta [Type Text])) - (case elemT - (#.Primitive name #.Nil) - (let [boxed-name (|> (dict.get name boxes) - (maybe.default name))] - (macro/wrap [(#.Primitive boxed-name #.Nil) - boxed-name])) - - (#.Primitive name _) - (if (dict.contains? name boxes) - (lang.throw Primitives-Cannot-Have-Type-Parameters name) - (macro/wrap [elemT name])) - - _ - (lang.throw Invalid-Type-For-Array-Element (%type elemT)))) - -(def: (array//read proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list arrayC idxC)) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var) - _ (typeA.infer varT) - arrayA (typeA.with-type (type (Array varT)) - (analyse arrayC)) - ?elemT (typeA.with-env - (tc.read var-id)) - [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) - idxA (typeA.with-type Nat - (analyse idxC))] - (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA arrayA)))) - - _ - (lang.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) - -(def: (array//write proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list arrayC idxC valueC)) - (do macro.Monad - [[var-id varT] (typeA.with-env tc.var) - _ (typeA.infer (type (Array varT))) - arrayA (typeA.with-type (type (Array varT)) - (analyse arrayC)) - ?elemT (typeA.with-env - (tc.read var-id)) - [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) - idxA (typeA.with-type Nat - (analyse idxC)) - valueA (typeA.with-type valueT - (analyse valueC))] - (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA valueA arrayA)))) - - _ - (lang.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) - -(def: array-procs - /.Bundle - (<| (/.prefix "array") - (|> (dict.new text.Hash) - (/.install "length" array//length) - (/.install "new" array//new) - (/.install "read" array//read) - (/.install "write" array//write) - ))) - -(def: (object//null proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list)) - (do macro.Monad - [expectedT macro.expected-type - _ (check-object expectedT)] - (wrap (#analysisL.Extension proc (list)))) - - _ - (lang.throw /.incorrect-extension-arity [proc +0 (list.size args)])))) - -(def: (object//null? proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list objectC)) - (do macro.Monad - [_ (typeA.infer Bool) - [objectT objectA] (typeA.with-inference - (analyse objectC)) - _ (check-object objectT)] - (wrap (#analysisL.Extension proc (list objectA)))) - - _ - (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (object//synchronized proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list monitorC exprC)) - (do macro.Monad - [[monitorT monitorA] (typeA.with-inference - (analyse monitorC)) - _ (check-object monitorT) - exprA (analyse exprC)] - (wrap (#analysisL.Extension proc (list monitorA exprA)))) - - _ - (lang.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) - -(host.import java/lang/Object - (equals [Object] boolean)) - -(host.import java/lang/ClassLoader) - -(host.import java/lang/reflect/GenericArrayType - (getGenericComponentType [] java/lang/reflect/Type)) - -(host.import java/lang/reflect/ParameterizedType - (getRawType [] java/lang/reflect/Type) - (getActualTypeArguments [] (Array java/lang/reflect/Type))) - -(host.import (java/lang/reflect/TypeVariable d) - (getName [] String) - (getBounds [] (Array java/lang/reflect/Type))) - -(host.import (java/lang/reflect/WildcardType d) - (getLowerBounds [] (Array java/lang/reflect/Type)) - (getUpperBounds [] (Array java/lang/reflect/Type))) - -(host.import java/lang/reflect/Modifier - (#static isStatic [int] boolean) - (#static isFinal [int] boolean) - (#static isInterface [int] boolean) - (#static isAbstract [int] boolean)) - -(host.import java/lang/reflect/Field - (getDeclaringClass [] (java/lang/Class Object)) - (getModifiers [] int) - (getGenericType [] java/lang/reflect/Type)) - -(host.import java/lang/reflect/Method - (getName [] String) - (getModifiers [] int) - (getDeclaringClass [] (Class Object)) - (getTypeParameters [] (Array (TypeVariable Method))) - (getGenericParameterTypes [] (Array java/lang/reflect/Type)) - (getGenericReturnType [] java/lang/reflect/Type) - (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) - -(host.import (java/lang/reflect/Constructor c) - (getModifiers [] int) - (getDeclaringClass [] (Class c)) - (getTypeParameters [] (Array (TypeVariable (Constructor c)))) - (getGenericParameterTypes [] (Array java/lang/reflect/Type)) - (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) - -(host.import (java/lang/Class c) - (getName [] String) - (getModifiers [] int) - (#static forName [String] #try (Class Object)) - (isAssignableFrom [(Class Object)] boolean) - (getTypeParameters [] (Array (TypeVariable (Class c)))) - (getGenericInterfaces [] (Array java/lang/reflect/Type)) - (getGenericSuperclass [] java/lang/reflect/Type) - (getDeclaredField [String] #try Field) - (getConstructors [] (Array (Constructor Object))) - (getDeclaredMethods [] (Array Method))) - -(def: (load-class name) - (-> Text (Meta (Class Object))) - (do macro.Monad - [] - (case (Class::forName [name]) - (#e.Success [class]) - (wrap class) - - (#e.Error error) - (lang.throw Unknown-Class name)))) - -(def: (sub-class? super sub) - (-> Text Text (Meta Bool)) - (do macro.Monad - [super (load-class super) - sub (load-class sub)] - (wrap (Class::isAssignableFrom [sub] super)))) - -(def: (object//throw proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list exceptionC)) - (do macro.Monad - [_ (typeA.infer Nothing) - [exceptionT exceptionA] (typeA.with-inference - (analyse exceptionC)) - exception-class (check-object exceptionT) - ? (sub-class? "java.lang.Throwable" exception-class) - _ (: (Meta Any) - (if ? - (wrap []) - (lang.throw non-throwable exception-class)))] - (wrap (#analysisL.Extension proc (list exceptionA)))) - - _ - (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (object//class proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list classC)) - (case classC - [_ (#.Text class)] - (do macro.Monad - [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) - _ (load-class class)] - (wrap (#analysisL.Extension proc (list (analysisL.text class))))) - - _ - (lang.throw /.invalid-syntax [proc args])) - - _ - (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (object//instance? proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list classC objectC)) - (case classC - [_ (#.Text class)] - (do macro.Monad - [_ (typeA.infer Bool) - [objectT objectA] (typeA.with-inference - (analyse objectC)) - object-class (check-object objectT) - ? (sub-class? class object-class)] - (if ? - (wrap (#analysisL.Extension proc (list (analysisL.text class)))) - (lang.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class)))) - - _ - (lang.throw /.invalid-syntax [proc args])) - - _ - (lang.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) - -(def: (java-type-to-class type) - (-> java/lang/reflect/Type (Meta Text)) - (cond (host.instance? Class type) - (macro/wrap (Class::getName [] (:! Class type))) - - (host.instance? ParameterizedType type) - (java-type-to-class (ParameterizedType::getRawType [] (:! ParameterizedType type))) - - ## else - (lang.throw Cannot-Convert-To-Class (jvm-type-name type)))) - -(type: Mappings - (Dict Text Type)) - -(def: fresh-mappings Mappings (dict.new text.Hash)) - -(def: (java-type-to-lux-type mappings java-type) - (-> Mappings java/lang/reflect/Type (Meta Type)) - (cond (host.instance? TypeVariable java-type) - (let [var-name (TypeVariable::getName [] (:! TypeVariable java-type))] - (case (dict.get var-name mappings) - (#.Some var-type) - (macro/wrap var-type) - - #.None - (lang.throw Unknown-Type-Var var-name))) - - (host.instance? WildcardType java-type) - (let [java-type (:! WildcardType java-type)] - (case [(array.read +0 (WildcardType::getUpperBounds [] java-type)) - (array.read +0 (WildcardType::getLowerBounds [] java-type))] - (^or [(#.Some bound) _] [_ (#.Some bound)]) - (java-type-to-lux-type mappings bound) - - _ - (macro/wrap Any))) - - (host.instance? Class java-type) - (let [java-type (:! (Class Object) java-type) - class-name (Class::getName [] java-type)] - (macro/wrap (case (array.size (Class::getTypeParameters [] java-type)) - +0 - (#.Primitive class-name (list)) - - arity - (|> (list.n/range +0 (dec arity)) - list.reverse - (list/map (|>> (n/* +2) inc #.Bound)) - (#.Primitive class-name) - (type.univ-q arity))))) - - (host.instance? ParameterizedType java-type) - (let [java-type (:! ParameterizedType java-type) - raw (ParameterizedType::getRawType [] java-type)] - (if (host.instance? Class raw) - (do macro.Monad - [paramsT (|> java-type - (ParameterizedType::getActualTypeArguments []) - array.to-list - (monad.map @ (java-type-to-lux-type mappings)))] - (macro/wrap (#.Primitive (Class::getName [] (:! (Class Object) raw)) - paramsT))) - (lang.throw jvm-type-is-not-a-class raw))) - - (host.instance? GenericArrayType java-type) - (do macro.Monad - [innerT (|> (:! GenericArrayType java-type) - (GenericArrayType::getGenericComponentType []) - (java-type-to-lux-type mappings))] - (wrap (#.Primitive "#Array" (list innerT)))) - - ## else - (lang.throw Cannot-Convert-To-Lux-Type (jvm-type-name java-type)))) - -(def: (correspond-type-params class type) - (-> (Class Object) Type (Meta Mappings)) - (case type - (#.Primitive name params) - (let [class-name (Class::getName [] class) - class-params (array.to-list (Class::getTypeParameters [] class)) - num-class-params (list.size class-params) - num-type-params (list.size params)] - (cond (not (text/= class-name name)) - (lang.throw Cannot-Correspond-Type-With-Class - (format "Class = " class-name "\n" - "Type = " (%type type))) - - (not (n/= num-class-params num-type-params)) - (lang.throw Type-Parameter-Mismatch - (format "Expected: " (%i (.int num-class-params)) "\n" - " Actual: " (%i (.int num-type-params)) "\n" - " Class: " class-name "\n" - " Type: " (%type type))) - - ## else - (macro/wrap (|> params - (list.zip2 (list/map (TypeVariable::getName []) class-params)) - (dict.from-list text.Hash))) - )) - - _ - (lang.throw non-jvm-type type))) - -(def: (object//cast proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list valueC)) - (do macro.Monad - [toT macro.expected-type - to-name (check-jvm toT) - [valueT valueA] (typeA.with-inference - (analyse valueC)) - from-name (check-jvm valueT) - can-cast? (: (Meta Bool) - (case [from-name to-name] - (^template [ ] - (^or [ ] - [ ]) - (do @ - [_ (typeA.infer (#.Primitive to-name (list)))] - (wrap true))) - (["boolean" "java.lang.Boolean"] - ["byte" "java.lang.Byte"] - ["short" "java.lang.Short"] - ["int" "java.lang.Integer"] - ["long" "java.lang.Long"] - ["float" "java.lang.Float"] - ["double" "java.lang.Double"] - ["char" "java.lang.Character"]) - - _ - (do @ - [_ (lang.assert Primitives-Are-Not-Objects from-name - (not (dict.contains? from-name boxes))) - _ (lang.assert Primitives-Are-Not-Objects to-name - (not (dict.contains? to-name boxes))) - to-class (load-class to-name)] - (loop [[current-name currentT] [from-name valueT]] - (if (text/= to-name current-name) - (do @ - [_ (typeA.infer toT)] - (wrap true)) - (do @ - [current-class (load-class current-name) - _ (lang.assert Cannot-Cast (format "From class/primitive: " current-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n") - (Class::isAssignableFrom [current-class] to-class)) - candiate-parents (monad.map @ - (function (_ java-type) - (do @ - [class-name (java-type-to-class java-type) - class (load-class class-name)] - (wrap [[class-name java-type] (Class::isAssignableFrom [class] to-class)]))) - (list& (Class::getGenericSuperclass [] current-class) - (array.to-list (Class::getGenericInterfaces [] current-class))))] - (case (|> candiate-parents - (list.filter product.right) - (list/map product.left)) - (#.Cons [next-name nextJT] _) - (do @ - [mapping (correspond-type-params current-class currentT) - nextT (java-type-to-lux-type mapping nextJT)] - (recur [next-name nextT])) - - #.Nil - (lang.throw Cannot-Cast (format "From class/primitive: " from-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n"))) - ))))))] - (if can-cast? - (wrap (#analysisL.Extension proc (list (analysisL.text from-name) - (analysisL.text to-name) - valueA))) - (lang.throw Cannot-Cast (format "From class/primitive: " from-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n")))) - - _ - (lang.throw /.invalid-syntax [proc args])))) - -(def: object-procs - /.Bundle - (<| (/.prefix "object") - (|> (dict.new text.Hash) - (/.install "null" object//null) - (/.install "null?" object//null?) - (/.install "synchronized" object//synchronized) - (/.install "throw" object//throw) - (/.install "class" object//class) - (/.install "instance?" object//instance?) - (/.install "cast" object//cast) - ))) - -(def: (find-field class-name field-name) - (-> Text Text (Meta [(Class Object) Field])) - (do macro.Monad - [class (load-class class-name)] - (case (Class::getDeclaredField [field-name] class) - (#e.Success field) - (let [owner (Field::getDeclaringClass [] field)] - (if (is? owner class) - (wrap [class field]) - (lang.throw Mistaken-Field-Owner - (format " Field: " field-name "\n" - " Owner Class: " (Class::getName [] owner) "\n" - "Target Class: " class-name "\n")))) - - (#e.Error _) - (lang.throw Unknown-Field (format class-name "#" field-name))))) - -(def: (static-field class-name field-name) - (-> Text Text (Meta [Type Bool])) - (do macro.Monad - [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field::getModifiers [] fieldJ)]] - (if (Modifier::isStatic [modifiers]) - (let [fieldJT (Field::getGenericType [] fieldJ)] - (do @ - [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] - (wrap [fieldT (Modifier::isFinal [modifiers])]))) - (lang.throw Not-Static-Field (format class-name "#" field-name))))) - -(def: (virtual-field class-name field-name objectT) - (-> Text Text Type (Meta [Type Bool])) - (do macro.Monad - [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field::getModifiers [] fieldJ)]] - (if (not (Modifier::isStatic [modifiers])) - (do @ - [#let [fieldJT (Field::getGenericType [] fieldJ) - var-names (|> class - (Class::getTypeParameters []) - array.to-list - (list/map (TypeVariable::getName [])))] - mappings (: (Meta Mappings) - (case objectT - (#.Primitive _class-name _class-params) - (do @ - [#let [num-params (list.size _class-params) - num-vars (list.size var-names)] - _ (lang.assert Type-Parameter-Mismatch - (format "Expected: " (%i (.int num-params)) "\n" - " Actual: " (%i (.int num-vars)) "\n" - " Class: " _class-name "\n" - " Type: " (%type objectT)) - (n/= num-params num-vars))] - (wrap (|> (list.zip2 var-names _class-params) - (dict.from-list text.Hash)))) - - _ - (lang.throw non-object objectT))) - fieldT (java-type-to-lux-type mappings fieldJT)] - (wrap [fieldT (Modifier::isFinal [modifiers])])) - (lang.throw Not-Virtual-Field (format class-name "#" field-name))))) - -(def: (static//get proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list classC fieldC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad - [[fieldT final?] (static-field class field)] - (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field))))) - - _ - (lang.throw /.invalid-syntax [proc args])) - - _ - (lang.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) - -(def: (static//put proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list classC fieldC valueC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad - [_ (typeA.infer Any) - [fieldT final?] (static-field class field) - _ (lang.assert Cannot-Set-Final-Field (format class "#" field) - (not final?)) - valueA (typeA.with-type fieldT - (analyse valueC))] - (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA)))) - - _ - (lang.throw /.invalid-syntax [proc args])) - - _ - (lang.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) - -(def: (virtual//get proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list classC fieldC objectC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad - [[objectT objectA] (typeA.with-inference - (analyse objectC)) - [fieldT final?] (virtual-field class field objectT)] - (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) objectA)))) - - _ - (lang.throw /.invalid-syntax [proc args])) - - _ - (lang.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) - -(def: (virtual//put proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list classC fieldC valueC objectC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad - [[objectT objectA] (typeA.with-inference - (analyse objectC)) - _ (typeA.infer objectT) - [fieldT final?] (virtual-field class field objectT) - _ (lang.assert Cannot-Set-Final-Field (format class "#" field) - (not final?)) - valueA (typeA.with-type fieldT - (analyse valueC))] - (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA objectA)))) - - _ - (lang.throw /.invalid-syntax [proc args])) - - _ - (lang.throw /.incorrect-extension-arity [proc +4 (list.size args)])))) - -(def: (java-type-to-parameter type) - (-> java/lang/reflect/Type (Meta Text)) - (cond (host.instance? Class type) - (macro/wrap (Class::getName [] (:! Class type))) - - (host.instance? ParameterizedType type) - (java-type-to-parameter (ParameterizedType::getRawType [] (:! ParameterizedType type))) - - (or (host.instance? TypeVariable type) - (host.instance? WildcardType type)) - (macro/wrap "java.lang.Object") - - (host.instance? GenericArrayType type) - (do macro.Monad - [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:! GenericArrayType type)))] - (wrap (format componentP "[]"))) - - ## else - (lang.throw Cannot-Convert-To-Parameter (jvm-type-name type)))) - -(type: Method-Type - #Static - #Abstract - #Virtual - #Special - #Interface) - -(def: (check-method class method-name method-type arg-classes method) - (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool)) - (do macro.Monad - [parameters (|> (Method::getGenericParameterTypes [] method) - array.to-list - (monad.map @ java-type-to-parameter)) - #let [modifiers (Method::getModifiers [] method)]] - (wrap (and (Object::equals [class] (Method::getDeclaringClass [] method)) - (text/= method-name (Method::getName [] method)) - (case #Static - #Special - (Modifier::isStatic [modifiers]) - - _ - true) - (case method-type - #Special - (not (or (Modifier::isInterface [(Class::getModifiers [] class)]) - (Modifier::isAbstract [modifiers]))) - - _ - true) - (n/= (list.size arg-classes) (list.size parameters)) - (list/fold (function (_ [expectedJC actualJC] prev) - (and prev - (text/= expectedJC actualJC))) - true - (list.zip2 arg-classes parameters)))))) - -(def: (check-constructor class arg-classes constructor) - (-> (Class Object) (List Text) (Constructor Object) (Meta Bool)) - (do macro.Monad - [parameters (|> (Constructor::getGenericParameterTypes [] constructor) - array.to-list - (monad.map @ java-type-to-parameter))] - (wrap (and (Object::equals [class] (Constructor::getDeclaringClass [] constructor)) - (n/= (list.size arg-classes) (list.size parameters)) - (list/fold (function (_ [expectedJC actualJC] prev) - (and prev - (text/= expectedJC actualJC))) - true - (list.zip2 arg-classes parameters)))))) - -(def: idx-to-bound - (-> Nat Type) - (|>> (n/* +2) inc #.Bound)) - -(def: (type-vars amount offset) - (-> Nat Nat (List Type)) - (if (n/= +0 amount) - (list) - (|> (list.n/range offset (|> amount dec (n/+ offset))) - (list/map idx-to-bound)))) - -(def: (method-to-type method-type method) - (-> Method-Type Method (Meta [Type (List Type)])) - (let [owner (Method::getDeclaringClass [] method) - owner-name (Class::getName [] owner) - owner-tvars (case method-type - #Static - (list) - - _ - (|> (Class::getTypeParameters [] owner) - array.to-list - (list/map (TypeVariable::getName [])))) - method-tvars (|> (Method::getTypeParameters [] method) - array.to-list - (list/map (TypeVariable::getName []))) - num-owner-tvars (list.size owner-tvars) - num-method-tvars (list.size method-tvars) - all-tvars (list/compose owner-tvars method-tvars) - num-all-tvars (list.size all-tvars) - owner-tvarsT (type-vars num-owner-tvars +0) - method-tvarsT (type-vars num-method-tvars num-owner-tvars) - mappings (: Mappings - (if (list.empty? all-tvars) - fresh-mappings - (|> (list/compose owner-tvarsT method-tvarsT) - list.reverse - (list.zip2 all-tvars) - (dict.from-list text.Hash))))] - (do macro.Monad - [inputsT (|> (Method::getGenericParameterTypes [] method) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - outputT (java-type-to-lux-type mappings (Method::getGenericReturnType [] method)) - exceptionsT (|> (Method::getGenericExceptionTypes [] method) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - #let [methodT (<| (type.univ-q num-all-tvars) - (type.function (case method-type - #Static - inputsT - - _ - (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) - inputsT))) - outputT)]] - (wrap [methodT exceptionsT])))) - -(def: (methods class-name method-name method-type arg-classes) - (-> Text Text Method-Type (List Text) (Meta [Type (List Type)])) - (do macro.Monad - [class (load-class class-name) - candidates (|> class - (Class::getDeclaredMethods []) - array.to-list - (monad.map @ (function (_ method) - (do @ - [passes? (check-method class method-name method-type arg-classes method)] - (wrap [passes? method])))))] - (case (list.filter product.left candidates) - #.Nil - (lang.throw No-Candidates (format class-name "#" method-name)) - - (#.Cons candidate #.Nil) - (|> candidate product.right (method-to-type method-type)) - - _ - (lang.throw Too-Many-Candidates (format class-name "#" method-name))))) - -(def: (constructor-to-type constructor) - (-> (Constructor Object) (Meta [Type (List Type)])) - (let [owner (Constructor::getDeclaringClass [] constructor) - owner-name (Class::getName [] owner) - owner-tvars (|> (Class::getTypeParameters [] owner) - array.to-list - (list/map (TypeVariable::getName []))) - constructor-tvars (|> (Constructor::getTypeParameters [] constructor) - array.to-list - (list/map (TypeVariable::getName []))) - num-owner-tvars (list.size owner-tvars) - all-tvars (list/compose owner-tvars constructor-tvars) - num-all-tvars (list.size all-tvars) - owner-tvarsT (type-vars num-owner-tvars +0) - constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) - mappings (: Mappings - (if (list.empty? all-tvars) - fresh-mappings - (|> (list/compose owner-tvarsT constructor-tvarsT) - list.reverse - (list.zip2 all-tvars) - (dict.from-list text.Hash))))] - (do macro.Monad - [inputsT (|> (Constructor::getGenericParameterTypes [] constructor) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - exceptionsT (|> (Constructor::getGenericExceptionTypes [] constructor) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT)) - constructorT (<| (type.univ-q num-all-tvars) - (type.function inputsT) - objectT)]] - (wrap [constructorT exceptionsT])))) - -(def: (constructor-methods class-name arg-classes) - (-> Text (List Text) (Meta [Type (List Type)])) - (do macro.Monad - [class (load-class class-name) - candidates (|> class - (Class::getConstructors []) - array.to-list - (monad.map @ (function (_ constructor) - (do @ - [passes? (check-constructor class arg-classes constructor)] - (wrap [passes? constructor])))))] - (case (list.filter product.left candidates) - #.Nil - (lang.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")")) - - (#.Cons candidate #.Nil) - (|> candidate product.right constructor-to-type) - - _ - (lang.throw Too-Many-Candidates class-name)))) - -(def: (decorate-inputs typesT inputsA) - (-> (List Text) (List Analysis) (List Analysis)) - (|> inputsA - (list.zip2 (list/map analysisL.text typesT)) - (list/map (function (_ [type value]) - (analysisL.product-analysis (list type value)))))) - -(def: (invoke//static proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case (: (e.Error [Text Text (List [Text Code])]) - (s.run args ($_ p.seq s.text s.text (p.some (s.tuple (p.seq s.text s.any)))))) - (#e.Success [class method argsTC]) - (do macro.Monad - [#let [argsT (list/map product.left argsTC)] - [methodT exceptionsT] (methods class method #Static argsT) - [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) - outputJC (check-jvm outputT)] - (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) - (analysisL.text outputJC) (decorate-inputs argsT argsA))))) - - _ - (lang.throw /.invalid-syntax [proc args])))) - -(def: (invoke//virtual proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case (: (e.Error [Text Text Code (List [Text Code])]) - (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) - (#e.Success [class method objectC argsTC]) - (do macro.Monad - [#let [argsT (list/map product.left argsTC)] - [methodT exceptionsT] (methods class 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))] - outputJC (check-jvm outputT)] - (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) - (analysisL.text outputJC) objectA (decorate-inputs argsT argsA))))) - - _ - (lang.throw /.invalid-syntax [proc args])))) - -(def: (invoke//special proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Any]]) - (p.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))) s.end!))) - (#e.Success [_ [class method objectC argsTC _]]) - (do macro.Monad - [#let [argsT (list/map product.left argsTC)] - [methodT exceptionsT] (methods class method #Special argsT) - [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) - outputJC (check-jvm outputT)] - (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) - (analysisL.text outputJC) (decorate-inputs argsT argsA))))) - - _ - (lang.throw /.invalid-syntax [proc args])))) - -(def: (invoke//interface proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case (: (e.Error [Text Text Code (List [Text Code])]) - (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) - (#e.Success [class-name method objectC argsTC]) - (do macro.Monad - [#let [argsT (list/map product.left argsTC)] - class (load-class class-name) - _ (lang.assert non-interface class-name - (Modifier::isInterface [(Class::getModifiers [] class)])) - [methodT exceptionsT] (methods class-name method #Interface argsT) - [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) - outputJC (check-jvm outputT)] - (wrap (#analysisL.Extension proc - (list& (analysisL.text class-name) (analysisL.text method) (analysisL.text outputJC) - (decorate-inputs argsT argsA))))) - - _ - (lang.throw /.invalid-syntax [proc args])))) - -(def: (invoke//constructor proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case (: (e.Error [Text (List [Text Code])]) - (s.run args ($_ p.seq s.text (p.some (s.tuple (p.seq s.text s.any)))))) - (#e.Success [class argsTC]) - (do macro.Monad - [#let [argsT (list/map product.left argsTC)] - [methodT exceptionsT] (constructor-methods class argsT) - [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] - (wrap (#analysisL.Extension proc (list& (analysisL.text class) (decorate-inputs argsT argsA))))) - - _ - (lang.throw /.invalid-syntax [proc args])))) - -(def: member-procs - /.Bundle - (<| (/.prefix "member") - (|> (dict.new text.Hash) - (dict.merge (<| (/.prefix "static") - (|> (dict.new text.Hash) - (/.install "get" static//get) - (/.install "put" static//put)))) - (dict.merge (<| (/.prefix "virtual") - (|> (dict.new text.Hash) - (/.install "get" virtual//get) - (/.install "put" virtual//put)))) - (dict.merge (<| (/.prefix "invoke") - (|> (dict.new text.Hash) - (/.install "static" invoke//static) - (/.install "virtual" invoke//virtual) - (/.install "special" invoke//special) - (/.install "interface" invoke//interface) - (/.install "constructor" invoke//constructor) - ))) - ))) - -(def: #export extensions - /.Bundle - (<| (/.prefix "jvm") - (|> (dict.new text.Hash) - (dict.merge conversion-procs) - (dict.merge int-procs) - (dict.merge long-procs) - (dict.merge float-procs) - (dict.merge double-procs) - (dict.merge char-procs) - (dict.merge array-procs) - (dict.merge object-procs) - (dict.merge member-procs) - ))) diff --git a/stdlib/source/lux/lang/extension/synthesis.lux b/stdlib/source/lux/lang/extension/synthesis.lux deleted file mode 100644 index c48f3e3a5..000000000 --- a/stdlib/source/lux/lang/extension/synthesis.lux +++ /dev/null @@ -1,9 +0,0 @@ -(.module: - lux - (lux (data [text] - (coll (dictionary ["dict" unordered #+ Dict])))) - [//]) - -(def: #export defaults - (Dict Text //.Synthesis) - (dict.new text.Hash)) diff --git a/stdlib/source/lux/lang/extension/translation.lux b/stdlib/source/lux/lang/extension/translation.lux deleted file mode 100644 index bc95ed1f4..000000000 --- a/stdlib/source/lux/lang/extension/translation.lux +++ /dev/null @@ -1,9 +0,0 @@ -(.module: - lux - (lux (data [text] - (coll (dictionary ["dict" unordered #+ Dict])))) - [//]) - -(def: #export defaults - (Dict Text //.Translation) - (dict.new text.Hash)) diff --git a/stdlib/source/lux/lang/host.lux b/stdlib/source/lux/lang/host.lux new file mode 100644 index 000000000..218de67a4 --- /dev/null +++ b/stdlib/source/lux/lang/host.lux @@ -0,0 +1,18 @@ +(.module: + lux) + +(type: #export Host Text) + +(do-template [ ] + [(def: #export Host )] + + [common-lisp "Common Lisp"] + [js "JavaScript"] + [jvm "JVM"] + [lua "Lua"] + [php "PHP"] + [python "Python"] + [r "R"] + [ruby "Ruby"] + [scheme "Scheme"] + ) diff --git a/stdlib/source/lux/lang/init.lux b/stdlib/source/lux/lang/init.lux deleted file mode 100644 index 40a7fc69c..000000000 --- a/stdlib/source/lux/lang/init.lux +++ /dev/null @@ -1,61 +0,0 @@ -(.module: - lux - [//] - (// ["//." target] - [".L" extension] - (extension [".E" analysis] - [".E" synthesis] - [".E" translation] - ## [".E" statement] - ))) - -(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: #export type-context - Type-Context - {#.ex-counter +0 - #.var-counter +0 - #.var-bindings (list)}) - -(`` (def: #export info - Info - {#.target (for {(~~ (static //target.common-lisp)) //target.common-lisp - (~~ (static //target.js)) //target.js - (~~ (static //target.jvm)) //target.jvm - (~~ (static //target.lua)) //target.lua - (~~ (static //target.php)) //target.php - (~~ (static //target.python)) //target.python - (~~ (static //target.r)) //target.r - (~~ (static //target.ruby)) //target.ruby - (~~ (static //target.scheme)) //target.scheme}) - #.version //.version - #.mode #.Build})) - -(def: #export (compiler host) - (-> 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 {#extensionL.analysis analysisE.defaults - #extensionL.synthesis synthesisE.defaults - #extensionL.translation translationE.defaults - #extensionL.statement (:!! []) ## statementE.defaults - } - #.host host}) diff --git a/stdlib/source/lux/lang/module.lux b/stdlib/source/lux/lang/module.lux index 161fd073a..d6b66da74 100644 --- a/stdlib/source/lux/lang/module.lux +++ b/stdlib/source/lux/lang/module.lux @@ -9,7 +9,8 @@ (coll [list "list/" Fold Functor] (dictionary [plist]))) [macro]) - [//]) + [//compiler] + (//compiler [analysis])) (type: #export Tag Text) @@ -17,13 +18,13 @@ module) (exception: #export (cannot-declare-tag-twice {module Text} {tag Text}) - (format "Module: " module "\n" - " Tag: " tag "\n")) + (ex.report ["Module" module] + ["Tag" tag])) (do-template [] [(exception: #export ( {tags (List Text)} {owner Type}) - (format "Tags: " (text.join-with " " tags) "\n" - "Type: " (%type owner) "\n"))] + (ex.report ["Tags" (text.join-with " " tags)] + ["Type" (%type owner)]))] [cannot-declare-tags-for-unnamed-type] [cannot-declare-tags-for-foreign-type] @@ -33,16 +34,16 @@ (%ident name)) (exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State}) - (format " Module: " module "\n" - "Desired state: " (case state - #.Active "Active" - #.Compiled "Compiled" - #.Cached "Cached") "\n")) + (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}) - (format " Module: " module "\n" - "Old annotations: " (%code old) "\n" - "New annotations: " (%code new) "\n")) + (ex.report ["Module" module] + ["Old annotations" (%code old)] + ["New annotations" (%code new)])) (def: (new hash) (-> Nat Module) @@ -69,7 +70,7 @@ []])) (#.Some old) - (//.throw cannot-set-module-annotations-more-than-once [self-name old annotations])))) + (//compiler.throw cannot-set-module-annotations-more-than-once [self-name old annotations])))) (def: #export (import module) (-> Text (Meta Any)) @@ -119,7 +120,7 @@ []]) (#.Some already-existing) - ((//.throw cannot-define-more-than-once [self-name name]) compiler))))) + ((//compiler.throw cannot-define-more-than-once [self-name name]) compiler))))) (def: #export (create hash name) (-> Nat Text (Meta [])) @@ -134,7 +135,7 @@ (All [a] (-> Nat Text (Meta a) (Meta [Module a]))) (do macro.Monad [_ (create hash name) - output (//.with-current-module name + output (analysis.with-current-module name action) module (macro.find-module name)] (wrap [module output]))) @@ -153,11 +154,11 @@ (plist.put module-name (set@ #.module-state module)) compiler) []]) - ((//.throw can-only-change-state-of-active-module [module-name ]) + ((//compiler.throw can-only-change-state-of-active-module [module-name ]) compiler))) #.None - ((//.throw unknown-module module-name) compiler)))) + ((//compiler.throw unknown-module module-name) compiler)))) (def: #export ( module-name) (-> Text (Meta Bool)) @@ -170,7 +171,7 @@ _ false)]) #.None - ((//.throw unknown-module module-name) compiler))))] + ((//compiler.throw unknown-module module-name) compiler))))] [set-active active? #.Active] [set-compiled compiled? #.Compiled] @@ -186,7 +187,7 @@ (#e.Success [compiler (get@ module)]) #.None - ((//.throw unknown-module module-name) compiler))))] + ((//compiler.throw unknown-module module-name) compiler))))] [tags #.tags (List [Text [Nat (List Ident) Bool Type]])] [types #.types (List [Text [(List Ident) Bool Type]])] @@ -204,7 +205,7 @@ (wrap []) (#.Some _) - (//.throw cannot-declare-tag-twice [module-name tag]))) + (//compiler.throw cannot-declare-tag-twice [module-name tag]))) tags)] (wrap []))) @@ -217,10 +218,10 @@ (wrap type-ident) _ - (//.throw cannot-declare-tags-for-unnamed-type [tags type])) + (//compiler.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))] + _ (//compiler.assert cannot-declare-tags-for-foreign-type [tags type] + (text/= self-name type-module))] (function (_ compiler) (case (|> compiler (get@ #.modules) (plist.get self-name)) (#.Some module) @@ -236,4 +237,4 @@ compiler) []])) #.None - ((//.throw unknown-module self-name) compiler))))) + ((//compiler.throw unknown-module self-name) compiler))))) diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux deleted file mode 100644 index 1bf06cdd0..000000000 --- a/stdlib/source/lux/lang/synthesis.lux +++ /dev/null @@ -1,243 +0,0 @@ -(.module: - [lux #- i64 Scope] - (lux (control [monad #+ do]) - (data [error #+ Error] - (coll (dictionary ["dict" unordered #+ Dict])))) - [// #+ Extension] - [//reference #+ Register Variable Reference] - [//analysis #+ Environment Arity Analysis] - [//compiler #+ Operation Compiler]) - -(type: #export Resolver (Dict Variable Variable)) - -(type: #export State - {#scope-arity Arity - #resolver Resolver - #direct? Bool - #locals Nat}) - -(def: #export fresh-resolver - Resolver - (dict.new //reference.Hash)) - -(def: #export init - State - {#scope-arity +0 - #resolver fresh-resolver - #direct? false - #locals +0}) - -(type: #export Primitive - (#Bool Bool) - (#I64 I64) - (#F64 Frac) - (#Text Text)) - -(type: #export (Structure a) - (#Variant (//analysis.Variant a)) - (#Tuple (//analysis.Tuple a))) - -(type: #export Side - (Either Nat Nat)) - -(type: #export Member - (Either Nat Nat)) - -(type: #export Access - (#Side Side) - (#Member Member)) - -(type: #export (Path' s) - #Pop - (#Test Primitive) - (#Access Access) - (#Bind Register) - (#Alt (Path' s) (Path' s)) - (#Seq (Path' s) (Path' s)) - (#Then s)) - -(type: #export (Abstraction' s) - {#environment Environment - #arity Arity - #body s}) - -(type: #export (Branch s) - (#Case s (Path' s)) - (#Let s Register s) - (#If s s s)) - -(type: #export (Scope s) - {#start Register - #inits (List s) - #iteration s}) - -(type: #export (Loop s) - (#Scope (Scope s)) - (#Recur (List s))) - -(type: #export (Function s) - (#Abstraction (Abstraction' s)) - (#Apply s (List s))) - -(type: #export (Control s) - (#Branch (Branch s)) - (#Loop (Loop s)) - (#Function (Function s))) - -(type: #export #rec Synthesis - (#Primitive Primitive) - (#Structure (Structure Synthesis)) - (#Reference Reference) - (#Control (Control Synthesis)) - (#Extension (Extension Synthesis))) - -(type: #export Path - (Path' Synthesis)) - -(def: #export path/pop - Path - #Pop) - -(do-template [ ] - [(template: #export ( content) - (#..Test ( content)))] - - [path/bool #..Bool] - [path/i64 #..I64] - [path/f64 #..F64] - [path/text #..Text] - ) - -(do-template [ ] - [(template: #export ( content) - (.<| #..Access - - content))] - - [path/side #..Side] - [path/member #..Member] - ) - -(do-template [ ] - [(template: #export ( content) - (.<| #..Access - - - content))] - - [side/left #..Side #.Left] - [side/right #..Side #.Right] - [member/left #..Member #.Left] - [member/right #..Member #.Right] - ) - -(do-template [ ] - [(template: #export ( content) - ( content))] - - [path/alt #..Alt] - [path/seq #..Seq] - [path/then #..Then] - ) - -(type: #export Abstraction - (Abstraction' Synthesis)) - -(def: #export unit Text "") - -(type: #export Synthesizer - (Compiler ..State Analysis Synthesis)) - -(do-template [ ] - [(def: #export - (All [a] (-> (Operation ..State a) (Operation ..State a))) - (//compiler.localized (set@ #direct? )))] - - [indirectly false] - [directly true] - ) - -(do-template [ ] - [(def: #export ( value) - (-> (All [a] (-> (Operation ..State a) (Operation ..State a)))) - (//compiler.localized (set@ value)))] - - [with-scope-arity Arity #scope-arity] - [with-resolver Resolver #resolver] - [with-locals Nat #locals] - ) - -(def: #export (with-abstraction arity resolver) - (All [o] - (-> Arity Resolver - (-> (Operation ..State o) (Operation ..State o)))) - (//compiler.with-state {#scope-arity arity - #resolver resolver - #direct? true - #locals arity})) - -(do-template [ ] - [(def: #export - (Operation ..State ) - (function (_ state) - (#error.Success [state (get@ state)])))] - - [scope-arity #scope-arity Arity] - [resolver #resolver Resolver] - [direct? #direct? Bool] - [locals #locals Nat] - ) - -(def: #export with-new-local - (All [a] (-> (Operation ..State a) (Operation ..State a))) - (<<| (do //compiler.Monad - [locals ..locals]) - (..with-locals (inc locals)))) - -(do-template [ ] - [(template: #export ( content) - (#..Primitive ( content)))] - - [bool #..Bool] - [i64 #..I64] - [f64 #..F64] - [text #..Text] - ) - -(do-template [ ] - [(template: #export ( content) - (<| #..Structure - - content))] - - [variant #..Variant] - [tuple #..Tuple] - ) - -(do-template [ ] - [(template: #export ( content) - (.<| #..Reference - - content))] - - [variable/local //reference.local] - [variable/foreign //reference.foreign] - ) - -(do-template [ ] - [(template: #export ( content) - (.<| #..Control - - - content))] - - [branch/case #..Branch #..Case] - [branch/let #..Branch #..Let] - [branch/if #..Branch #..If] - - [loop/scope #..Loop #..Scope] - [loop/recur #..Loop #..Recur] - - [function/abstraction #..Function #..Abstraction] - [function/apply #..Function #..Apply] - ) diff --git a/stdlib/source/lux/lang/synthesis/case.lux b/stdlib/source/lux/lang/synthesis/case.lux deleted file mode 100644 index b7f224168..000000000 --- a/stdlib/source/lux/lang/synthesis/case.lux +++ /dev/null @@ -1,177 +0,0 @@ -(.module: - lux - (lux (control [equality #+ Eq] - pipe - [monad #+ do]) - (data [product] - [bool "bool/" Eq] - [text "text/" Eq] - text/format - [number "frac/" Eq] - (coll [list "list/" Fold Monoid]))) - [///reference] - [///compiler #+ Operation "operation/" Monad] - [///analysis #+ Pattern Match Analysis] - [// #+ Path Synthesis] - [//function]) - -(def: (path' pattern bodyC) - (-> Pattern (Operation //.State Path) (Operation //.State Path)) - (case pattern - (#///analysis.Simple simple) - (case simple - #///analysis.Unit - bodyC - - (^template [ ] - ( value) - (operation/map (|>> (#//.Seq (#//.Test (|> value )))) - bodyC)) - ([#///analysis.Bool #//.Bool] - [#///analysis.Nat (<| #//.I64 .i64)] - [#///analysis.Int (<| #//.I64 .i64)] - [#///analysis.Deg (<| #//.I64 .i64)] - [#///analysis.Frac #//.F64] - [#///analysis.Text #//.Text])) - - (#///analysis.Bind register) - (<| (do ///compiler.Monad - [arity //.scope-arity]) - (:: @ map (|>> (#//.Seq (#//.Bind (if (//function.nested? arity) - (n/+ (dec arity) register) - register))))) - //.with-new-local - bodyC) - - (#///analysis.Complex _) - (case (///analysis.variant-pattern pattern) - (#.Some [lefts right? value-pattern]) - (operation/map (|>> (#//.Seq (#//.Access (#//.Side (if right? - (#.Right lefts) - (#.Left lefts)))))) - (path' value-pattern bodyC)) - - #.None - (let [tuple (///analysis.tuple-pattern pattern) - tuple/last (dec (list.size tuple))] - (list/fold (function (_ [tuple/idx tuple/member] thenC) - (case tuple/member - (#///analysis.Simple #///analysis.Unit) - thenC - - _ - (let [last? (n/= tuple/last tuple/idx)] - (|> (if (or last? - (is? bodyC thenC)) - thenC - (operation/map (|>> (#//.Seq #//.Pop)) thenC)) - (path' tuple/member) - (operation/map (|>> (#//.Seq (#//.Access (#//.Member (if last? - (#.Right (dec tuple/idx)) - (#.Left tuple/idx))))))))))) - bodyC - (list.reverse (list.enumerate tuple))))))) - -(def: #export (path synthesize pattern bodyA) - (-> //.Synthesizer Pattern Analysis (Operation //.State Path)) - (path' pattern (operation/map (|>> #//.Then) (synthesize bodyA)))) - -(def: #export (weave leftP rightP) - (-> Path Path Path) - (with-expansions [ (as-is (#//.Alt leftP rightP))] - (case [leftP rightP] - [(#//.Seq preL postL) - (#//.Seq preR postR)] - (case (weave preL preR) - (#//.Alt _) - - - weavedP - (#//.Seq weavedP (weave postL postR))) - - [#//.Pop #//.Pop] - rightP - - (^template [ ] - [(#//.Test ( leftV)) - (#//.Test ( rightV))] - (if ( leftV rightV) - rightP - )) - ([#//.Bool bool/=] - [#//.I64 (:! (Eq I64) i/=)] - [#//.F64 frac/=] - [#//.Text text/=]) - - (^template [ ] - [(#//.Access ( ( leftL))) - (#//.Access ( ( rightL)))] - (if (n/= leftL rightL) - rightP - )) - ([#//.Side #.Left] - [#//.Side #.Right] - [#//.Member #.Left] - [#//.Member #.Right]) - - [(#//.Bind leftR) (#//.Bind rightR)] - (if (n/= leftR rightR) - rightP - ) - - _ - ))) - -(def: #export (synthesize synthesize^ inputA [headB tailB+]) - (-> //.Synthesizer Analysis Match (Operation //.State Synthesis)) - (do ///compiler.Monad - [inputS (synthesize^ inputA)] - (with-expansions [ - (as-is (^multi (^ (#///analysis.Reference (///reference.local outputR))) - (n/= inputR outputR)) - (wrap inputS)) - - - (as-is [[(#///analysis.Bind inputR) headB/bodyA] - #.Nil] - (case headB/bodyA - - - _ - (do @ - [arity //.scope-arity - headB/bodyS (//.with-new-local - (synthesize^ headB/bodyA))] - (wrap (//.branch/let [inputS - (if (//function.nested? arity) - (n/+ (dec arity) inputR) - inputR) - headB/bodyS]))))) - - - (as-is (^or (^ [[(///analysis.pattern/bool true) thenA] - (list [(///analysis.pattern/bool false) elseA])]) - (^ [[(///analysis.pattern/bool false) elseA] - (list [(///analysis.pattern/bool true) thenA])])) - (do @ - [thenS (synthesize^ thenA) - elseS (synthesize^ elseA)] - (wrap (//.branch/if [inputS thenS elseS])))) - - - (as-is _ - (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) - list.reverse - (case> (#.Cons [lastP lastA] prevsPA) - [[lastP lastA] prevsPA] - - _ - (undefined)))] - (do @ - [lastSP (path synthesize^ lastP lastA) - prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] - (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))))] - (case [headB tailB+] - - - )))) diff --git a/stdlib/source/lux/lang/synthesis/expression.lux b/stdlib/source/lux/lang/synthesis/expression.lux deleted file mode 100644 index 52ea33805..000000000 --- a/stdlib/source/lux/lang/synthesis/expression.lux +++ /dev/null @@ -1,99 +0,0 @@ -(.module: - [lux #- primitive] - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [maybe] - (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dict])))) - [///reference] - [///compiler "operation/" Monad] - [///analysis #+ Analysis] - [///extension #+ Extension] - [// #+ Synthesis] - [//function] - [//case]) - -(exception: #export (unknown-synthesis-extension {name Text}) - name) - -(def: (primitive analysis) - (-> ///analysis.Primitive //.Primitive) - (case analysis - #///analysis.Unit - (#//.Text //.unit) - - (^template [ ] - ( value) - ( value)) - ([#///analysis.Bool #//.Bool] - [#///analysis.Frac #//.F64] - [#///analysis.Text #//.Text]) - - (^template [ ] - ( value) - ( (.i64 value))) - ([#///analysis.Nat #//.I64] - [#///analysis.Int #//.I64] - [#///analysis.Deg #//.I64]))) - -(def: #export (synthesizer extensions) - (-> (Extension ///extension.Synthesis) //.Synthesizer) - (function (synthesize analysis) - (case analysis - (#///analysis.Primitive analysis') - (operation/wrap (#//.Primitive (..primitive analysis'))) - - (#///analysis.Structure composite) - (case (///analysis.variant analysis) - (#.Some variant) - (do ///compiler.Monad - [valueS (synthesize (get@ #///analysis.value variant))] - (wrap (#//.Structure (#//.Variant (set@ #///analysis.value valueS variant))))) - - _ - (do ///compiler.Monad - [tupleS (monad.map @ synthesize (///analysis.tuple analysis))] - (wrap (#//.Structure (#//.Tuple tupleS))))) - - (#///analysis.Apply _) - (//function.apply (|>> synthesize //.indirectly) analysis) - - (#///analysis.Function environmentA bodyA) - (//function.function synthesize environmentA bodyA) - - (#///analysis.Extension name args) - (case (dict.get name extensions) - #.None - (///compiler.throw unknown-synthesis-extension name) - - (#.Some extension) - (extension (|>> synthesize //.indirectly) args)) - - (#///analysis.Reference reference) - (case reference - (#///reference.Constant constant) - (operation/wrap (#//.Reference reference)) - - (#///reference.Variable var) - (do ///compiler.Monad - [resolver //.resolver] - (case var - (#///reference.Local register) - (do @ - [arity //.scope-arity] - (wrap (if (//function.nested? arity) - (if (n/= +0 register) - (|> (dec arity) - (list.n/range +1) - (list/map (|>> //.variable/local)) - [(//.variable/local +0)] - //.function/apply) - (#//.Reference (#///reference.Variable (//function.adjust arity false var)))) - (#//.Reference (#///reference.Variable var))))) - - (#///reference.Foreign register) - (wrap (|> resolver (dict.get var) (maybe.default var) #///reference.Variable #//.Reference))))) - - (#///analysis.Case inputA branchesAB+) - (//case.synthesize (|>> synthesize //.indirectly) inputA branchesAB+) - ))) diff --git a/stdlib/source/lux/lang/synthesis/function.lux b/stdlib/source/lux/lang/synthesis/function.lux deleted file mode 100644 index 35b9e047e..000000000 --- a/stdlib/source/lux/lang/synthesis/function.lux +++ /dev/null @@ -1,130 +0,0 @@ -(.module: - [lux #- function] - (lux (control [monad #+ do] - [state] - pipe - ["ex" exception #+ exception:]) - (data [maybe "maybe/" Monad] - [error] - (coll [list "list/" Functor Monoid Fold] - (dictionary ["dict" unordered #+ Dict])))) - [///reference #+ Variable] - [///compiler #+ Operation] - [///analysis #+ Environment Arity Analysis] - [// #+ Synthesis Synthesizer] - [//loop]) - -(def: #export nested? - (-> Arity Bool) - (n/> +1)) - -(def: #export (adjust up-arity after? var) - (-> Arity Bool Variable Variable) - (case var - (#///reference.Local register) - (if (and after? (n/>= up-arity register)) - (#///reference.Local (n/+ (dec up-arity) register)) - var) - - _ - var)) - -(def: (unfold apply) - (-> Analysis [Analysis (List Analysis)]) - (loop [apply apply - args (list)] - (case apply - (#///analysis.Apply arg func) - (recur func (#.Cons arg args)) - - _ - [apply args]))) - -(def: #export (apply synthesize) - (-> Synthesizer Synthesizer) - (.function (_ exprA) - (let [[funcA argsA] (unfold exprA)] - (do (state.Monad error.Monad) - [funcS (synthesize funcA) - argsS (monad.map @ synthesize argsA) - locals //.locals] - (case funcS - (^ (//.function/abstraction functionS)) - (wrap (|> functionS - (//loop.loop (get@ #//.environment functionS) locals argsS) - (maybe.default (//.function/apply [funcS argsS])))) - - (^ (//.function/apply [funcS' argsS'])) - (wrap (//.function/apply [funcS' (list/compose argsS' argsS)])) - - _ - (wrap (//.function/apply [funcS argsS]))))))) - -(def: (prepare up down) - (-> Arity Arity (//loop.Transform Synthesis)) - (.function (_ body) - (if (nested? up) - (#.Some body) - (//loop.recursion down body)))) - -(exception: #export (cannot-prepare-function-body {_ []}) - "") - -(def: return - (All [a] (-> (Maybe a) (Operation //.State a))) - (|>> (case> (#.Some output) - (:: ///compiler.Monad wrap output) - - #.None - (///compiler.throw cannot-prepare-function-body [])))) - -(def: #export (function synthesize environment body) - (-> Synthesizer Environment Analysis (Operation //.State Synthesis)) - (do ///compiler.Monad - [direct? //.direct? - arity //.scope-arity - resolver //.resolver - #let [function-arity (if direct? - (inc arity) - +1) - up-environment (if (nested? arity) - (list/map (.function (_ closure) - (case (dict.get closure resolver) - (#.Some resolved) - (adjust arity true resolved) - - #.None - (adjust arity false closure))) - environment) - environment) - down-environment (: (List Variable) - (case environment - #.Nil - (list) - - _ - (|> (list.size environment) dec (list.n/range +0) - (list/map (|>> #///reference.Foreign))))) - resolver' (if (and (nested? function-arity) - direct?) - (list/fold (.function (_ [from to] resolver') - (dict.put from to resolver')) - //.fresh-resolver - (list.zip2 down-environment up-environment)) - (list/fold (.function (_ var resolver') - (dict.put var var resolver')) - //.fresh-resolver - down-environment))] - bodyS (//.with-abstraction function-arity resolver' - (synthesize body))] - (case bodyS - (^ (//.function/abstraction [env' down-arity' bodyS'])) - (let [arity' (inc down-arity')] - (|> (prepare function-arity arity' bodyS') - (maybe/map (|>> [up-environment arity'] //.function/abstraction)) - ..return)) - - _ - (|> (prepare function-arity +1 bodyS) - (maybe/map (|>> [up-environment +1] //.function/abstraction)) - ..return)))) diff --git a/stdlib/source/lux/lang/synthesis/loop.lux b/stdlib/source/lux/lang/synthesis/loop.lux deleted file mode 100644 index eb57eb7ad..000000000 --- a/stdlib/source/lux/lang/synthesis/loop.lux +++ /dev/null @@ -1,285 +0,0 @@ -(.module: - [lux #- loop] - (lux (control [monad #+ do] - ["p" parser]) - (data [maybe "maybe/" Monad] - (coll [list "list/" Functor])) - (macro [code] - [syntax])) - [///] - [///reference #+ Register Variable] - [///analysis #+ Environment] - [// #+ Path Abstraction Synthesis]) - -(type: #export (Transform a) - (-> a (Maybe a))) - -(def: (some? maybe) - (All [a] (-> (Maybe a) Bool)) - (case maybe - (#.Some _) true - #.None false)) - -(template: #export (self) - (#//.Reference (///reference.local +0))) - -(template: (recursive-apply args) - (#//.Apply (self) args)) - -(def: proper Bool true) -(def: improper Bool false) - -(def: (proper? exprS) - (-> Synthesis Bool) - (case exprS - (^ (self)) - improper - - (#//.Structure structure) - (case structure - (#//.Variant variantS) - (proper? (get@ #///analysis.value variantS)) - - (#//.Tuple membersS+) - (list.every? proper? membersS+)) - - (#//.Control controlS) - (case controlS - (#//.Branch branchS) - (case branchS - (#//.Case inputS pathS) - (and (proper? inputS) - (.loop [pathS pathS] - (case pathS - (^or (#//.Alt leftS rightS) (#//.Seq leftS rightS)) - (and (recur leftS) (recur rightS)) - - (#//.Then bodyS) - (proper? bodyS) - - _ - proper))) - - (#//.Let inputS register bodyS) - (and (proper? inputS) - (proper? bodyS)) - - (#//.If inputS thenS elseS) - (and (proper? inputS) - (proper? thenS) - (proper? elseS))) - - (#//.Loop loopS) - (case loopS - (#//.Scope scopeS) - (and (list.every? proper? (get@ #//.inits scopeS)) - (proper? (get@ #//.iteration scopeS))) - - (#//.Recur argsS) - (list.every? proper? argsS)) - - (#//.Function functionS) - (case functionS - (#//.Abstraction environment arity bodyS) - (list.every? ///reference.self? environment) - - (#//.Apply funcS argsS) - (and (proper? funcS) - (list.every? proper? argsS)))) - - (#//.Extension [name argsS]) - (list.every? proper? argsS) - - _ - proper)) - -(def: (path-recursion synthesis-recursion) - (-> (Transform Synthesis) (Transform Path)) - (function (recur pathS) - (case pathS - (#//.Alt leftS rightS) - (let [leftS' (recur leftS) - rightS' (recur rightS)] - (if (or (some? leftS') - (some? rightS')) - (#.Some (#//.Alt (maybe.default leftS leftS') - (maybe.default rightS rightS'))) - #.None)) - - (#//.Seq leftS rightS) - (maybe/map (|>> (#//.Seq leftS)) (recur rightS)) - - (#//.Then bodyS) - (maybe/map (|>> #//.Then) (synthesis-recursion bodyS)) - - _ - #.None))) - -(def: #export (recursion arity) - (-> Nat (Transform Synthesis)) - (function (recur exprS) - (case exprS - (#//.Control controlS) - (case controlS - (#//.Branch branchS) - (case branchS - (#//.Case inputS pathS) - (|> pathS - (path-recursion recur) - (maybe/map (|>> (#//.Case inputS) #//.Branch #//.Control))) - - (#//.Let inputS register bodyS) - (maybe/map (|>> (#//.Let inputS register) #//.Branch #//.Control) - (recur bodyS)) - - (#//.If inputS thenS elseS) - (let [thenS' (recur thenS) - elseS' (recur elseS)] - (if (or (some? thenS') - (some? elseS')) - (#.Some (|> (#//.If inputS - (maybe.default thenS thenS') - (maybe.default elseS elseS')) - #//.Branch #//.Control)) - #.None))) - - (^ (#//.Function (recursive-apply argsS))) - (if (n/= arity (list.size argsS)) - (#.Some (|> argsS #//.Recur #//.Loop #//.Control)) - #.None) - - _ - #.None) - - _ - #.None))) - -(def: (resolve environment) - (-> Environment (Transform Variable)) - (function (_ variable) - (case variable - (#///reference.Foreign register) - (list.nth register environment) - - _ - (#.Some variable)))) - -(def: (adjust-path adjust-synthesis offset) - (-> (Transform Synthesis) Register (Transform Path)) - (function (recur pathS) - (case pathS - (#//.Bind register) - (#.Some (#//.Bind (n/+ offset register))) - - (^template [] - ( leftS rightS) - (do maybe.Monad - [leftS' (recur leftS) - rightS' (recur rightS)] - (wrap ( leftS' rightS')))) - ([#//.Alt] [#//.Seq]) - - (#//.Then bodyS) - (|> bodyS adjust-synthesis (maybe/map (|>> #//.Then))) - - _ - (#.Some pathS)))) - -(def: (adjust scope-environment offset) - (-> Environment Register (Transform Synthesis)) - (function (recur exprS) - (case exprS - (#//.Structure structureS) - (case structureS - (#//.Variant variantS) - (do maybe.Monad - [valueS' (|> variantS (get@ #///analysis.value) recur)] - (wrap (|> variantS - (set@ #///analysis.value valueS') - #//.Variant - #//.Structure))) - - (#//.Tuple membersS+) - (|> membersS+ - (monad.map maybe.Monad recur) - (maybe/map (|>> #//.Tuple #//.Structure)))) - - (#//.Reference reference) - (case reference - (^ (///reference.constant constant)) - (#.Some exprS) - - (^ (///reference.local register)) - (#.Some (#//.Reference (///reference.local (n/+ offset register)))) - - (^ (///reference.foreign register)) - (|> scope-environment - (list.nth register) - (maybe/map (|>> #///reference.Variable #//.Reference)))) - - (^ (//.branch/case [inputS pathS])) - (do maybe.Monad - [inputS' (recur inputS) - pathS' (adjust-path recur offset pathS)] - (wrap (|> pathS' [inputS'] //.branch/case))) - - (^ (//.branch/let [inputS register bodyS])) - (do maybe.Monad - [inputS' (recur inputS) - bodyS' (recur bodyS)] - (wrap (//.branch/let [inputS' register bodyS']))) - - (^ (//.branch/if [inputS thenS elseS])) - (do maybe.Monad - [inputS' (recur inputS) - thenS' (recur thenS) - elseS' (recur elseS)] - (wrap (//.branch/if [inputS' thenS' elseS']))) - - (^ (//.loop/scope scopeS)) - (do maybe.Monad - [inits' (|> scopeS - (get@ #//.inits) - (monad.map maybe.Monad recur)) - iteration' (recur (get@ #//.iteration scopeS))] - (wrap (//.loop/scope {#//.start (|> scopeS (get@ #//.start) (n/+ offset)) - #//.inits inits' - #//.iteration iteration'}))) - - (^ (//.loop/recur argsS)) - (|> argsS - (monad.map maybe.Monad recur) - (maybe/map (|>> //.loop/recur))) - - - (^ (//.function/abstraction [environment arity bodyS])) - (do maybe.Monad - [environment' (monad.map maybe.Monad - (resolve scope-environment) - environment)] - (wrap (//.function/abstraction [environment' arity bodyS]))) - - (^ (//.function/apply [function arguments])) - (do maybe.Monad - [function' (recur function) - arguments' (monad.map maybe.Monad recur arguments)] - (wrap (//.function/apply [function' arguments']))) - - (#//.Extension [name argsS]) - (|> argsS - (monad.map maybe.Monad recur) - (maybe/map (|>> [name] #//.Extension))) - - _ - (#.Some exprS)))) - -(def: #export (loop environment num-locals inits functionS) - (-> Environment Nat (List Synthesis) Abstraction (Maybe Synthesis)) - (let [bodyS (get@ #//.body functionS)] - (if (and (n/= (list.size inits) - (get@ #//.arity functionS)) - (proper? bodyS)) - (|> bodyS - (adjust environment num-locals) - (maybe/map (|>> [(inc num-locals) inits] //.loop/scope))) - #.None))) diff --git a/stdlib/source/lux/lang/target.lux b/stdlib/source/lux/lang/target.lux deleted file mode 100644 index ee0eee74d..000000000 --- a/stdlib/source/lux/lang/target.lux +++ /dev/null @@ -1,18 +0,0 @@ -(.module: - lux) - -(type: #export Target Text) - -(do-template [ ] - [(def: #export Target )] - - [common-lisp "Common Lisp"] - [js "JavaScript"] - [jvm "JVM"] - [lua "Lua"] - [php "PHP"] - [python "Python"] - [r "R"] - [ruby "Ruby"] - [scheme "Scheme"] - ) diff --git a/stdlib/source/lux/lang/translation.lux b/stdlib/source/lux/lang/translation.lux deleted file mode 100644 index c117bc019..000000000 --- a/stdlib/source/lux/lang/translation.lux +++ /dev/null @@ -1,164 +0,0 @@ -(.module: - lux - (lux (control ["ex" exception #+ exception:] - [monad #+ do]) - (data [maybe "maybe/" Functor] - [error #+ Error] - [text] - text/format - (coll [sequence #+ Sequence] - (dictionary ["dict" unordered #+ Dict]))) - (world [file #+ File])) - [//name] - [//reference #+ Register] - [//compiler #+ Operation Compiler] - [//synthesis #+ Synthesis]) - -(do-template [] - [(exception: #export () - "")] - - [no-active-buffer] - [no-anchor] - ) - -(exception: #export (cannot-interpret {message Text}) - message) - -(type: #export Context - {#scope-name Text - #inner-functions Nat}) - -(sig: #export (Host code) - (: (-> code (Error Any)) - execute!) - (: (-> code (Error Any)) - evaluate!)) - -(type: #export (Buffer code) (Sequence [Ident code])) - -(type: #export (Artifacts code) (Dict File (Buffer code))) - -(type: #export (State anchor code) - {#context Context - #anchor (Maybe anchor) - #host (Host code) - #buffer (Maybe (Buffer code)) - #artifacts (Artifacts code)}) - -(type: #export (Translator anchor code) - (Compiler (State anchor code) Synthesis code)) - -(def: #export (init host) - (All [anchor code] (-> (Host code) (..State anchor code))) - {#context {#scope-name "" - #inner-functions +0} - #anchor #.None - #host host - #buffer #.None - #artifacts (dict.new text.Hash)}) - -(def: #export (with-context expr) - (All [anchor code output] - (-> (Operation (..State anchor code) output) - (Operation (..State anchor code) [Text output]))) - (function (_ state) - (let [[old-scope old-inner] (get@ #context state) - new-scope (format old-scope "c___" (%i (.int old-inner)))] - (case (expr (set@ #context [new-scope +0] state)) - (#error.Success [state' output]) - (#error.Success [(set@ #context [old-scope (inc old-inner)] state') - [new-scope output]]) - - (#error.Error error) - (#error.Error error))))) - -(def: #export context - (All [anchor code] (Operation (..State anchor code) Text)) - (function (_ state) - (#error.Success [state - (|> state - (get@ #context) - (get@ #scope-name))]))) - -(do-template [ - - ] - [(def: #export - (All [anchor code output] ) - (function (_ body) - (function (_ state) - (case (body (set@ (#.Some ) state)) - (#error.Success [state' output]) - (#error.Success [(set@ (get@ state) state') - output]) - - (#error.Error error) - (#error.Error error))))) - - (def: #export - (All [anchor code] (Operation (..State anchor code) )) - (function (_ state) - (case (get@ state) - (#.Some output) - (#error.Success [state output]) - - #.None - (ex.throw []))))] - - [#anchor - (with-anchor anchor) - (-> anchor (Operation (..State anchor code) output) - (Operation (..State anchor code) output)) - anchor - anchor anchor no-anchor] - - [#buffer - with-buffer - (-> (Operation (..State anchor code) output) - (Operation (..State anchor code) output)) - sequence.empty - buffer (Buffer code) no-active-buffer] - ) - -(def: #export artifacts - (All [anchor code] - (Operation (..State anchor code) (Artifacts code))) - (function (_ state) - (#error.Success [state (get@ #artifacts state)]))) - -(do-template [] - [(def: #export ( code) - (All [anchor code] - (-> code (Operation (..State anchor code) Any))) - (function (_ state) - (case (:: (get@ #host state) code) - (#error.Error error) - (ex.throw cannot-interpret error) - - (#error.Success output) - (#error.Success [state output]))))] - - [execute!] - [evaluate!] - ) - -(def: #export (save! name code) - (All [anchor code] - (-> Ident code (Operation (..State anchor code) Any))) - (do //compiler.Monad - [_ (execute! code)] - (function (_ state) - (#error.Success [(update@ #buffer - (maybe/map (sequence.add [name code])) - state) - []])))) - -(def: #export (save-buffer! target) - (All [anchor code] - (-> File (Operation (..State anchor code) Any))) - (do //compiler.Monad - [buffer ..buffer] - (function (_ state) - (#error.Success [(update@ #artifacts (dict.put target buffer) state) - []])))) diff --git a/stdlib/source/lux/lang/translation/scheme/case.jvm.lux b/stdlib/source/lux/lang/translation/scheme/case.jvm.lux deleted file mode 100644 index e5d12a005..000000000 --- a/stdlib/source/lux/lang/translation/scheme/case.jvm.lux +++ /dev/null @@ -1,170 +0,0 @@ -(.module: - [lux #- case let if] - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [number] - [text] - text/format - (coll [list "list/" Functor Fold] - (set ["set" unordered #+ Set])))) - (//// [reference #+ Register] - (host ["_" scheme #+ Expression Computation Var]) - [compiler #+ "operation/" Monad] - [synthesis #+ Synthesis Path]) - [//runtime #+ Operation Translator] - [//reference]) - -(def: #export (let translate [valueS register bodyS]) - (-> Translator [Synthesis Register Synthesis] - (Operation Computation)) - (do compiler.Monad - [valueO (translate valueS) - bodyO (translate bodyS)] - (wrap (_.let (list [(//reference.local' register) valueO]) - bodyO)))) - -(def: #export (record-get translate valueS pathP) - (-> Translator Synthesis (List [Nat Bool]) - (Operation Expression)) - (do compiler.Monad - [valueO (translate valueS)] - (wrap (list/fold (function (_ [idx tail?] source) - (.let [method (.if tail? - //runtime.product//right - //runtime.product//left)] - (method source (_.int (:! Int idx))))) - valueO - pathP)))) - -(def: #export (if translate [testS thenS elseS]) - (-> Translator [Synthesis Synthesis Synthesis] - (Operation Computation)) - (do compiler.Monad - [testO (translate testS) - thenO (translate thenS) - elseO (translate elseS)] - (wrap (_.if testO thenO elseO)))) - -(def: @savepoint (_.var "lux_pm_cursor_savepoint")) - -(def: @cursor (_.var "lux_pm_cursor")) - -(def: top _.length/1) - -(def: (push! value var) - (-> Expression Var Computation) - (_.set! var (_.cons/2 value var))) - -(def: (pop! var) - (-> Var Computation) - (_.set! var var)) - -(def: (push-cursor! value) - (-> Expression Computation) - (push! value @cursor)) - -(def: save-cursor! - Computation - (push! @cursor @savepoint)) - -(def: restore-cursor! - Computation - (_.set! @cursor (_.car/1 @savepoint))) - -(def: cursor-top - Computation - (_.car/1 @cursor)) - -(def: pop-cursor! - Computation - (pop! @cursor)) - -(def: pm-error (_.string "PM-ERROR")) - -(def: fail-pm! (_.raise/1 pm-error)) - -(def: @temp (_.var "lux_pm_temp")) - -(exception: #export (unrecognized-path) - "") - -(def: $alt_error (_.var "alt_error")) - -(def: (pm-catch handler) - (-> Expression Computation) - (_.lambda [(list $alt_error) #.None] - (_.if (|> $alt_error (_.eqv?/2 pm-error)) - handler - (_.raise/1 $alt_error)))) - -(def: (pattern-matching' translate pathP) - (-> Translator Path (Operation Expression)) - (.case pathP - (^ (synthesis.path/then bodyS)) - (translate bodyS) - - #synthesis.Pop - (operation/wrap pop-cursor!) - - (#synthesis.Bind register) - (operation/wrap (_.define (//reference.local' register) [(list) #.None] - cursor-top)) - - (^template [ <=>] - (^ ( value)) - (operation/wrap (_.when (|> value (<=> cursor-top) _.not/1) - fail-pm!))) - ([synthesis.path/bool _.bool _.eqv?/2] - [synthesis.path/i64 _.int _.=/2] - [synthesis.path/f64 _.float _.=/2] - [synthesis.path/text _.string _.eqv?/2]) - - (^template [ ] - (^ ( idx)) - (operation/wrap (_.let (list [@temp (|> idx .int _.int (//runtime.sum//get cursor-top ))]) - (_.if (_.null?/1 @temp) - fail-pm! - (push-cursor! @temp))))) - ([synthesis.side/left _.nil (<|)] - [synthesis.side/right (_.string "") inc]) - - (^template [ ] - (^ ( idx)) - (operation/wrap (|> idx .int _.int ( cursor-top) push-cursor!))) - ([synthesis.member/left //runtime.product//left (<|)] - [synthesis.member/right //runtime.product//right inc]) - - (^template [ ] - (^ ( [leftP rightP])) - (do compiler.Monad - [leftO (pattern-matching' translate leftP) - rightO (pattern-matching' translate rightP)] - (wrap ))) - ([synthesis.path/seq (_.begin (list leftO - rightO))] - [synthesis.path/alt (_.with-exception-handler - (pm-catch (_.begin (list restore-cursor! - rightO))) - (_.lambda [(list) #.None] - (_.begin (list save-cursor! - leftO))))]) - - _ - (compiler.throw unrecognized-path []))) - -(def: (pattern-matching translate pathP) - (-> Translator Path (Operation Computation)) - (do compiler.Monad - [pattern-matching! (pattern-matching' translate pathP)] - (wrap (_.with-exception-handler - (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) - (_.lambda [(list) #.None] - pattern-matching!))))) - -(def: #export (case translate [valueS pathP]) - (-> Translator [Synthesis Path] (Operation Computation)) - (do compiler.Monad - [valueO (translate valueS)] - (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] - [@savepoint (_.list/* (list))]))) - (pattern-matching translate pathP)))) diff --git a/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux b/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux deleted file mode 100644 index 96bb17126..000000000 --- a/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux +++ /dev/null @@ -1,53 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do])) - (//// [compiler] - [synthesis] - [extension]) - [//runtime #+ Translator] - [//primitive] - [//structure] - [//reference] - [//function] - [//case]) - -(def: #export (translate synthesis) - Translator - (case synthesis - (^template [ ] - (^ ( value)) - ( value)) - ([synthesis.bool //primitive.bool] - [synthesis.i64 //primitive.i64] - [synthesis.f64 //primitive.f64] - [synthesis.text //primitive.text]) - - (^ (synthesis.variant variantS)) - (//structure.variant translate variantS) - - (^ (synthesis.tuple members)) - (//structure.tuple translate members) - - (#synthesis.Reference reference) - (//reference.reference reference) - - (^ (synthesis.function/apply application)) - (//function.apply translate application) - - (^ (synthesis.function/abstraction abstraction)) - (//function.function translate abstraction) - - (^ (synthesis.branch/case case)) - (//case.case translate case) - - (^ (synthesis.branch/let let)) - (//case.let translate let) - - (^ (synthesis.branch/if if)) - (//case.if translate if) - - (#synthesis.Extension [extension argsS]) - (do compiler.Monad - [extension (extension.find-translation extension)] - (extension argsS)) - )) diff --git a/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux b/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux deleted file mode 100644 index 6475caf68..000000000 --- a/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux +++ /dev/null @@ -1,32 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [maybe] - text/format - (coll (dictionary ["dict" unordered #+ Dict])))) - (//// [reference #+ Register Variable] - (host ["_" scheme #+ Computation]) - [compiler "operation/" Monad] - [synthesis #+ Synthesis]) - [//runtime #+ Operation Translator] - [/common] - ## [/host] - ) - -(exception: #export (unknown-extension {message Text}) - message) - -(def: extensions - /common.Bundle - (|> /common.extensions - ## (dict.merge /host.extensions) - )) - -(def: #export (extension translate name args) - (-> Translator Text (List Synthesis) - (Operation Computation)) - (<| (maybe.default (compiler.throw unknown-extension (%t name))) - (do maybe.Monad - [ext (dict.get name extensions)] - (wrap (ext translate args))))) diff --git a/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux deleted file mode 100644 index 140045aaf..000000000 --- a/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux +++ /dev/null @@ -1,389 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data ["e" error] - [product] - [text] - text/format - [number #+ hex] - (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dict]))) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (///// (host ["_" scheme #+ Expression Computation]) - [compiler] - [synthesis #+ Synthesis]) - [///runtime #+ Operation Translator]) - -## [Types] -(type: #export Extension - (-> Translator (List Synthesis) (Operation Computation))) - -(type: #export Bundle - (Dict Text Extension)) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector +0 Expression) Computation)) -(type: #export Unary (-> (Vector +1 Expression) Computation)) -(type: #export Binary (-> (Vector +2 Expression) Computation)) -(type: #export Trinary (-> (Vector +3 Expression) Computation)) -(type: #export Variadic (-> (List Expression) Computation)) - -## [Utils] -(def: #export (install name unnamed) - (-> Text (-> Text Extension) - (-> Bundle Bundle)) - (dict.put name (unnamed name))) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict.entries - (list/map (function (_ [key val]) [(format prefix " " key) val])) - (dict.from-list text.Hash))) - -(exception: #export (wrong-arity {extension Text} {expected Nat} {actual Nat}) - (ex.report ["Extension" (%t extension)] - ["Expected" (|> expected .int %i)] - ["Actual" (|> actual .int %i)])) - -(syntax: (arity: {name s.local-symbol} {arity s.nat}) - (with-gensyms [g!_ g!extension g!name g!translate g!inputs] - (do @ - [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!extension)) - (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) - (-> Text ..Extension)) - (function ((~ g!_) (~ g!name)) - (function ((~ g!_) (~ g!translate) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do compiler.Monad - [(~+ (|> g!input+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!translate) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) - - (~' _) - (compiler.throw wrong-arity [(~ g!name) +1 (list.size (~ g!inputs))]))))))))))) - -(arity: nullary +0) -(arity: unary +1) -(arity: binary +2) -(arity: trinary +3) - -(def: #export (variadic extension) - (-> Variadic (-> Text Extension)) - (function (_ extension-name) - (function (_ translate inputsS) - (do compiler.Monad - [inputsI (monad.map @ translate inputsS)] - (wrap (extension inputsI)))))) - -## [Extensions] -## [[Lux]] -(def: extensions/lux - Bundle - (|> (dict.new text.Hash) - (install "is?" (binary (product.uncurry _.eq?/2))) - (install "try" (unary ///runtime.lux//try)))) - -## [[Bits]] -(do-template [ ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [bit//and _.bit-and/2] - [bit//or _.bit-or/2] - [bit//xor _.bit-xor/2] - ) - -(def: (bit//left-shift [subjectO paramO]) - Binary - (_.arithmetic-shift/2 (_.remainder/2 (_.int 64) paramO) - subjectO)) - -(def: (bit//arithmetic-right-shift [subjectO paramO]) - Binary - (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int 64)) (_.*/2 (_.int -1))) - subjectO)) - -(def: (bit//logical-right-shift [subjectO paramO]) - Binary - (///runtime.bit//logical-right-shift (_.remainder/2 (_.int 64) paramO) subjectO)) - -(def: extensions/bit - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash) - (install "and" (binary bit//and)) - (install "or" (binary bit//or)) - (install "xor" (binary bit//xor)) - (install "left-shift" (binary bit//left-shift)) - (install "logical-right-shift" (binary bit//logical-right-shift)) - (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) - ))) - -## [[Arrays]] -(def: (array//new size0) - Unary - (_.make-vector/2 size0 _.nil)) - -(def: (array//get [arrayO idxO]) - Binary - (///runtime.array//get arrayO idxO)) - -(def: (array//put [arrayO idxO elemO]) - Trinary - (///runtime.array//put arrayO idxO elemO)) - -(def: (array//remove [arrayO idxO]) - Binary - (///runtime.array//put arrayO idxO _.nil)) - -(def: extensions/array - Bundle - (<| (prefix "array") - (|> (dict.new text.Hash) - (install "new" (unary array//new)) - (install "get" (binary array//get)) - (install "put" (trinary array//put)) - (install "remove" (binary array//remove)) - (install "size" (unary _.vector-length/1)) - ))) - -## [[Numbers]] -(host.import java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(do-template [ ] - [(def: ( _) - Nullary - ( ))] - - [frac//smallest Double::MIN_VALUE _.float] - [frac//min (f/* -1.0 Double::MAX_VALUE) _.float] - [frac//max Double::MAX_VALUE _.float] - ) - -(do-template [ ] - [(def: ( _) - Nullary - (_.float ))] - - [frac//not-a-number number.not-a-number] - [frac//positive-infinity number.positive-infinity] - [frac//negative-infinity number.negative-infinity] - ) - -(do-template [ ] - [(def: ( [subjectO paramO]) - Binary - (|> subjectO ( paramO)))] - - [int//+ _.+/2] - [int//- _.-/2] - [int//* _.*/2] - [int/// _.quotient/2] - [int//% _.remainder/2] - ) - -(do-template [ ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [frac//+ _.+/2] - [frac//- _.-/2] - [frac//* _.*/2] - [frac/// _.//2] - [frac//% _.mod/2] - [frac//= _.=/2] - [frac//< _. ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [int//= _.=/2] - [int//< _.> _.integer->char/1 _.string/1)) - -(def: extensions/int - Bundle - (<| (prefix "int") - (|> (dict.new text.Hash) - (install "+" (binary int//+)) - (install "-" (binary int//-)) - (install "*" (binary int//*)) - (install "/" (binary int///)) - (install "%" (binary int//%)) - (install "=" (binary int//=)) - (install "<" (binary int//<)) - (install "to-frac" (unary (|>> (_.//2 (_.float 1.0))))) - (install "char" (unary int//char))))) - -(def: extensions/frac - Bundle - (<| (prefix "frac") - (|> (dict.new text.Hash) - (install "+" (binary frac//+)) - (install "-" (binary frac//-)) - (install "*" (binary frac//*)) - (install "/" (binary frac///)) - (install "%" (binary frac//%)) - (install "=" (binary frac//=)) - (install "<" (binary frac//<)) - (install "smallest" (nullary frac//smallest)) - (install "min" (nullary frac//min)) - (install "max" (nullary frac//max)) - (install "not-a-number" (nullary frac//not-a-number)) - (install "positive-infinity" (nullary frac//positive-infinity)) - (install "negative-infinity" (nullary frac//negative-infinity)) - (install "to-int" (unary _.exact/1)) - (install "encode" (unary _.number->string/1)) - (install "decode" (unary ///runtime.frac//decode))))) - -## [[Text]] -(def: (text//char [subjectO paramO]) - Binary - (_.string/1 (_.string-ref/2 subjectO paramO))) - -(def: (text//clip [subjectO startO endO]) - Trinary - (_.substring/3 subjectO startO endO)) - -(def: extensions/text - Bundle - (<| (prefix "text") - (|> (dict.new text.Hash) - (install "=" (binary text//=)) - (install "<" (binary text//<)) - (install "concat" (binary (product.uncurry _.string-append/2))) - (install "size" (unary _.string-length/1)) - (install "char" (binary text//char)) - (install "clip" (trinary text//clip))))) - -## [[Math]] -(def: (math//pow [subject param]) - Binary - (_.expt/2 param subject)) - -(def: math-func - (-> Text Unary) - (|>> _.global _.apply/1)) - -(def: extensions/math - Bundle - (<| (prefix "math") - (|> (dict.new text.Hash) - (install "cos" (unary (math-func "cos"))) - (install "sin" (unary (math-func "sin"))) - (install "tan" (unary (math-func "tan"))) - (install "acos" (unary (math-func "acos"))) - (install "asin" (unary (math-func "asin"))) - (install "atan" (unary (math-func "atan"))) - (install "exp" (unary (math-func "exp"))) - (install "log" (unary (math-func "log"))) - (install "ceil" (unary (math-func "ceiling"))) - (install "floor" (unary (math-func "floor"))) - (install "pow" (binary math//pow)) - ))) - -## [[IO]] -(def: (io//log input) - Unary - (_.begin (list (_.display/1 input) - _.newline/0))) - -(def: (void code) - (-> Expression Computation) - (_.begin (list code (_.string synthesis.unit)))) - -(def: extensions/io - Bundle - (<| (prefix "io") - (|> (dict.new text.Hash) - (install "log" (unary (|>> io//log ..void))) - (install "error" (unary _.raise/1)) - (install "exit" (unary _.exit/1)) - (install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string synthesis.unit)))))))) - -## [[Atoms]] -(def: atom//new - Unary - (|>> (list) _.vector/*)) - -(def: (atom//read atom) - Unary - (_.vector-ref/2 atom (_.int 0))) - -(def: (atom//compare-and-swap [atomO oldO newO]) - Trinary - (///runtime.atom//compare-and-swap atomO oldO newO)) - -(def: extensions/atom - Bundle - (<| (prefix "atom") - (|> (dict.new text.Hash) - (install "new" (unary atom//new)) - (install "read" (unary atom//read)) - (install "compare-and-swap" (trinary atom//compare-and-swap))))) - -## [[Box]] -(def: (box//write [valueO boxO]) - Binary - (///runtime.box//write valueO boxO)) - -(def: extensions/box - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash) - (install "new" (unary atom//new)) - (install "read" (unary atom//read)) - (install "write" (binary box//write))))) - -## [[Processes]] -(def: (process//parallelism-level []) - Nullary - (_.int 1)) - -(def: extensions/process - Bundle - (<| (prefix "process") - (|> (dict.new text.Hash) - (install "parallelism-level" (nullary process//parallelism-level)) - (install "schedule" (binary (product.uncurry ///runtime.process//schedule))) - ))) - -## [Bundles] -(def: #export extensions - Bundle - (<| (prefix "lux") - (|> extensions/lux - (dict.merge extensions/bit) - (dict.merge extensions/int) - (dict.merge extensions/frac) - (dict.merge extensions/text) - (dict.merge extensions/array) - (dict.merge extensions/math) - (dict.merge extensions/io) - (dict.merge extensions/atom) - (dict.merge extensions/box) - (dict.merge extensions/process) - ))) diff --git a/stdlib/source/lux/lang/translation/scheme/function.jvm.lux b/stdlib/source/lux/lang/translation/scheme/function.jvm.lux deleted file mode 100644 index 11c64076c..000000000 --- a/stdlib/source/lux/lang/translation/scheme/function.jvm.lux +++ /dev/null @@ -1,85 +0,0 @@ -(.module: - [lux #- function] - (lux (control [monad #+ do] - pipe) - (data [product] - text/format - (coll [list "list/" Functor]))) - (//// [reference #+ Register Variable] - [name] - [compiler "operation/" Monad] - [analysis #+ Variant Tuple Environment Arity Abstraction Application Analysis] - [synthesis #+ Synthesis] - (host ["_" scheme #+ Expression Computation Var])) - [///] - [//runtime #+ Operation Translator] - [//primitive] - [//reference]) - -(def: #export (apply translate [functionS argsS+]) - (-> Translator (Application Synthesis) (Operation Computation)) - (do compiler.Monad - [functionO (translate functionS) - argsO+ (monad.map @ translate argsS+)] - (wrap (_.apply/* functionO argsO+)))) - -(def: (with-closure function-name inits function-definition) - (-> Text (List Expression) Computation (Operation Computation)) - (let [@closure (_.var (format function-name "___CLOSURE"))] - (operation/wrap - (case inits - #.Nil - function-definition - - _ - (_.letrec (list [@closure - (_.lambda [(|> (list.enumerate inits) - (list/map (|>> product.left //reference.foreign'))) - #.None] - function-definition)]) - (_.apply/* @closure inits)))))) - -(def: @curried (_.var "curried")) -(def: @missing (_.var "missing")) - -(def: input - (|>> inc //reference.local')) - -(def: #export (function translate [environment arity bodyS]) - (-> Translator (Abstraction Synthesis) (Operation Computation)) - (do compiler.Monad - [[function-name bodyO] (///.with-context - (do @ - [function-name ///.context] - (///.with-anchor (_.var function-name) - (translate bodyS)))) - closureO+ (monad.map @ //reference.variable environment) - #let [arityO (|> arity .int _.int) - @num-args (_.var "num_args") - @function (_.var function-name) - apply-poly (.function (_ args func) - (_.apply/2 (_.global "apply") func args))]] - (with-closure function-name closureO+ - (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] - (_.let (list [@num-args (_.length/1 @curried)]) - (<| (_.if (|> @num-args (_.=/2 arityO)) - (<| (_.let (list [(//reference.local' +0) @function])) - (_.let-values (list [[(|> (list.n/range +0 (dec arity)) - (list/map ..input)) - #.None] - (_.apply/2 (_.global "apply") (_.global "values") @curried)])) - bodyO)) - (_.if (|> @num-args (_.>/2 arityO)) - (let [arity-args (//runtime.slice (_.int 0) arityO @curried) - output-func-args (//runtime.slice arityO - (|> @num-args (_.-/2 arityO)) - @curried)] - (|> @function - (apply-poly arity-args) - (apply-poly output-func-args)))) - ## (|> @num-args (_. @function - (apply-poly (_.append/2 @curried @missing)))))))]) - @function)) - )) diff --git a/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux b/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux deleted file mode 100644 index 6f305336e..000000000 --- a/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux #- loop] - (lux (control [monad #+ do]) - (data [product] - [text] - text/format - (coll [list "list/" Functor])) - [macro]) - [////] - (//// [name] - (host ["_" scheme #+ Computation Var]) - [compiler "operation/" Monad] - [synthesis #+ Synthesis]) - [///] - [//runtime #+ Operation Translator] - [//reference]) - -(def: @loop (_.var "loop")) - -(def: #export (loop translate offset initsS+ bodyS) - (-> Translator Nat (List Synthesis) Synthesis - (Operation Computation)) - (do compiler.Monad - [initsO+ (monad.map @ translate initsS+) - bodyO (///.with-anchor @loop - (translate bodyS))] - (wrap (_.letrec (list [@loop (_.lambda [(|> initsS+ - list.enumerate - (list/map (|>> product.left (n/+ offset) //reference.local'))) - #.None] - bodyO)]) - (_.apply/* @loop initsO+))))) - -(def: #export (recur translate argsS+) - (-> Translator (List Synthesis) (Operation Computation)) - (do compiler.Monad - [@loop ///.anchor - argsO+ (monad.map @ translate argsS+)] - (wrap (_.apply/* @loop argsO+)))) diff --git a/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux deleted file mode 100644 index ac775fa82..000000000 --- a/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux +++ /dev/null @@ -1,22 +0,0 @@ -(.module: - [lux #- i64] - [/// #+ State] - (//// [compiler #+ "operation/" Monad] - (host ["_" scheme #+ Expression])) - [//runtime #+ Operation]) - -(def: #export bool - (-> Bool (Operation Expression)) - (|>> _.bool operation/wrap)) - -(def: #export i64 - (-> (I64 Any) (Operation Expression)) - (|>> .int _.int operation/wrap)) - -(def: #export f64 - (-> Frac (Operation Expression)) - (|>> _.float operation/wrap)) - -(def: #export text - (-> Text (Operation Expression)) - (|>> _.string operation/wrap)) diff --git a/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux b/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux deleted file mode 100644 index 453d4edb6..000000000 --- a/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux +++ /dev/null @@ -1,54 +0,0 @@ -(.module: - lux - (lux (control pipe) - (data text/format)) - (//// [reference #+ Register Variable Reference] - [name] - [compiler "operation/" Monad] - [analysis #+ Variant Tuple] - [synthesis #+ Synthesis] - (host ["_" scheme #+ Expression Var])) - [//runtime #+ Operation Translator] - [//primitive]) - -(do-template [ ] - [(def: #export - (-> Register Var) - (|>> .int %i (format ) _.var))] - - [local' "l"] - [foreign' "f"] - ) - -(def: #export variable' - (-> Variable Var) - (|>> (case> (#reference.Local register) - (local' register) - - (#reference.Foreign register) - (foreign' register)))) - -(def: #export variable - (-> Variable (Operation Var)) - (|>> ..variable' - operation/wrap)) - -(def: #export constant' - (-> Ident Var) - (|>> name.definition _.var)) - -(def: #export constant - (-> Ident (Operation Var)) - (|>> constant' operation/wrap)) - -(def: #export reference' - (-> Reference Expression) - (|>> (case> (#reference.Constant value) - (..constant' value) - - (#reference.Variable value) - (..variable' value)))) - -(def: #export reference - (-> Reference (Operation Expression)) - (|>> reference' operation/wrap)) diff --git a/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux deleted file mode 100644 index b30aff3a2..000000000 --- a/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux +++ /dev/null @@ -1,362 +0,0 @@ -(.module: - lux - (lux (control ["p" parser "p/" Monad] - [monad #+ do]) - (data [number #+ hex] - text/format - (coll [list "list/" Monad])) - [function] - (macro [code] - ["s" syntax #+ syntax:])) - [/// #+ State] - (//// [name] - [compiler] - [analysis #+ Variant] - [synthesis] - (host ["_" scheme #+ Expression Computation Var]))) - -(type: #export Operation - (compiler.Operation (State Var Expression))) - -(type: #export Translator - (///.Translator Var Expression)) - -(def: prefix Text "LuxRuntime") - -(def: unit (_.string synthesis.unit)) - -(def: #export variant-tag "lux-variant") - -(def: (flag value) - (-> Bool Computation) - (if value - (_.string "") - _.nil)) - -(def: (variant' tag last? value) - (-> Expression Expression Expression Computation) - (<| (_.cons/2 (_.symbol ..variant-tag)) - (_.cons/2 tag) - (_.cons/2 last?) - value)) - -(def: #export (variant [lefts right? value]) - (-> (Variant Expression) Computation) - (variant' (_.int (.int lefts)) (flag right?) value)) - -(def: #export none - Computation - (variant [+0 false ..unit])) - -(def: #export some - (-> Expression Computation) - (|>> [+0 true] ..variant)) - -(def: #export left - (-> Expression Computation) - (|>> [+0 false] ..variant)) - -(def: #export right - (-> Expression Computation) - (|>> [+0 true] ..variant)) - -(def: declaration - (s.Syntax [Text (List Text)]) - (p.either (p.seq s.local-symbol (p/wrap (list))) - (s.form (p.seq s.local-symbol (p.some s.local-symbol))))) - -(syntax: (runtime: {[name args] declaration} - definition) - (let [implementation (code.local-symbol (format "@@" name)) - runtime (format prefix "__" (name.normalize name)) - @runtime (` (_.var (~ (code.text runtime)))) - argsC+ (list/map code.local-symbol args) - argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`)) - args) - declaration (` ((~ (code.local-symbol name)) - (~+ argsC+))) - type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) - _.Computation))] - (wrap (list (` (def: (~' #export) (~ declaration) - (~ type) - (~ (case argsC+ - #.Nil - @runtime - - _ - (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) - (` (def: (~ implementation) - _.Computation - (~ (case argsC+ - #.Nil - (` (_.define (~ @runtime) [(list) #.None] (~ definition))) - - _ - (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) - (list/map (function (_ [left right]) - (list left right))) - list/join))] - (_.define (~ @runtime) [(list (~+ argsLC+)) #.None] - (~ definition)))))))))))) - -(runtime: (slice offset length list) - (<| (_.if (_.null?/1 list) - list) - (_.if (|> offset (_.>/2 (_.int 0))) - (slice (|> offset (_.-/2 (_.int 1))) - length - (_.cdr/1 list))) - (_.if (|> length (_.>/2 (_.int 0))) - (_.cons/2 (_.car/1 list) - (slice offset - (|> length (_.-/2 (_.int 1))) - (_.cdr/1 list)))) - _.nil)) - -(syntax: #export (with-vars {vars (s.tuple (p.many s.local-symbol))} - body) - (wrap (list (` (let [(~+ (|> vars - (list/map (function (_ var) - (list (code.local-symbol var) - (` (_.var (~ (code.text (format "LRV__" (name.normalize var))))))))) - list/join))] - (~ body)))))) - -(runtime: (lux//try op) - (with-vars [error] - (_.with-exception-handler - (_.lambda [(list error) #.None] - (..left error)) - (_.lambda [(list) #.None] - (..right (_.apply/* op (list ..unit))))))) - -(runtime: (lux//program-args program-args) - (with-vars [@loop @input @output] - (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] - (_.if (_.eqv?/2 _.nil @input) - @output - (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) - (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) - -(def: runtime//lux - Computation - (_.begin (list @@lux//try - @@lux//program-args))) - -(def: minimum-index-length - (-> Expression Computation) - (|>> (_.+/2 (_.int 1)))) - -(def: product-element - (-> Expression Expression Computation) - (function.flip _.vector-ref/2)) - -(def: (product-tail product) - (-> Expression Computation) - (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int 1))))) - -(def: (updated-index min-length product) - (-> Expression Expression Computation) - (|> min-length (_.-/2 (_.length/1 product)))) - -(runtime: (product//left product index) - (let [@index_min_length (_.var "index_min_length")] - (_.begin - (list (_.define @index_min_length [(list) #.None] - (minimum-index-length index)) - (_.if (|> product _.length/1 (_.>/2 @index_min_length)) - ## No need for recursion - (product-element index product) - ## Needs recursion - (product//left (product-tail product) - (updated-index @index_min_length product))))))) - -(runtime: (product//right product index) - (let [@index_min_length (_.var "index_min_length") - @product_length (_.var "product_length") - @slice (_.var "slice") - last-element? (|> @product_length (_.=/2 @index_min_length)) - needs-recursion? (|> @product_length (_. @product_length (_.-/2 index)))) - (_.vector-copy!/5 @slice (_.int 0) product index @product_length) - @slice))))))) - -(runtime: (sum//get sum last? wanted-tag) - (with-vars [variant-tag sum-tag sum-flag sum-value] - (let [no-match _.nil - is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) - test-recursion (_.if is-last? - ## Must recurse. - (sum//get sum-value - (|> wanted-tag (_.-/2 sum-tag)) - last?) - no-match)] - (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None] - (_.apply/* (_.global "apply") (list (_.global "values") sum))])) - (_.if (|> wanted-tag (_.=/2 sum-tag)) - (_.if (|> sum-flag (_.eqv?/2 last?)) - sum-value - test-recursion)) - (_.if (|> wanted-tag (_.>/2 sum-tag)) - test-recursion) - (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) - (|> wanted-tag (_. sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) - no-match)))) - -(def: runtime//adt - Computation - (_.begin (list @@product//left - @@product//right - @@sum//get))) - -(runtime: (bit//logical-right-shift shift input) - (_.if (_.=/2 (_.int 0) shift) - input - (|> input - (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) - (_.bit-and/2 (_.int (hex "7FFFFFFFFFFFFFFF")))))) - -(def: runtime//bit - Computation - (_.begin (list @@bit//logical-right-shift))) - -(runtime: (frac//decode input) - (with-vars [@output] - (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) - (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) - (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) - ..none - (..some @output))))) - -(def: runtime//frac - Computation - (_.begin - (list @@frac//decode))) - -(def: (check-index-out-of-bounds array idx body) - (-> Expression Expression Expression Computation) - (_.if (|> idx (_.<=/2 (_.length/1 array))) - body - (_.raise/1 (_.string "Array index out of bounds!")))) - -(runtime: (array//get array idx) - (with-vars [@temp] - (<| (check-index-out-of-bounds array idx) - (_.let (list [@temp (_.vector-ref/2 array idx)]) - (_.if (|> @temp (_.eqv?/2 _.nil)) - ..none - (..some @temp)))))) - -(runtime: (array//put array idx value) - (<| (check-index-out-of-bounds array idx) - (_.begin - (list (_.vector-set!/3 array idx value) - array)))) - -(def: runtime//array - Computation - (_.begin - (list @@array//get - @@array//put))) - -(runtime: (atom//compare-and-swap atom old new) - (with-vars [@temp] - (_.let (list [@temp (_.vector-ref/2 atom (_.int 0))]) - (_.if (_.eq?/2 old @temp) - (_.begin - (list (_.vector-set!/3 atom (_.int 0) new) - (_.bool true))) - (_.bool false))))) - -(def: runtime//atom - Computation - @@atom//compare-and-swap) - -(runtime: (box//write value box) - (_.begin - (list - (_.vector-set!/3 box (_.int 0) value) - ..unit))) - -(def: runtime//box - Computation - (_.begin (list @@box//write))) - -(runtime: (io//current-time _) - (|> (_.apply/* (_.global "current-second") (list)) - (_.*/2 (_.int 1_000)) - _.exact/1)) - -(def: runtime//io - (_.begin (list @@io//current-time))) - -(def: process//incoming - Var - (_.var (name.normalize "process//incoming"))) - -(runtime: (process//loop _) - (_.when (_.not/1 (_.null?/1 process//incoming)) - (with-vars [queue process] - (_.let (list [queue process//incoming]) - (_.begin (list (_.set! process//incoming (_.list/* (list))) - (_.map/2 (_.lambda [(list process) #.None] - (_.apply/1 process ..unit)) - queue) - (process//loop ..unit))))))) - -(runtime: (process//schedule milli-seconds procedure) - (let [process//future (function (_ process) - (_.set! process//incoming (_.cons/2 process process//incoming)))] - (_.begin - (list - (_.if (_.=/2 (_.int 0) milli-seconds) - (process//future procedure) - (with-vars [@start @process @now @ignored] - (_.let (list [@start (io//current-time ..unit)]) - (_.letrec (list [@process (_.lambda [(list) (#.Some @ignored)] - (_.let (list [@now (io//current-time ..unit)]) - (_.if (|> @now (_.-/2 @start) (_.>=/2 milli-seconds)) - (_.apply/1 procedure ..unit) - (process//future @process))))]) - (process//future @process))))) - ..unit)))) - -(def: runtime//process - Computation - (_.begin (list (_.define process//incoming [(list) #.None] (_.list/* (list))) - @@process//loop - @@process//schedule))) - -(def: runtime - Computation - (_.begin (list @@slice - runtime//lux - runtime//bit - runtime//adt - runtime//frac - runtime//array - runtime//atom - runtime//box - runtime//io - runtime//process - ))) - -(def: #export translate - (Operation Any) - (///.with-buffer - (do compiler.Monad - [_ (///.save! ["" ..prefix] ..runtime)] - (///.save-buffer! "")))) diff --git a/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux b/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux deleted file mode 100644 index a11434594..000000000 --- a/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux +++ /dev/null @@ -1,29 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do])) - (//// [compiler] - [analysis #+ Variant Tuple] - [synthesis #+ Synthesis] - (host ["_" scheme #+ Expression])) - [//runtime #+ Operation Translator] - [//primitive]) - -(def: #export (tuple translate elemsS+) - (-> Translator (Tuple Synthesis) (Operation Expression)) - (case elemsS+ - #.Nil - (//primitive.text synthesis.unit) - - (#.Cons singletonS #.Nil) - (translate singletonS) - - _ - (do compiler.Monad - [elemsT+ (monad.map @ translate elemsS+)] - (wrap (_.vector/* elemsT+))))) - -(def: #export (variant translate [lefts right? valueS]) - (-> Translator (Variant Synthesis) (Operation Expression)) - (do compiler.Monad - [valueT (translate valueS)] - (wrap (//runtime.variant [lefts right? valueT])))) diff --git a/stdlib/test/test/lux/lang/analysis/case.lux b/stdlib/test/test/lux/lang/analysis/case.lux deleted file mode 100644 index 9e775f8a3..000000000 --- a/stdlib/test/test/lux/lang/analysis/case.lux +++ /dev/null @@ -1,194 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "B/" Eq] - ["R" error] - [product] - [maybe] - [text "T/" Eq] - text/format - (coll [list "list/" Monad] - (set ["set" unordered]))) - ["r" math/random "r/" Monad] - [macro #+ Monad] - (macro [code]) - [lang] - (lang [type "type/" Eq] - (type ["tc" check]) - [".L" module] - (analysis [".A" type] - ["/" case])) - test) - (// ["_." primitive] - ["_." structure])) - -(def: (exhaustive-weaving branchings) - (-> (List (List Code)) (List (List Code))) - (case branchings - #.Nil - #.Nil - - (#.Cons head+ #.Nil) - (list/map (|>> list) head+) - - (#.Cons head+ tail++) - (do list.Monad - [tail+ (exhaustive-weaving tail++) - head head+] - (wrap (#.Cons head tail+))))) - -(def: #export (exhaustive-branches allow-literals? variantTC inputC) - (-> Bool (List [Code Code]) Code (r.Random (List Code))) - (case inputC - [_ (#.Bool _)] - (r/wrap (list (' true) (' false))) - - (^template [ ] - [_ ( _)] - (if allow-literals? - (do r.Monad - [?sample (r.maybe )] - (case ?sample - (#.Some sample) - (do @ - [else (exhaustive-branches allow-literals? variantTC inputC)] - (wrap (list& ( sample) else))) - - #.None - (wrap (list (' _))))) - (r/wrap (list (' _))))) - ([#.Nat r.nat code.nat] - [#.Int r.int code.int] - [#.Deg r.deg code.deg] - [#.Frac r.frac code.frac] - [#.Text (r.unicode +5) code.text]) - - (^ [_ (#.Tuple (list))]) - (r/wrap (list (' []))) - - (^ [_ (#.Record (list))]) - (r/wrap (list (' {}))) - - [_ (#.Tuple members)] - (do r.Monad - [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (list/map code.tuple)))) - - [_ (#.Record kvs)] - (do r.Monad - [#let [ks (list/map product.left kvs) - vs (list/map product.right kvs)] - member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (list/map (|>> (list.zip2 ks) code.record))))) - - (^ [_ (#.Form (list [_ (#.Tag _)] _))]) - (do r.Monad - [bundles (monad.map @ - (function (_ [_tag _code]) - (do @ - [v-branches (exhaustive-branches allow-literals? variantTC _code)] - (wrap (list/map (function (_ pattern) (` ((~ _tag) (~ pattern)))) - v-branches)))) - variantTC)] - (wrap (list/join bundles))) - - _ - (r/wrap (list)) - )) - -(def: #export (input variant-tags record-tags primitivesC) - (-> (List Code) (List Code) (List Code) (r.Random Code)) - (r.rec - (function (_ input) - ($_ r.either - (r/map product.right _primitive.primitive) - (do r.Monad - [choice (|> r.nat (:: @ map (n/% (list.size variant-tags)))) - #let [choiceT (maybe.assume (list.nth choice variant-tags)) - choiceC (maybe.assume (list.nth choice primitivesC))]] - (wrap (` ((~ choiceT) (~ choiceC))))) - (do r.Monad - [size (|> r.nat (:: @ map (n/% +3))) - elems (r.list size input)] - (wrap (code.tuple elems))) - (r/wrap (code.record (list.zip2 record-tags primitivesC))) - )))) - -(def: (branch body pattern) - (-> Code Code [Code Code]) - [pattern body]) - -(context: "Pattern-matching." - ## #seed +9253409297339902486 - ## #seed +3793366152923578600 - (<| (seed +5004137551292836565) - ## (times +100) - (do @ - [module-name (r.unicode +5) - variant-name (r.unicode +5) - record-name (|> (r.unicode +5) (r.filter (|>> (T/= variant-name) not))) - size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - variant-tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) - record-tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) - primitivesTC (r.list size _primitive.primitive) - #let [primitivesT (list/map product.left primitivesTC) - primitivesC (list/map product.right primitivesTC) - code-tag (|>> [module-name] code.tag) - variant-tags+ (list/map code-tag variant-tags) - record-tags+ (list/map code-tag record-tags) - variantTC (list.zip2 variant-tags+ primitivesC)] - inputC (input variant-tags+ record-tags+ primitivesC) - [outputT outputC] _primitive.primitive - [heterogeneousT heterogeneousC] (|> _primitive.primitive - (r.filter (|>> product.left (tc.checks? outputT) not))) - exhaustive-patterns (exhaustive-branches true variantTC inputC) - redundant-patterns (exhaustive-branches false variantTC inputC) - redundancy-idx (|> r.nat (:: @ map (n/% (list.size redundant-patterns)))) - heterogeneous-idx (|> r.nat (:: @ map (n/% (list.size exhaustive-patterns)))) - #let [exhaustive-branchesC (list/map (branch outputC) - exhaustive-patterns) - non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC)) - exhaustive-branchesC) - redundant-branchesC (<| (list/map (branch outputC)) - list.concat - (list (list.take redundancy-idx redundant-patterns) - (list (maybe.assume (list.nth redundancy-idx redundant-patterns))) - (list.drop redundancy-idx redundant-patterns))) - heterogeneous-branchesC (list.concat (list (list.take heterogeneous-idx exhaustive-branchesC) - (list (let [[_pattern _body] (maybe.assume (list.nth heterogeneous-idx exhaustive-branchesC))] - [_pattern heterogeneousC])) - (list.drop (inc heterogeneous-idx) exhaustive-branchesC))) - analyse-pm (|>> (/.case _primitive.analyse inputC) - (typeA.with-type outputT) - lang.with-scope - (do Monad - [_ (moduleL.declare-tags variant-tags false - (#.Named [module-name variant-name] - (type.variant primitivesT))) - _ (moduleL.declare-tags record-tags false - (#.Named [module-name record-name] - (type.tuple primitivesT)))]) - (moduleL.with-module +0 module-name))]] - ($_ seq - (test "Will reject empty pattern-matching (no branches)." - (|> (analyse-pm (list)) - _structure.check-fails)) - (test "Can analyse exhaustive pattern-matching." - (|> (analyse-pm exhaustive-branchesC) - _structure.check-succeeds)) - (test "Will reject non-exhaustive pattern-matching." - (|> (analyse-pm non-exhaustive-branchesC) - _structure.check-fails)) - (test "Will reject redundant pattern-matching." - (|> (analyse-pm redundant-branchesC) - _structure.check-fails)) - (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." - (|> (analyse-pm heterogeneous-branchesC) - _structure.check-fails)) - )))) diff --git a/stdlib/test/test/lux/lang/analysis/function.lux b/stdlib/test/test/lux/lang/analysis/function.lux deleted file mode 100644 index a99504045..000000000 --- a/stdlib/test/test/lux/lang/analysis/function.lux +++ /dev/null @@ -1,112 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data ["e" error] - [maybe] - [product] - [text "text/" Eq] - text/format - (coll [list "list/" Functor])) - ["r" math/random "r/" Monad] - [macro] - (macro [code]) - [lang] - (lang [type "type/" Eq] - [".L" init] - [".L" reference] - [".L" analysis #+ Analysis] - (analysis [".A" type] - [".A" expression] - ["/" function])) - test) - (// ["_." primitive] - ["_." structure])) - -(def: analyse (expressionA.analyser (:! lang.Eval []))) - -(def: (check-apply expectedT num-args analysis) - (-> Type Nat (Meta Analysis) Bool) - (|> analysis - (typeA.with-type expectedT) - (macro.run (initL.compiler [])) - (case> (#e.Success applyA) - (let [[funcA argsA] (analysisL.application applyA)] - (n/= num-args (list.size argsA))) - - (#e.Error error) - false))) - -(context: "Function definition." - (<| (times +100) - (do @ - [func-name (r.unicode +5) - arg-name (|> (r.unicode +5) (r.filter (|>> (text/= func-name) not))) - [outputT outputC] _primitive.primitive - [inputT _] _primitive.primitive - #let [g!arg (code.local-symbol arg-name)]] - ($_ seq - (test "Can analyse function." - (and (|> (typeA.with-type (All [a] (-> a outputT)) - (/.function ..analyse func-name arg-name outputC)) - _structure.check-succeeds) - (|> (typeA.with-type (All [a] (-> a a)) - (/.function ..analyse func-name arg-name g!arg)) - _structure.check-succeeds))) - (test "Generic functions can always be specialized." - (and (|> (typeA.with-type (-> inputT outputT) - (/.function ..analyse func-name arg-name outputC)) - _structure.check-succeeds) - (|> (typeA.with-type (-> inputT inputT) - (/.function ..analyse func-name arg-name g!arg)) - _structure.check-succeeds))) - (test "The function's name is bound to the function's type." - (|> (typeA.with-type (Rec self (-> inputT self)) - (/.function ..analyse func-name arg-name (code.local-symbol func-name))) - _structure.check-succeeds)) - )))) - -(context: "Function application." - (<| (times +100) - (do @ - [full-args (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - partial-args (|> r.nat (:: @ map (n/% full-args))) - var-idx (|> r.nat (:: @ map (|>> (n/% full-args) (n/max +1)))) - inputsTC (r.list full-args _primitive.primitive) - #let [inputsT (list/map product.left inputsTC) - inputsC (list/map product.right inputsTC)] - [outputT outputC] _primitive.primitive - #let [funcT (type.function inputsT outputT) - partialT (type.function (list.drop partial-args inputsT) outputT) - varT (#.Bound +1) - polyT (<| (type.univ-q +1) - (type.function (list.concat (list (list.take var-idx inputsT) - (list varT) - (list.drop (inc var-idx) inputsT)))) - varT) - poly-inputT (maybe.assume (list.nth var-idx inputsT)) - partial-poly-inputsT (list.drop (inc var-idx) inputsT) - partial-polyT1 (<| (type.function partial-poly-inputsT) - poly-inputT) - partial-polyT2 (<| (type.univ-q +1) - (type.function (#.Cons varT partial-poly-inputsT)) - varT) - dummy-function (#analysisL.Function (list) (#analysisL.Reference (referenceL.local +1)))]] - ($_ seq - (test "Can analyse monomorphic type application." - (|> (/.apply ..analyse funcT dummy-function inputsC) - (check-apply outputT full-args))) - (test "Can partially apply functions." - (|> (/.apply ..analyse funcT dummy-function (list.take partial-args inputsC)) - (check-apply partialT partial-args))) - (test "Can apply polymorphic functions." - (|> (/.apply ..analyse polyT dummy-function inputsC) - (check-apply poly-inputT full-args))) - (test "Polymorphic partial application propagates found type-vars." - (|> (/.apply ..analyse polyT dummy-function (list.take (inc var-idx) inputsC)) - (check-apply partial-polyT1 (inc var-idx)))) - (test "Polymorphic partial application preserves quantification for type-vars." - (|> (/.apply ..analyse polyT dummy-function (list.take var-idx inputsC)) - (check-apply partial-polyT2 var-idx))) - )))) diff --git a/stdlib/test/test/lux/lang/analysis/primitive.lux b/stdlib/test/test/lux/lang/analysis/primitive.lux deleted file mode 100644 index 6e2a8aae9..000000000 --- a/stdlib/test/test/lux/lang/analysis/primitive.lux +++ /dev/null @@ -1,86 +0,0 @@ -(.module: - [lux #- primitive] - (lux [io] - (control [monad #+ do] - pipe - ["ex" exception #+ exception:]) - (data (text format) - ["e" error]) - ["r" math/random "r/" Monad] - [macro] - (macro [code]) - [lang] - (lang [".L" type "type/" Eq] - [".L" init] - [analysis #+ Analysis] - (analysis [".A" type] - [".A" expression])) - test)) - -(def: #export analyse (expressionA.analyser (:! lang.Eval []))) - -(def: unit - (r.Random Code) - (r/wrap (' []))) - -(def: #export primitive - (r.Random [Type Code]) - (`` ($_ r.either - (~~ (do-template [ ] - [(r.seq (r/wrap ) (r/map ))] - - [Any code.tuple (r.list +0 ..unit)] - [Bool code.bool r.bool] - [Nat code.nat r.nat] - [Int code.int r.int] - [Deg code.deg r.deg] - [Frac code.frac r.frac] - [Text code.text (r.unicode +5)] - ))))) - -(exception: (wrong-inference {expected Type} {inferred Type}) - (ex.report ["Expected" (%type expected)] - ["Inferred" (%type inferred)])) - -(def: (infer-primitive expected-type analysis) - (-> Type (Meta Analysis) (e.Error Analysis)) - (|> (typeA.with-inference - analysis) - (macro.run (initL.compiler [])) - (case> (#e.Success [inferred-type output]) - (if (is? expected-type inferred-type) - (#e.Success output) - (ex.throw wrong-inference [expected-type inferred-type])) - - (#e.Error error) - (#e.Error error)))) - -(context: "Primitives" - ($_ seq - (test "Can analyse unit." - (|> (infer-primitive Any (..analyse (' []))) - (case> (^ (#e.Success (#analysis.Primitive (#analysis.Unit output)))) - (is? [] output) - - _ - false))) - (<| (times +100) - (`` ($_ seq - (~~ (do-template [ ] - [(do @ - [sample ] - (test (format "Can analyse " ".") - (|> (infer-primitive (..analyse ( sample))) - (case> (#e.Success (#analysis.Primitive ( output))) - (is? sample output) - - _ - false))))] - - ["bool" Bool #analysis.Bool r.bool code.bool] - ["nat" Nat #analysis.Nat r.nat code.nat] - ["int" Int #analysis.Int r.int code.int] - ["deg" Deg #analysis.Deg r.deg code.deg] - ["frac" Frac #analysis.Frac r.frac code.frac] - ["text" Text #analysis.Text (r.unicode +5) code.text] - ))))))) diff --git a/stdlib/test/test/lux/lang/analysis/procedure/common.lux b/stdlib/test/test/lux/lang/analysis/procedure/common.lux deleted file mode 100644 index 898376045..000000000 --- a/stdlib/test/test/lux/lang/analysis/procedure/common.lux +++ /dev/null @@ -1,316 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (concurrency [atom]) - (data text/format - ["e" error] - [product] - (coll [array])) - ["r" math/random "r/" Monad] - [macro #+ Monad] - (macro [code]) - [lang] - (lang [type "type/" Eq] - [".L" scope] - [".L" init] - (analysis [".A" type])) - test) - (/// ["_." primitive])) - -(do-template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bool) - (|> (lang.with-scope - (typeA.with-type output-type - (_primitive.analyse (` ((~ (code.text procedure)) (~+ params)))))) - (macro.run (initL.compiler [])) - (case> (#e.Success _) - - - (#e.Error error) - )))] - - [check-success+ true false] - [check-failure+ false true] - ) - -(context: "Lux procedures" - (<| (times +100) - (do @ - [[primT primC] _primitive.primitive - [antiT antiC] (|> _primitive.primitive - (r.filter (|>> product.left (type/= primT) not)))] - ($_ seq - (test "Can test for reference equality." - (check-success+ "lux is" (list primC primC) Bool)) - (test "Reference equality must be done with elements of the same type." - (check-failure+ "lux is" (list primC antiC) Bool)) - (test "Can 'try' risky IO computations." - (check-success+ "lux try" - (list (` ("lux function" (~' _) (~' _) (~ primC)))) - (type (Either Text primT)))) - )))) - -(context: "Bit procedures" - (<| (times +100) - (do @ - [subjectC (|> r.nat (:: @ map code.nat)) - signedC (|> r.int (:: @ map code.int)) - paramC (|> r.nat (:: @ map code.nat))] - ($_ seq - (test "Can perform bit 'and'." - (check-success+ "lux bit and" (list subjectC paramC) Nat)) - (test "Can perform bit 'or'." - (check-success+ "lux bit or" (list subjectC paramC) Nat)) - (test "Can perform bit 'xor'." - (check-success+ "lux bit xor" (list subjectC paramC) Nat)) - (test "Can shift bit pattern to the left." - (check-success+ "lux bit left-shift" (list subjectC paramC) Nat)) - (test "Can shift bit pattern to the right." - (check-success+ "lux bit logical-right-shift" (list subjectC paramC) Nat)) - (test "Can shift signed bit pattern to the right." - (check-success+ "lux bit arithmetic-right-shift" (list signedC paramC) Int)) - )))) - -(context: "Int procedures" - (<| (times +100) - (do @ - [subjectC (|> r.int (:: @ map code.int)) - paramC (|> r.int (:: @ map code.int))] - ($_ seq - (test "Can add integers." - (check-success+ "lux int +" (list subjectC paramC) Int)) - (test "Can subtract integers." - (check-success+ "lux int -" (list subjectC paramC) Int)) - (test "Can multiply integers." - (check-success+ "lux int *" (list subjectC paramC) Int)) - (test "Can divide integers." - (check-success+ "lux int /" (list subjectC paramC) Int)) - (test "Can calculate remainder of integers." - (check-success+ "lux int %" (list subjectC paramC) Int)) - (test "Can test equality of integers." - (check-success+ "lux int =" (list subjectC paramC) Bool)) - (test "Can compare integers." - (check-success+ "lux int <" (list subjectC paramC) Bool)) - (test "Can obtain minimum integer." - (check-success+ "lux int min" (list) Int)) - (test "Can obtain maximum integer." - (check-success+ "lux int max" (list) Int)) - (test "Can convert integer to natural number." - (check-success+ "lux int to-nat" (list subjectC) Nat)) - (test "Can convert integer to frac number." - (check-success+ "lux int to-frac" (list subjectC) Frac)) - (test "Can convert integer to text." - (check-success+ "lux int char" (list subjectC) Text)) - )))) - -(context: "Frac procedures" - (<| (times +100) - (do @ - [subjectC (|> r.frac (:: @ map code.frac)) - paramC (|> r.frac (:: @ map code.frac)) - encodedC (|> (r.unicode +5) (:: @ map code.text))] - ($_ seq - (test "Can add frac numbers." - (check-success+ "lux frac +" (list subjectC paramC) Frac)) - (test "Can subtract frac numbers." - (check-success+ "lux frac -" (list subjectC paramC) Frac)) - (test "Can multiply frac numbers." - (check-success+ "lux frac *" (list subjectC paramC) Frac)) - (test "Can divide frac numbers." - (check-success+ "lux frac /" (list subjectC paramC) Frac)) - (test "Can calculate remainder of frac numbers." - (check-success+ "lux frac %" (list subjectC paramC) Frac)) - (test "Can test equality of frac numbers." - (check-success+ "lux frac =" (list subjectC paramC) Bool)) - (test "Can compare frac numbers." - (check-success+ "lux frac <" (list subjectC paramC) Bool)) - (test "Can obtain minimum frac number." - (check-success+ "lux frac min" (list) Frac)) - (test "Can obtain maximum frac number." - (check-success+ "lux frac max" (list) Frac)) - (test "Can obtain smallest frac number." - (check-success+ "lux frac smallest" (list) Frac)) - (test "Can obtain not-a-number." - (check-success+ "lux frac not-a-number" (list) Frac)) - (test "Can obtain positive infinity." - (check-success+ "lux frac positive-infinity" (list) Frac)) - (test "Can obtain negative infinity." - (check-success+ "lux frac negative-infinity" (list) Frac)) - (test "Can convert frac number to integer." - (check-success+ "lux frac to-int" (list subjectC) Int)) - (test "Can convert frac number to text." - (check-success+ "lux frac encode" (list subjectC) Text)) - (test "Can convert text to frac number." - (check-success+ "lux frac decode" (list encodedC) (type (Maybe Frac)))) - )))) - -(context: "Text procedures" - (<| (times +100) - (do @ - [subjectC (|> (r.unicode +5) (:: @ map code.text)) - paramC (|> (r.unicode +5) (:: @ map code.text)) - replacementC (|> (r.unicode +5) (:: @ map code.text)) - fromC (|> r.nat (:: @ map code.nat)) - toC (|> r.nat (:: @ map code.nat))] - ($_ seq - (test "Can test text equality." - (check-success+ "lux text =" (list subjectC paramC) Bool)) - (test "Compare texts in lexicographical order." - (check-success+ "lux text <" (list subjectC paramC) Bool)) - (test "Can concatenate one text to another." - (check-success+ "lux text concat" (list subjectC paramC) Text)) - (test "Can find the index of a piece of text inside a larger one that (may) contain it." - (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat)))) - (test "Can query the size/length of a text." - (check-success+ "lux text size" (list subjectC) Nat)) - (test "Can calculate a hash code for text." - (check-success+ "lux text hash" (list subjectC) Nat)) - (test "Can replace a text inside of a larger one (once)." - (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text)) - (test "Can replace a text inside of a larger one (all times)." - (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text)) - (test "Can obtain the character code of a text at a given index." - (check-success+ "lux text char" (list subjectC fromC) (type (Maybe Nat)))) - (test "Can clip a piece of text between 2 indices." - (check-success+ "lux text clip" (list subjectC fromC toC) (type (Maybe Text)))) - )))) - -(context: "Array procedures" - (<| (times +100) - (do @ - [[elemT elemC] _primitive.primitive - sizeC (|> r.nat (:: @ map code.nat)) - idxC (|> r.nat (:: @ map code.nat)) - var-name (r.unicode +5) - #let [arrayT (type (Array elemT)) - g!array (code.local-symbol var-name) - array-operation (function (_ output-type code) - (|> (scopeL.with-scope "" - (scopeL.with-local [var-name arrayT] - (typeA.with-type output-type - (_primitive.analyse code)))) - (macro.run (initL.compiler [])) - (case> (#e.Success _) - true - - (#e.Error error) - false)))]] - ($_ seq - (test "Can create arrays." - (check-success+ "lux array new" (list sizeC) arrayT)) - (test "Can get a value inside an array." - (array-operation (type (Maybe elemT)) - (` ("lux array get" (~ g!array) (~ idxC))))) - (test "Can put a value inside an array." - (array-operation arrayT - (` ("lux array put" (~ g!array) (~ idxC) (~ elemC))))) - (test "Can remove a value from an array." - (array-operation arrayT - (` ("lux array remove" (~ g!array) (~ idxC))))) - (test "Can query the size of an array." - (array-operation Nat - (` ("lux array size" (~ g!array))))) - )))) - -(context: "Math procedures" - (<| (times +100) - (do @ - [subjectC (|> r.frac (:: @ map code.frac)) - paramC (|> r.frac (:: @ map code.frac))] - (`` ($_ seq - (~~ (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC) Frac))] - - ["lux math cos" "cosine"] - ["lux math sin" "sine"] - ["lux math tan" "tangent"] - ["lux math acos" "inverse/arc cosine"] - ["lux math asin" "inverse/arc sine"] - ["lux math atan" "inverse/arc tangent"] - ["lux math cosh" "hyperbolic cosine"] - ["lux math sinh" "hyperbolic sine"] - ["lux math tanh" "hyperbolic tangent"] - ["lux math exp" "exponentiation"] - ["lux math log" "logarithm"] - ["lux math ceil" "ceiling"] - ["lux math floor" "floor"] - ["lux math round" "rounding"])) - (~~ (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC paramC) Frac))] - - ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] - ["lux math pow" "power"]))))))) - -(context: "Atom procedures" - (<| (times +100) - (do @ - [[elemT elemC] _primitive.primitive - sizeC (|> r.nat (:: @ map code.nat)) - idxC (|> r.nat (:: @ map code.nat)) - var-name (r.unicode +5) - #let [atomT (type (atom.Atom elemT))]] - ($_ seq - (test "Can create atomic reference." - (check-success+ "lux atom new" (list elemC) atomT)) - (test "Can read the value of an atomic reference." - (|> (scopeL.with-scope "" - (scopeL.with-local [var-name atomT] - (typeA.with-type elemT - (_primitive.analyse (` ("lux atom read" (~ (code.symbol ["" var-name])))))))) - (macro.run (initL.compiler [])) - (case> (#e.Success _) - true - - (#e.Error _) - false))) - (test "Can swap the value of an atomic reference." - (|> (scopeL.with-scope "" - (scopeL.with-local [var-name atomT] - (typeA.with-type Bool - (_primitive.analyse (` ("lux atom compare-and-swap" - (~ (code.symbol ["" var-name])) - (~ elemC) - (~ elemC))))))) - (macro.run (initL.compiler [])) - (case> (#e.Success _) - true - - (#e.Error _) - false))) - )))) - -(context: "Process procedures" - (<| (times +100) - (do @ - [[primT primC] _primitive.primitive - timeC (|> r.nat (:: @ map code.nat))] - ($_ seq - (test "Can query the level of concurrency." - (check-success+ "lux process parallelism-level" (list) Nat)) - (test "Can schedule an IO computation to run concurrently at some future time." - (check-success+ "lux process schedule" - (list timeC - (` ("lux function" (~' _) (~' _) (~ primC)))) - Any)) - )))) - -(context: "IO procedures" - (<| (times +100) - (do @ - [logC (|> (r.unicode +5) (:: @ map code.text)) - exitC (|> r.int (:: @ map code.int))] - ($_ seq - (test "Can log messages to standard output." - (check-success+ "lux io log" (list logC) Any)) - (test "Can throw a run-time error." - (check-success+ "lux io error" (list logC) Nothing)) - (test "Can exit the program." - (check-success+ "lux io exit" (list exitC) Nothing)) - (test "Can query the current time (as milliseconds since epoch)." - (check-success+ "lux io current-time" (list) Int)) - )))) diff --git a/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux b/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux deleted file mode 100644 index 0a60149d5..000000000 --- a/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux +++ /dev/null @@ -1,541 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (concurrency [atom]) - (data ["e" error] - [product] - [maybe] - [text "text/" Eq] - text/format - (coll [array] - [list "list/" Fold] - (dictionary ["dict" unordered]))) - ["r" math/random "r/" Monad] - [macro #+ Monad] - (macro [code]) - [lang] - (lang [type] - [".L" init] - (analysis [".A" type]) - (extension (analysis [".AE" host]))) - test) - (/// ["_." primitive])) - -(do-template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bool) - (|> (do Monad - [## runtime-bytecode @runtime.translate - ] - (lang.with-scope - (typeA.with-type output-type - (_primitive.analyse (` ((~ (code.text procedure)) (~+ params))))))) - (lang.with-current-module "") - (macro.run (initL.compiler [])) - (case> (#e.Success _) - - - (#e.Error error) - )))] - - [success true false] - [failure false true] - ) - -(do-template [ ] - [(def: ( syntax output-type) - (-> Code Type Bool) - (|> (do Monad - [## runtime-bytecode @runtime.translate - ] - (lang.with-scope - (typeA.with-type output-type - (_primitive.analyse syntax)))) - (lang.with-current-module "") - (macro.run (initL.compiler [])) - (case> (#e.Success _) - - - (#e.Error error) - )))] - - [success' true false] - [failure' false true] - ) - -(context: "Conversions [double + float]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert double-to-float" "java.lang.Double" hostAE.Float] - ["jvm convert double-to-int" "java.lang.Double" hostAE.Integer] - ["jvm convert double-to-long" "java.lang.Double" hostAE.Long] - ["jvm convert float-to-double" "java.lang.Float" hostAE.Double] - ["jvm convert float-to-int" "java.lang.Float" hostAE.Integer] - ["jvm convert float-to-long" "java.lang.Float" hostAE.Long] - )] - ($_ seq - - ))) - -(context: "Conversions [int]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert int-to-byte" "java.lang.Integer" hostAE.Byte] - ["jvm convert int-to-char" "java.lang.Integer" hostAE.Character] - ["jvm convert int-to-double" "java.lang.Integer" hostAE.Double] - ["jvm convert int-to-float" "java.lang.Integer" hostAE.Float] - ["jvm convert int-to-long" "java.lang.Integer" hostAE.Long] - ["jvm convert int-to-short" "java.lang.Integer" hostAE.Short] - )] - ($_ seq - - ))) - -(context: "Conversions [long]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert long-to-double" "java.lang.Long" hostAE.Double] - ["jvm convert long-to-float" "java.lang.Long" hostAE.Float] - ["jvm convert long-to-int" "java.lang.Long" hostAE.Integer] - ["jvm convert long-to-short" "java.lang.Long" hostAE.Short] - ["jvm convert long-to-byte" "java.lang.Long" hostAE.Byte] - )] - ($_ seq - - ))) - -(context: "Conversions [char + byte + short]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert char-to-byte" "java.lang.Character" hostAE.Byte] - ["jvm convert char-to-short" "java.lang.Character" hostAE.Short] - ["jvm convert char-to-int" "java.lang.Character" hostAE.Integer] - ["jvm convert char-to-long" "java.lang.Character" hostAE.Long] - ["jvm convert byte-to-long" "java.lang.Byte" hostAE.Long] - ["jvm convert short-to-long" "java.lang.Short" hostAE.Long] - )] - ($_ seq - - ))) - -(do-template [ ] - [(context: (format "Arithmetic " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " +") ] - [(format "jvm " " -") ] - [(format "jvm " " *") ] - [(format "jvm " " /") ] - [(format "jvm " " %") ] - )] - ($_ seq - - ))) - - (context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") hostAE.Boolean] - [(format "jvm " " <") hostAE.Boolean] - )] - ($_ seq - - ))) - - (context: (format "Bitwise " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " and") ] - [(format "jvm " " or") ] - [(format "jvm " " xor") ] - [(format "jvm " " shl") "java.lang.Integer" ] - [(format "jvm " " shr") "java.lang.Integer" ] - [(format "jvm " " ushr") "java.lang.Integer" ] - )] - ($_ seq - - )))] - - - ["int" "java.lang.Integer" hostAE.Integer] - ["long" "java.lang.Long" hostAE.Long] - ) - -(do-template [ ] - [(context: (format "Arithmetic " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " +") ] - [(format "jvm " " -") ] - [(format "jvm " " *") ] - [(format "jvm " " /") ] - [(format "jvm " " %") ] - )] - ($_ seq - - ))) - - (context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") hostAE.Boolean] - [(format "jvm " " <") hostAE.Boolean] - )] - ($_ seq - - )))] - - - ["float" "java.lang.Float" hostAE.Float] - ["double" "java.lang.Double" hostAE.Double] - ) - -(do-template [ ] - [(context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") hostAE.Boolean] - [(format "jvm " " <") hostAE.Boolean] - )] - ($_ seq - - )))] - - - ["char" "java.lang.Character" hostAE.Character] - ) - -(def: array-type - (r.Random [Text Text]) - (let [entries (dict.entries hostAE.boxes) - num-entries (list.size entries)] - (do r.Monad - [choice (|> r.nat (:: @ map (n/% (inc num-entries)))) - #let [[unboxed boxed] (: [Text Text] - (|> entries - (list.nth choice) - (maybe.default ["java.lang.Object" "java.lang.Object"])))]] - (wrap [unboxed boxed])))) - -(context: "Array." - (<| (times +100) - (do @ - [#let [cap (|>> (n/% +10) (n/max +1))] - [unboxed boxed] array-type - size (|> r.nat (:: @ map cap)) - idx (|> r.nat (:: @ map (n/% size))) - level (|> r.nat (:: @ map cap)) - #let [unboxedT (#.Primitive unboxed (list)) - arrayT (#.Primitive "#Array" (list unboxedT)) - arrayC (`' ("lux check" (+0 "#Array" (+1 (+0 (~ (code.text unboxed)) (+0)) (+0))) - ("jvm array new" (~ (code.nat size))))) - boxedT (#.Primitive boxed (list)) - boxedTC (` (+0 (~ (code.text boxed)) (+0))) - multi-arrayT (list/fold (function (_ _ innerT) - (|> innerT (list) (#.Primitive "#Array"))) - boxedT - (list.n/range +1 level))]] - ($_ seq - (test "jvm array new" - (success "jvm array new" - (list (code.nat size)) - arrayT)) - (test "jvm array new (no nesting)" - (failure "jvm array new" - (list (code.nat size)) - unboxedT)) - (test "jvm array new (nested/multi-level)" - (success "jvm array new" - (list (code.nat size)) - multi-arrayT)) - (test "jvm array length" - (success "jvm array length" - (list arrayC) - Nat)) - (test "jvm array read" - (success' (` ("jvm object cast" - ("jvm array read" (~ arrayC) (~ (code.nat idx))))) - boxedT)) - (test "jvm array write" - (success "jvm array write" - (list arrayC (code.nat idx) (`' ("lux coerce" (~ boxedTC) []))) - arrayT)) - )))) - -(def: throwables - (List Text) - (list "java.lang.Throwable" - "java.lang.Error" - "java.io.IOError" - "java.lang.VirtualMachineError" - "java.lang.Exception" - "java.io.IOException" - "java.lang.RuntimeException")) - -(context: "Object." - (<| (times +100) - (do @ - [[unboxed boxed] array-type - [!unboxed !boxed] (|> array-type - (r.filter (function (_ [!unboxed !boxed]) - (not (text/= boxed !boxed))))) - #let [boxedT (#.Primitive boxed (list)) - boxedC (`' ("lux check" (+0 (~ (code.text boxed)) (+0)) - ("jvm object null"))) - !boxedC (`' ("lux check" (+0 (~ (code.text !boxed)) (+0)) - ("jvm object null"))) - unboxedC (`' ("lux check" (+0 (~ (code.text unboxed)) (+0)) - ("jvm object null")))] - throwable (|> r.nat - (:: @ map (n/% (inc (list.size throwables)))) - (:: @ map (function (_ idx) - (|> throwables - (list.nth idx) - (maybe.default "java.lang.Object"))))) - #let [throwableC (`' ("lux check" (+0 (~ (code.text throwable)) (+0)) - ("jvm object null")))]] - ($_ seq - (test "jvm object null" - (success "jvm object null" - (list) - (#.Primitive boxed (list)))) - (test "jvm object null (no primitives)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object null" - (list) - (#.Primitive unboxed (list))))) - (test "jvm object null?" - (success "jvm object null?" - (list boxedC) - Bool)) - (test "jvm object synchronized" - (success "jvm object synchronized" - (list boxedC boxedC) - boxedT)) - (test "jvm object synchronized (no primitives)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object synchronized" - (list unboxedC boxedC) - boxedT))) - (test "jvm object throw" - (or (text/= "java.lang.Object" throwable) - (success "jvm object throw" - (list throwableC) - Nothing))) - (test "jvm object class" - (success "jvm object class" - (list (code.text boxed)) - (#.Primitive "java.lang.Class" (list boxedT)))) - (test "jvm object instance?" - (success "jvm object instance?" - (list (code.text boxed) - boxedC) - Bool)) - (test "jvm object instance? (lineage)" - (success "jvm object instance?" - (list (' "java.lang.Object") - boxedC) - Bool)) - (test "jvm object instance? (no lineage)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object instance?" - (list (code.text boxed) - !boxedC) - Bool))) - )))) - -(context: "Member [Static Field]." - ($_ seq - (test "jvm member static get" - (success "jvm member static get" - (list (code.text "java.lang.System") - (code.text "out")) - (#.Primitive "java.io.PrintStream" (list)))) - (test "jvm member static get (inheritance out)" - (success "jvm member static get" - (list (code.text "java.lang.System") - (code.text "out")) - (#.Primitive "java.lang.Object" (list)))) - (test "jvm member static put" - (success "jvm member static put" - (list (code.text "java.awt.datatransfer.DataFlavor") - (code.text "allHtmlFlavor") - (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0)) - ("jvm object null")))) - Any)) - (test "jvm member static put (final)" - (failure "jvm member static put" - (list (code.text "java.lang.System") - (code.text "out") - (`' ("lux check" (+0 "java.io.PrintStream" (+0)) - ("jvm object null")))) - Any)) - (test "jvm member static put (inheritance in)" - (success "jvm member static put" - (list (code.text "java.awt.datatransfer.DataFlavor") - (code.text "allHtmlFlavor") - (`' ("jvm object cast" - ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) - ("jvm object null"))))) - Any)) - )) - -(context: "Member [Virtual Field]." - ($_ seq - (test "jvm member virtual get" - (success "jvm member virtual get" - (list (code.text "org.omg.CORBA.ValueMember") - (code.text "id") - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (#.Primitive "java.lang.String" (list)))) - (test "jvm member virtual get (inheritance out)" - (success "jvm member virtual get" - (list (code.text "org.omg.CORBA.ValueMember") - (code.text "id") - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (#.Primitive "java.lang.Object" (list)))) - (test "jvm member virtual put" - (success "jvm member virtual put" - (list (code.text "org.omg.CORBA.ValueMember") - (code.text "id") - (`' ("lux check" (+0 "java.lang.String" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (primitive "org.omg.CORBA.ValueMember"))) - (test "jvm member virtual put (final)" - (failure "jvm member virtual put" - (list (code.text "javax.swing.text.html.parser.DTD") - (code.text "applet") - (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0)) - ("jvm object null")))) - (primitive "javax.swing.text.html.parser.DTD"))) - (test "jvm member virtual put (inheritance in)" - (success "jvm member virtual put" - (list (code.text "java.awt.GridBagConstraints") - (code.text "insets") - (`' ("jvm object cast" - ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) - ("jvm object null")))) - (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) - ("jvm object null")))) - (primitive "java.awt.GridBagConstraints"))) - )) - -(context: "Boxing/Unboxing." - ($_ seq - (test "jvm member static get" - (success "jvm member static get" - (list (code.text "java.util.GregorianCalendar") - (code.text "AD")) - (#.Primitive "java.lang.Integer" (list)))) - (test "jvm member virtual get" - (success "jvm member virtual get" - (list (code.text "javax.accessibility.AccessibleAttributeSequence") - (code.text "startIndex") - (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) - ("jvm object null")))) - (#.Primitive "java.lang.Integer" (list)))) - (test "jvm member virtual put" - (success "jvm member virtual put" - (list (code.text "javax.accessibility.AccessibleAttributeSequence") - (code.text "startIndex") - (`' ("jvm object cast" - ("lux check" (+0 "java.lang.Integer" (+0)) - ("jvm object null")))) - (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) - ("jvm object null")))) - (primitive "javax.accessibility.AccessibleAttributeSequence"))) - )) - -(context: "Member [Method]." - (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0)) - +123)) - intC (`' ("jvm convert long-to-int" (~ longC))) - stringC (' ("lux coerce" (+0 "java.lang.String" (+0)) - "YOLO")) - objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0))) - ("jvm member invoke constructor" "java.util.ArrayList" - ["int" ("jvm object cast" (~ intC))])))] - ($_ seq - (test "jvm member invoke static" - (success' (` ("jvm member invoke static" - "java.lang.Long" "decode" - ["java.lang.String" (~ stringC)])) - (#.Primitive "java.lang.Long" (list)))) - (test "jvm member invoke virtual" - (success' (` ("jvm object cast" - ("jvm member invoke virtual" - "java.lang.Object" "equals" - ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) - (#.Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke special" - (success' (` ("jvm object cast" - ("jvm member invoke special" - "java.lang.Long" "equals" - ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) - (#.Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke interface" - (success' (` ("jvm object cast" - ("jvm member invoke interface" - "java.util.Collection" "add" - ("jvm object cast" (~ objectC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) - (#.Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke constructor" - (success' (` ("jvm member invoke constructor" - "java.util.ArrayList" - ["int" ("jvm object cast" (~ intC))])) - (All [a] (#.Primitive "java.util.ArrayList" (list a))))) - ))) diff --git a/stdlib/test/test/lux/lang/analysis/reference.lux b/stdlib/test/test/lux/lang/analysis/reference.lux deleted file mode 100644 index 6551e3cba..000000000 --- a/stdlib/test/test/lux/lang/analysis/reference.lux +++ /dev/null @@ -1,58 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data ["e" error] - [ident "ident/" Eq]) - ["r" math/random] - [macro #+ Monad] - (macro [code]) - [lang] - (lang [type "type/" Eq] - [".L" scope] - [".L" module] - [".L" init] - [".L" reference] - [".L" analysis] - (analysis [".A" type] - [".A" expression])) - test) - (// ["_." primitive])) - -(def: analyse (expressionA.analyser (:! lang.Eval []))) - -(context: "References" - (<| (times +100) - (do @ - [[expectedT _] _primitive.primitive - module-name (r.unicode +5) - scope-name (r.unicode +5) - var-name (r.unicode +5) - #let [def-name [module-name var-name]]] - ($_ seq - (test "Can analyse variable." - (|> (scopeL.with-scope scope-name - (scopeL.with-local [var-name expectedT] - (typeA.with-inference - (..analyse (code.local-symbol var-name))))) - (macro.run (initL.compiler [])) - (case> (^ (#e.Success [inferredT (#analysisL.Reference (referenceL.local var))])) - (and (type/= expectedT inferredT) - (n/= +0 var)) - - _ - false))) - (test "Can analyse definition." - (|> (do Monad - [_ (moduleL.define var-name [expectedT (' {}) []])] - (typeA.with-inference - (..analyse (code.symbol def-name)))) - (moduleL.with-module +0 module-name) - (macro.run (initL.compiler [])) - (case> (^ (#e.Success [_ inferredT (#analysisL.Reference (referenceL.constant constant-name))])) - (and (type/= expectedT inferredT) - (ident/= def-name constant-name)) - - _ - false))))))) diff --git a/stdlib/test/test/lux/lang/analysis/structure.lux b/stdlib/test/test/lux/lang/analysis/structure.lux deleted file mode 100644 index 20b911714..000000000 --- a/stdlib/test/test/lux/lang/analysis/structure.lux +++ /dev/null @@ -1,292 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "bool/" Eq] - ["e" error] - [product] - [maybe] - [text] - text/format - (coll [list "list/" Functor] - (set ["set" unordered]))) - ["r" math/random "r/" Monad] - [macro] - (macro [code]) - [lang] - (lang [type "type/" Eq] - (type ["tc" check]) - [".L" module] - [".L" init] - [".L" analysis #+ Analysis Variant Tag] - (analysis [".A" type] - ["/" structure] - [".A" expression])) - test) - (// ["_." primitive])) - -(def: analyse (expressionA.analyser (:! lang.Eval []))) - -(do-template [ ] - [(def: #export - (All [a] (-> (Meta a) Bool)) - (|>> (macro.run (initL.compiler [])) - (case> (#e.Success _) - - - _ - )))] - - [check-succeeds true false] - [check-fails false true] - ) - -(def: (check-sum' size tag variant) - (-> Nat Tag (Variant Analysis) Bool) - (let [variant-tag (if (get@ #analysisL.right? variant) - (inc (get@ #analysisL.lefts variant)) - (get@ #analysisL.lefts variant))] - (|> size dec (n/= tag) - (bool/= (get@ #analysisL.right? variant)) - (and (n/= tag variant-tag))))) - -(def: (check-sum type size tag analysis) - (-> Type Nat Tag (Meta Analysis) Bool) - (|> analysis - (typeA.with-type type) - (macro.run (initL.compiler [])) - (case> (^multi (#e.Success sumA) - [(analysisL.variant sumA) - (#.Some variant)]) - (check-sum' size tag variant) - - _ - false))) - -(def: (tagged module tags type) - (All [a] (-> Text (List moduleL.Tag) Type (Meta a) (Meta [Module a]))) - (|>> (do macro.Monad - [_ (moduleL.declare-tags tags false type)]) - (moduleL.with-module +0 module))) - -(def: (check-variant module tags type size tag analysis) - (-> Text (List moduleL.Tag) Type Nat Tag (Meta Analysis) Bool) - (|> analysis - (tagged module tags type) - (typeA.with-type type) - (macro.run (initL.compiler [])) - (case> (^multi (#e.Success [_ sumA]) - [(analysisL.variant sumA) - (#.Some variant)]) - (check-sum' size tag variant) - - _ - false))) - -(def: (right-size? size) - (-> Nat (-> Analysis Bool)) - (|>> analysisL.tuple list.size (n/= size))) - -(def: (check-record-inference module tags type size analysis) - (-> Text (List moduleL.Tag) Type Nat (Meta [Type Analysis]) Bool) - (|> analysis - (tagged module tags type) - (macro.run (initL.compiler [])) - (case> (#e.Success [_ productT productA]) - (and (type/= type productT) - (right-size? size productA)) - - _ - false))) - -(context: "Sums" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - choice (|> r.nat (:: @ map (n/% size))) - primitives (r.list size _primitive.primitive) - +choice (|> r.nat (:: @ map (n/% (inc size)))) - [_ +valueC] _primitive.primitive - #let [variantT (type.variant (list/map product.left primitives)) - [valueT valueC] (maybe.assume (list.nth choice primitives)) - +size (inc size) - +primitives (list.concat (list (list.take choice primitives) - (list [(#.Bound +1) +valueC]) - (list.drop choice primitives))) - [+valueT +valueC] (maybe.assume (list.nth +choice +primitives)) - +variantT (type.variant (list/map product.left +primitives))]] - ($_ seq - (test "Can analyse sum." - (check-sum variantT size choice - (/.sum ..analyse choice valueC))) - (test "Can analyse sum through bound type-vars." - (|> (do macro.Monad - [[_ varT] (typeA.with-env tc.var) - _ (typeA.with-env - (tc.check varT variantT))] - (typeA.with-type varT - (/.sum ..analyse choice valueC))) - (macro.run (initL.compiler [])) - (case> (^multi (#e.Success sumA) - [(analysisL.variant sumA) - (#.Some variant)]) - (check-sum' size choice variant) - - _ - false))) - (test "Cannot analyse sum through unbound type-vars." - (|> (do macro.Monad - [[_ varT] (typeA.with-env tc.var)] - (typeA.with-type varT - (/.sum ..analyse choice valueC))) - check-fails)) - (test "Can analyse sum through existential quantification." - (|> (typeA.with-type (type.ex-q +1 +variantT) - (/.sum ..analyse +choice +valueC)) - check-succeeds)) - (test "Can analyse sum through universal quantification." - (let [check-outcome (if (not (n/= choice +choice)) - check-succeeds - check-fails)] - (|> (typeA.with-type (type.univ-q +1 +variantT) - (/.sum ..analyse +choice +valueC)) - check-outcome))) - )))) - -(context: "Products" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - primitives (r.list size _primitive.primitive) - choice (|> r.nat (:: @ map (n/% size))) - [_ +valueC] _primitive.primitive - #let [tupleT (type.tuple (list/map product.left primitives)) - [singletonT singletonC] (|> primitives (list.nth choice) maybe.assume) - +primitives (list.concat (list (list.take choice primitives) - (list [(#.Bound +1) +valueC]) - (list.drop choice primitives))) - +tupleT (type.tuple (list/map product.left +primitives))]] - ($_ seq - (test "Can analyse product." - (|> (typeA.with-type tupleT - (/.product ..analyse (list/map product.right primitives))) - (macro.run (initL.compiler [])) - (case> (#e.Success tupleA) - (right-size? size tupleA) - - _ - false))) - (test "Can infer product." - (|> (typeA.with-inference - (/.product ..analyse (list/map product.right primitives))) - (macro.run (initL.compiler [])) - (case> (#e.Success [_type tupleA]) - (and (type/= tupleT _type) - (right-size? size tupleA)) - - _ - false))) - (test "Can analyse pseudo-product (singleton tuple)" - (|> (typeA.with-type singletonT - (..analyse (` [(~ singletonC)]))) - check-succeeds)) - (test "Can analyse product through bound type-vars." - (|> (do macro.Monad - [[_ varT] (typeA.with-env tc.var) - _ (typeA.with-env - (tc.check varT (type.tuple (list/map product.left primitives))))] - (typeA.with-type varT - (/.product ..analyse (list/map product.right primitives)))) - (macro.run (initL.compiler [])) - (case> (#e.Success tupleA) - (right-size? size tupleA) - - _ - false))) - (test "Can analyse product through existential quantification." - (|> (typeA.with-type (type.ex-q +1 +tupleT) - (/.product ..analyse (list/map product.right +primitives))) - check-succeeds)) - (test "Cannot analyse product through universal quantification." - (|> (typeA.with-type (type.univ-q +1 +tupleT) - (/.product ..analyse (list/map product.right +primitives))) - check-fails)) - )))) - -(context: "Tagged Sums" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) - choice (|> r.nat (:: @ map (n/% size))) - other-choice (|> r.nat (:: @ map (n/% size)) (r.filter (|>> (n/= choice) not))) - primitives (r.list size _primitive.primitive) - module-name (r.unicode +5) - type-name (r.unicode +5) - #let [varT (#.Bound +1) - primitivesT (list/map product.left primitives) - [choiceT choiceC] (maybe.assume (list.nth choice primitives)) - [other-choiceT other-choiceC] (maybe.assume (list.nth other-choice primitives)) - variantT (type.variant primitivesT) - namedT (#.Named [module-name type-name] variantT) - named-polyT (|> (type.variant (list.concat (list (list.take choice primitivesT) - (list varT) - (list.drop (inc choice) primitivesT)))) - (type.univ-q +1) - (#.Named [module-name type-name])) - choice-tag (maybe.assume (list.nth choice tags)) - other-choice-tag (maybe.assume (list.nth other-choice tags))]] - ($_ seq - (test "Can infer tagged sum." - (|> (/.tagged-sum ..analyse [module-name choice-tag] choiceC) - (check-variant module-name tags namedT choice size))) - (test "Tagged sums specialize when type-vars get bound." - (|> (/.tagged-sum ..analyse [module-name choice-tag] choiceC) - (check-variant module-name tags named-polyT choice size))) - (test "Tagged sum inference retains universal quantification when type-vars are not bound." - (|> (/.tagged-sum ..analyse [module-name other-choice-tag] other-choiceC) - (check-variant module-name tags named-polyT other-choice size))) - (test "Can specialize generic tagged sums." - (|> (typeA.with-type variantT - (/.tagged-sum ..analyse [module-name other-choice-tag] other-choiceC)) - (check-variant module-name tags named-polyT other-choice size))) - )))) - -(context: "Records" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) - primitives (r.list size _primitive.primitive) - module-name (r.unicode +5) - type-name (r.unicode +5) - choice (|> r.nat (:: @ map (n/% size))) - #let [varT (#.Bound +1) - tagsC (list/map (|>> [module-name] code.tag) tags) - primitivesT (list/map product.left primitives) - primitivesC (list/map product.right primitives) - tupleT (type.tuple primitivesT) - namedT (#.Named [module-name type-name] tupleT) - recordC (list.zip2 tagsC primitivesC) - named-polyT (|> (type.tuple (list.concat (list (list.take choice primitivesT) - (list varT) - (list.drop (inc choice) primitivesT)))) - (type.univ-q +1) - (#.Named [module-name type-name]))]] - ($_ seq - (test "Can infer record." - (|> (typeA.with-inference - (/.record ..analyse recordC)) - (check-record-inference module-name tags namedT size))) - (test "Records specialize when type-vars get bound." - (|> (typeA.with-inference - (/.record ..analyse recordC)) - (check-record-inference module-name tags named-polyT size))) - (test "Can specialize generic records." - (|> (do macro.Monad - [recordA (typeA.with-type tupleT - (/.record ..analyse recordC))] - (wrap [tupleT recordA])) - (check-record-inference module-name tags named-polyT size))) - )))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/case.lux b/stdlib/test/test/lux/lang/compiler/analysis/case.lux new file mode 100644 index 000000000..d2836558e --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/case.lux @@ -0,0 +1,194 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "B/" Eq] + ["R" error] + [product] + [maybe] + [text "T/" Eq] + text/format + (coll [list "list/" Monad] + (set ["set" unordered]))) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + (lang [type "type/" Eq] + (type ["tc" check]) + [".L" module] + (compiler [analysis] + (analysis [".A" type] + ["/" case]))) + test) + (// ["_." primitive] + ["_." structure])) + +(def: (exhaustive-weaving branchings) + (-> (List (List Code)) (List (List Code))) + (case branchings + #.Nil + #.Nil + + (#.Cons head+ #.Nil) + (list/map (|>> list) head+) + + (#.Cons head+ tail++) + (do list.Monad + [tail+ (exhaustive-weaving tail++) + head head+] + (wrap (#.Cons head tail+))))) + +(def: #export (exhaustive-branches allow-literals? variantTC inputC) + (-> Bool (List [Code Code]) Code (r.Random (List Code))) + (case inputC + [_ (#.Bool _)] + (r/wrap (list (' true) (' false))) + + (^template [ ] + [_ ( _)] + (if allow-literals? + (do r.Monad + [?sample (r.maybe )] + (case ?sample + (#.Some sample) + (do @ + [else (exhaustive-branches allow-literals? variantTC inputC)] + (wrap (list& ( sample) else))) + + #.None + (wrap (list (' _))))) + (r/wrap (list (' _))))) + ([#.Nat r.nat code.nat] + [#.Int r.int code.int] + [#.Deg r.deg code.deg] + [#.Frac r.frac code.frac] + [#.Text (r.unicode +5) code.text]) + + (^ [_ (#.Tuple (list))]) + (r/wrap (list (' []))) + + (^ [_ (#.Record (list))]) + (r/wrap (list (' {}))) + + [_ (#.Tuple members)] + (do r.Monad + [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] + (wrap (|> member-wise-patterns + exhaustive-weaving + (list/map code.tuple)))) + + [_ (#.Record kvs)] + (do r.Monad + [#let [ks (list/map product.left kvs) + vs (list/map product.right kvs)] + member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)] + (wrap (|> member-wise-patterns + exhaustive-weaving + (list/map (|>> (list.zip2 ks) code.record))))) + + (^ [_ (#.Form (list [_ (#.Tag _)] _))]) + (do r.Monad + [bundles (monad.map @ + (function (_ [_tag _code]) + (do @ + [v-branches (exhaustive-branches allow-literals? variantTC _code)] + (wrap (list/map (function (_ pattern) (` ((~ _tag) (~ pattern)))) + v-branches)))) + variantTC)] + (wrap (list/join bundles))) + + _ + (r/wrap (list)) + )) + +(def: #export (input variant-tags record-tags primitivesC) + (-> (List Code) (List Code) (List Code) (r.Random Code)) + (r.rec + (function (_ input) + ($_ r.either + (r/map product.right _primitive.primitive) + (do r.Monad + [choice (|> r.nat (:: @ map (n/% (list.size variant-tags)))) + #let [choiceT (maybe.assume (list.nth choice variant-tags)) + choiceC (maybe.assume (list.nth choice primitivesC))]] + (wrap (` ((~ choiceT) (~ choiceC))))) + (do r.Monad + [size (|> r.nat (:: @ map (n/% +3))) + elems (r.list size input)] + (wrap (code.tuple elems))) + (r/wrap (code.record (list.zip2 record-tags primitivesC))) + )))) + +(def: (branch body pattern) + (-> Code Code [Code Code]) + [pattern body]) + +(context: "Pattern-matching." + ## #seed +9253409297339902486 + ## #seed +3793366152923578600 + (<| (seed +5004137551292836565) + ## (times +100) + (do @ + [module-name (r.unicode +5) + variant-name (r.unicode +5) + record-name (|> (r.unicode +5) (r.filter (|>> (T/= variant-name) not))) + size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + variant-tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) + record-tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) + primitivesTC (r.list size _primitive.primitive) + #let [primitivesT (list/map product.left primitivesTC) + primitivesC (list/map product.right primitivesTC) + code-tag (|>> [module-name] code.tag) + variant-tags+ (list/map code-tag variant-tags) + record-tags+ (list/map code-tag record-tags) + variantTC (list.zip2 variant-tags+ primitivesC)] + inputC (input variant-tags+ record-tags+ primitivesC) + [outputT outputC] _primitive.primitive + [heterogeneousT heterogeneousC] (r.filter (|>> product.left (tc.checks? outputT) not) + _primitive.primitive) + exhaustive-patterns (exhaustive-branches true variantTC inputC) + redundant-patterns (exhaustive-branches false variantTC inputC) + redundancy-idx (|> r.nat (:: @ map (n/% (list.size redundant-patterns)))) + heterogeneous-idx (|> r.nat (:: @ map (n/% (list.size exhaustive-patterns)))) + #let [exhaustive-branchesC (list/map (branch outputC) + exhaustive-patterns) + non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC)) + exhaustive-branchesC) + redundant-branchesC (<| (list/map (branch outputC)) + list.concat + (list (list.take redundancy-idx redundant-patterns) + (list (maybe.assume (list.nth redundancy-idx redundant-patterns))) + (list.drop redundancy-idx redundant-patterns))) + heterogeneous-branchesC (list.concat (list (list.take heterogeneous-idx exhaustive-branchesC) + (list (let [[_pattern _body] (maybe.assume (list.nth heterogeneous-idx exhaustive-branchesC))] + [_pattern heterogeneousC])) + (list.drop (inc heterogeneous-idx) exhaustive-branchesC))) + analyse-pm (|>> (/.case _primitive.analyse inputC) + (typeA.with-type outputT) + analysis.with-scope + (do Monad + [_ (moduleL.declare-tags variant-tags false + (#.Named [module-name variant-name] + (type.variant primitivesT))) + _ (moduleL.declare-tags record-tags false + (#.Named [module-name record-name] + (type.tuple primitivesT)))]) + (moduleL.with-module +0 module-name))]] + ($_ seq + (test "Will reject empty pattern-matching (no branches)." + (|> (analyse-pm (list)) + _structure.check-fails)) + (test "Can analyse exhaustive pattern-matching." + (|> (analyse-pm exhaustive-branchesC) + _structure.check-succeeds)) + (test "Will reject non-exhaustive pattern-matching." + (|> (analyse-pm non-exhaustive-branchesC) + _structure.check-fails)) + (test "Will reject redundant pattern-matching." + (|> (analyse-pm redundant-branchesC) + _structure.check-fails)) + (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." + (|> (analyse-pm heterogeneous-branchesC) + _structure.check-fails))) + ))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/function.lux b/stdlib/test/test/lux/lang/compiler/analysis/function.lux new file mode 100644 index 000000000..147cbcc9e --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/function.lux @@ -0,0 +1,112 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error] + [maybe] + [product] + [text "text/" Eq] + text/format + (coll [list "list/" Functor])) + ["r" math/random "r/" Monad] + [macro] + (macro [code]) + [lang] + (lang [type "type/" Eq] + [".L" reference] + (compiler [".L" init] + [".L" analysis #+ Analysis] + (analysis [".A" type] + [".A" expression] + ["/" function]))) + test) + (// ["_." primitive] + ["_." structure])) + +(def: analyse (expressionA.analyser (:! lang.Eval []))) + +(def: (check-apply expectedT num-args analysis) + (-> Type Nat (Meta Analysis) Bool) + (|> analysis + (typeA.with-type expectedT) + (macro.run (initL.compiler [])) + (case> (#e.Success applyA) + (let [[funcA argsA] (analysisL.application applyA)] + (n/= num-args (list.size argsA))) + + (#e.Error error) + false))) + +(context: "Function definition." + (<| (times +100) + (do @ + [func-name (r.unicode +5) + arg-name (|> (r.unicode +5) (r.filter (|>> (text/= func-name) not))) + [outputT outputC] _primitive.primitive + [inputT _] _primitive.primitive + #let [g!arg (code.local-symbol arg-name)]] + ($_ seq + (test "Can analyse function." + (and (|> (typeA.with-type (All [a] (-> a outputT)) + (/.function ..analyse func-name arg-name outputC)) + _structure.check-succeeds) + (|> (typeA.with-type (All [a] (-> a a)) + (/.function ..analyse func-name arg-name g!arg)) + _structure.check-succeeds))) + (test "Generic functions can always be specialized." + (and (|> (typeA.with-type (-> inputT outputT) + (/.function ..analyse func-name arg-name outputC)) + _structure.check-succeeds) + (|> (typeA.with-type (-> inputT inputT) + (/.function ..analyse func-name arg-name g!arg)) + _structure.check-succeeds))) + (test "The function's name is bound to the function's type." + (|> (typeA.with-type (Rec self (-> inputT self)) + (/.function ..analyse func-name arg-name (code.local-symbol func-name))) + _structure.check-succeeds)) + )))) + +(context: "Function application." + (<| (times +100) + (do @ + [full-args (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + partial-args (|> r.nat (:: @ map (n/% full-args))) + var-idx (|> r.nat (:: @ map (|>> (n/% full-args) (n/max +1)))) + inputsTC (r.list full-args _primitive.primitive) + #let [inputsT (list/map product.left inputsTC) + inputsC (list/map product.right inputsTC)] + [outputT outputC] _primitive.primitive + #let [funcT (type.function inputsT outputT) + partialT (type.function (list.drop partial-args inputsT) outputT) + varT (#.Bound +1) + polyT (<| (type.univ-q +1) + (type.function (list.concat (list (list.take var-idx inputsT) + (list varT) + (list.drop (inc var-idx) inputsT)))) + varT) + poly-inputT (maybe.assume (list.nth var-idx inputsT)) + partial-poly-inputsT (list.drop (inc var-idx) inputsT) + partial-polyT1 (<| (type.function partial-poly-inputsT) + poly-inputT) + partial-polyT2 (<| (type.univ-q +1) + (type.function (#.Cons varT partial-poly-inputsT)) + varT) + dummy-function (#analysisL.Function (list) (#analysisL.Reference (referenceL.local +1)))]] + ($_ seq + (test "Can analyse monomorphic type application." + (|> (/.apply ..analyse funcT dummy-function inputsC) + (check-apply outputT full-args))) + (test "Can partially apply functions." + (|> (/.apply ..analyse funcT dummy-function (list.take partial-args inputsC)) + (check-apply partialT partial-args))) + (test "Can apply polymorphic functions." + (|> (/.apply ..analyse polyT dummy-function inputsC) + (check-apply poly-inputT full-args))) + (test "Polymorphic partial application propagates found type-vars." + (|> (/.apply ..analyse polyT dummy-function (list.take (inc var-idx) inputsC)) + (check-apply partial-polyT1 (inc var-idx)))) + (test "Polymorphic partial application preserves quantification for type-vars." + (|> (/.apply ..analyse polyT dummy-function (list.take var-idx inputsC)) + (check-apply partial-polyT2 var-idx))) + )))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/primitive.lux b/stdlib/test/test/lux/lang/compiler/analysis/primitive.lux new file mode 100644 index 000000000..18b8f6c46 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/primitive.lux @@ -0,0 +1,86 @@ +(.module: + [lux #- primitive] + (lux [io] + (control [monad #+ do] + pipe + ["ex" exception #+ exception:]) + (data (text format) + ["e" error]) + ["r" math/random "r/" Monad] + [macro] + (macro [code]) + [lang] + (lang [".L" type "type/" Eq] + (compiler [".L" init] + [analysis #+ Analysis] + (analysis [".A" type] + [".A" expression]))) + test)) + +(def: #export analyse (expressionA.analyser (:! lang.Eval []))) + +(def: unit + (r.Random Code) + (r/wrap (' []))) + +(def: #export primitive + (r.Random [Type Code]) + (`` ($_ r.either + (~~ (do-template [ ] + [(r.seq (r/wrap ) (r/map ))] + + [Any code.tuple (r.list +0 ..unit)] + [Bool code.bool r.bool] + [Nat code.nat r.nat] + [Int code.int r.int] + [Deg code.deg r.deg] + [Frac code.frac r.frac] + [Text code.text (r.unicode +5)] + ))))) + +(exception: (wrong-inference {expected Type} {inferred Type}) + (ex.report ["Expected" (%type expected)] + ["Inferred" (%type inferred)])) + +(def: (infer-primitive expected-type analysis) + (-> Type (Meta Analysis) (e.Error Analysis)) + (|> (typeA.with-inference + analysis) + (macro.run (initL.compiler [])) + (case> (#e.Success [inferred-type output]) + (if (is? expected-type inferred-type) + (#e.Success output) + (ex.throw wrong-inference [expected-type inferred-type])) + + (#e.Error error) + (#e.Error error)))) + +(context: "Primitives" + ($_ seq + (test "Can analyse unit." + (|> (infer-primitive Any (..analyse (' []))) + (case> (^ (#e.Success (#analysis.Primitive (#analysis.Unit output)))) + (is? [] output) + + _ + false))) + (<| (times +100) + (`` ($_ seq + (~~ (do-template [ ] + [(do @ + [sample ] + (test (format "Can analyse " ".") + (|> (infer-primitive (..analyse ( sample))) + (case> (#e.Success (#analysis.Primitive ( output))) + (is? sample output) + + _ + false))))] + + ["bool" Bool #analysis.Bool r.bool code.bool] + ["nat" Nat #analysis.Nat r.nat code.nat] + ["int" Int #analysis.Int r.int code.int] + ["deg" Deg #analysis.Deg r.deg code.deg] + ["frac" Frac #analysis.Frac r.frac code.frac] + ["text" Text #analysis.Text (r.unicode +5) code.text] + ))))))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux b/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux new file mode 100644 index 000000000..898376045 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux @@ -0,0 +1,316 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data text/format + ["e" error] + [product] + (coll [array])) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + [lang] + (lang [type "type/" Eq] + [".L" scope] + [".L" init] + (analysis [".A" type])) + test) + (/// ["_." primitive])) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (lang.with-scope + (typeA.with-type output-type + (_primitive.analyse (` ((~ (code.text procedure)) (~+ params)))))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [check-success+ true false] + [check-failure+ false true] + ) + +(context: "Lux procedures" + (<| (times +100) + (do @ + [[primT primC] _primitive.primitive + [antiT antiC] (|> _primitive.primitive + (r.filter (|>> product.left (type/= primT) not)))] + ($_ seq + (test "Can test for reference equality." + (check-success+ "lux is" (list primC primC) Bool)) + (test "Reference equality must be done with elements of the same type." + (check-failure+ "lux is" (list primC antiC) Bool)) + (test "Can 'try' risky IO computations." + (check-success+ "lux try" + (list (` ("lux function" (~' _) (~' _) (~ primC)))) + (type (Either Text primT)))) + )))) + +(context: "Bit procedures" + (<| (times +100) + (do @ + [subjectC (|> r.nat (:: @ map code.nat)) + signedC (|> r.int (:: @ map code.int)) + paramC (|> r.nat (:: @ map code.nat))] + ($_ seq + (test "Can perform bit 'and'." + (check-success+ "lux bit and" (list subjectC paramC) Nat)) + (test "Can perform bit 'or'." + (check-success+ "lux bit or" (list subjectC paramC) Nat)) + (test "Can perform bit 'xor'." + (check-success+ "lux bit xor" (list subjectC paramC) Nat)) + (test "Can shift bit pattern to the left." + (check-success+ "lux bit left-shift" (list subjectC paramC) Nat)) + (test "Can shift bit pattern to the right." + (check-success+ "lux bit logical-right-shift" (list subjectC paramC) Nat)) + (test "Can shift signed bit pattern to the right." + (check-success+ "lux bit arithmetic-right-shift" (list signedC paramC) Int)) + )))) + +(context: "Int procedures" + (<| (times +100) + (do @ + [subjectC (|> r.int (:: @ map code.int)) + paramC (|> r.int (:: @ map code.int))] + ($_ seq + (test "Can add integers." + (check-success+ "lux int +" (list subjectC paramC) Int)) + (test "Can subtract integers." + (check-success+ "lux int -" (list subjectC paramC) Int)) + (test "Can multiply integers." + (check-success+ "lux int *" (list subjectC paramC) Int)) + (test "Can divide integers." + (check-success+ "lux int /" (list subjectC paramC) Int)) + (test "Can calculate remainder of integers." + (check-success+ "lux int %" (list subjectC paramC) Int)) + (test "Can test equality of integers." + (check-success+ "lux int =" (list subjectC paramC) Bool)) + (test "Can compare integers." + (check-success+ "lux int <" (list subjectC paramC) Bool)) + (test "Can obtain minimum integer." + (check-success+ "lux int min" (list) Int)) + (test "Can obtain maximum integer." + (check-success+ "lux int max" (list) Int)) + (test "Can convert integer to natural number." + (check-success+ "lux int to-nat" (list subjectC) Nat)) + (test "Can convert integer to frac number." + (check-success+ "lux int to-frac" (list subjectC) Frac)) + (test "Can convert integer to text." + (check-success+ "lux int char" (list subjectC) Text)) + )))) + +(context: "Frac procedures" + (<| (times +100) + (do @ + [subjectC (|> r.frac (:: @ map code.frac)) + paramC (|> r.frac (:: @ map code.frac)) + encodedC (|> (r.unicode +5) (:: @ map code.text))] + ($_ seq + (test "Can add frac numbers." + (check-success+ "lux frac +" (list subjectC paramC) Frac)) + (test "Can subtract frac numbers." + (check-success+ "lux frac -" (list subjectC paramC) Frac)) + (test "Can multiply frac numbers." + (check-success+ "lux frac *" (list subjectC paramC) Frac)) + (test "Can divide frac numbers." + (check-success+ "lux frac /" (list subjectC paramC) Frac)) + (test "Can calculate remainder of frac numbers." + (check-success+ "lux frac %" (list subjectC paramC) Frac)) + (test "Can test equality of frac numbers." + (check-success+ "lux frac =" (list subjectC paramC) Bool)) + (test "Can compare frac numbers." + (check-success+ "lux frac <" (list subjectC paramC) Bool)) + (test "Can obtain minimum frac number." + (check-success+ "lux frac min" (list) Frac)) + (test "Can obtain maximum frac number." + (check-success+ "lux frac max" (list) Frac)) + (test "Can obtain smallest frac number." + (check-success+ "lux frac smallest" (list) Frac)) + (test "Can obtain not-a-number." + (check-success+ "lux frac not-a-number" (list) Frac)) + (test "Can obtain positive infinity." + (check-success+ "lux frac positive-infinity" (list) Frac)) + (test "Can obtain negative infinity." + (check-success+ "lux frac negative-infinity" (list) Frac)) + (test "Can convert frac number to integer." + (check-success+ "lux frac to-int" (list subjectC) Int)) + (test "Can convert frac number to text." + (check-success+ "lux frac encode" (list subjectC) Text)) + (test "Can convert text to frac number." + (check-success+ "lux frac decode" (list encodedC) (type (Maybe Frac)))) + )))) + +(context: "Text procedures" + (<| (times +100) + (do @ + [subjectC (|> (r.unicode +5) (:: @ map code.text)) + paramC (|> (r.unicode +5) (:: @ map code.text)) + replacementC (|> (r.unicode +5) (:: @ map code.text)) + fromC (|> r.nat (:: @ map code.nat)) + toC (|> r.nat (:: @ map code.nat))] + ($_ seq + (test "Can test text equality." + (check-success+ "lux text =" (list subjectC paramC) Bool)) + (test "Compare texts in lexicographical order." + (check-success+ "lux text <" (list subjectC paramC) Bool)) + (test "Can concatenate one text to another." + (check-success+ "lux text concat" (list subjectC paramC) Text)) + (test "Can find the index of a piece of text inside a larger one that (may) contain it." + (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat)))) + (test "Can query the size/length of a text." + (check-success+ "lux text size" (list subjectC) Nat)) + (test "Can calculate a hash code for text." + (check-success+ "lux text hash" (list subjectC) Nat)) + (test "Can replace a text inside of a larger one (once)." + (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text)) + (test "Can replace a text inside of a larger one (all times)." + (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text)) + (test "Can obtain the character code of a text at a given index." + (check-success+ "lux text char" (list subjectC fromC) (type (Maybe Nat)))) + (test "Can clip a piece of text between 2 indices." + (check-success+ "lux text clip" (list subjectC fromC toC) (type (Maybe Text)))) + )))) + +(context: "Array procedures" + (<| (times +100) + (do @ + [[elemT elemC] _primitive.primitive + sizeC (|> r.nat (:: @ map code.nat)) + idxC (|> r.nat (:: @ map code.nat)) + var-name (r.unicode +5) + #let [arrayT (type (Array elemT)) + g!array (code.local-symbol var-name) + array-operation (function (_ output-type code) + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name arrayT] + (typeA.with-type output-type + (_primitive.analyse code)))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + true + + (#e.Error error) + false)))]] + ($_ seq + (test "Can create arrays." + (check-success+ "lux array new" (list sizeC) arrayT)) + (test "Can get a value inside an array." + (array-operation (type (Maybe elemT)) + (` ("lux array get" (~ g!array) (~ idxC))))) + (test "Can put a value inside an array." + (array-operation arrayT + (` ("lux array put" (~ g!array) (~ idxC) (~ elemC))))) + (test "Can remove a value from an array." + (array-operation arrayT + (` ("lux array remove" (~ g!array) (~ idxC))))) + (test "Can query the size of an array." + (array-operation Nat + (` ("lux array size" (~ g!array))))) + )))) + +(context: "Math procedures" + (<| (times +100) + (do @ + [subjectC (|> r.frac (:: @ map code.frac)) + paramC (|> r.frac (:: @ map code.frac))] + (`` ($_ seq + (~~ (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC) Frac))] + + ["lux math cos" "cosine"] + ["lux math sin" "sine"] + ["lux math tan" "tangent"] + ["lux math acos" "inverse/arc cosine"] + ["lux math asin" "inverse/arc sine"] + ["lux math atan" "inverse/arc tangent"] + ["lux math cosh" "hyperbolic cosine"] + ["lux math sinh" "hyperbolic sine"] + ["lux math tanh" "hyperbolic tangent"] + ["lux math exp" "exponentiation"] + ["lux math log" "logarithm"] + ["lux math ceil" "ceiling"] + ["lux math floor" "floor"] + ["lux math round" "rounding"])) + (~~ (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC paramC) Frac))] + + ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] + ["lux math pow" "power"]))))))) + +(context: "Atom procedures" + (<| (times +100) + (do @ + [[elemT elemC] _primitive.primitive + sizeC (|> r.nat (:: @ map code.nat)) + idxC (|> r.nat (:: @ map code.nat)) + var-name (r.unicode +5) + #let [atomT (type (atom.Atom elemT))]] + ($_ seq + (test "Can create atomic reference." + (check-success+ "lux atom new" (list elemC) atomT)) + (test "Can read the value of an atomic reference." + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name atomT] + (typeA.with-type elemT + (_primitive.analyse (` ("lux atom read" (~ (code.symbol ["" var-name])))))))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + true + + (#e.Error _) + false))) + (test "Can swap the value of an atomic reference." + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name atomT] + (typeA.with-type Bool + (_primitive.analyse (` ("lux atom compare-and-swap" + (~ (code.symbol ["" var-name])) + (~ elemC) + (~ elemC))))))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + true + + (#e.Error _) + false))) + )))) + +(context: "Process procedures" + (<| (times +100) + (do @ + [[primT primC] _primitive.primitive + timeC (|> r.nat (:: @ map code.nat))] + ($_ seq + (test "Can query the level of concurrency." + (check-success+ "lux process parallelism-level" (list) Nat)) + (test "Can schedule an IO computation to run concurrently at some future time." + (check-success+ "lux process schedule" + (list timeC + (` ("lux function" (~' _) (~' _) (~ primC)))) + Any)) + )))) + +(context: "IO procedures" + (<| (times +100) + (do @ + [logC (|> (r.unicode +5) (:: @ map code.text)) + exitC (|> r.int (:: @ map code.int))] + ($_ seq + (test "Can log messages to standard output." + (check-success+ "lux io log" (list logC) Any)) + (test "Can throw a run-time error." + (check-success+ "lux io error" (list logC) Nothing)) + (test "Can exit the program." + (check-success+ "lux io exit" (list exitC) Nothing)) + (test "Can query the current time (as milliseconds since epoch)." + (check-success+ "lux io current-time" (list) Int)) + )))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux b/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux new file mode 100644 index 000000000..0a60149d5 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux @@ -0,0 +1,541 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data ["e" error] + [product] + [maybe] + [text "text/" Eq] + text/format + (coll [array] + [list "list/" Fold] + (dictionary ["dict" unordered]))) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + [lang] + (lang [type] + [".L" init] + (analysis [".A" type]) + (extension (analysis [".AE" host]))) + test) + (/// ["_." primitive])) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (do Monad + [## runtime-bytecode @runtime.translate + ] + (lang.with-scope + (typeA.with-type output-type + (_primitive.analyse (` ((~ (code.text procedure)) (~+ params))))))) + (lang.with-current-module "") + (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [success true false] + [failure false true] + ) + +(do-template [ ] + [(def: ( syntax output-type) + (-> Code Type Bool) + (|> (do Monad + [## runtime-bytecode @runtime.translate + ] + (lang.with-scope + (typeA.with-type output-type + (_primitive.analyse syntax)))) + (lang.with-current-module "") + (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [success' true false] + [failure' false true] + ) + +(context: "Conversions [double + float]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert double-to-float" "java.lang.Double" hostAE.Float] + ["jvm convert double-to-int" "java.lang.Double" hostAE.Integer] + ["jvm convert double-to-long" "java.lang.Double" hostAE.Long] + ["jvm convert float-to-double" "java.lang.Float" hostAE.Double] + ["jvm convert float-to-int" "java.lang.Float" hostAE.Integer] + ["jvm convert float-to-long" "java.lang.Float" hostAE.Long] + )] + ($_ seq + + ))) + +(context: "Conversions [int]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert int-to-byte" "java.lang.Integer" hostAE.Byte] + ["jvm convert int-to-char" "java.lang.Integer" hostAE.Character] + ["jvm convert int-to-double" "java.lang.Integer" hostAE.Double] + ["jvm convert int-to-float" "java.lang.Integer" hostAE.Float] + ["jvm convert int-to-long" "java.lang.Integer" hostAE.Long] + ["jvm convert int-to-short" "java.lang.Integer" hostAE.Short] + )] + ($_ seq + + ))) + +(context: "Conversions [long]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert long-to-double" "java.lang.Long" hostAE.Double] + ["jvm convert long-to-float" "java.lang.Long" hostAE.Float] + ["jvm convert long-to-int" "java.lang.Long" hostAE.Integer] + ["jvm convert long-to-short" "java.lang.Long" hostAE.Short] + ["jvm convert long-to-byte" "java.lang.Long" hostAE.Byte] + )] + ($_ seq + + ))) + +(context: "Conversions [char + byte + short]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert char-to-byte" "java.lang.Character" hostAE.Byte] + ["jvm convert char-to-short" "java.lang.Character" hostAE.Short] + ["jvm convert char-to-int" "java.lang.Character" hostAE.Integer] + ["jvm convert char-to-long" "java.lang.Character" hostAE.Long] + ["jvm convert byte-to-long" "java.lang.Byte" hostAE.Long] + ["jvm convert short-to-long" "java.lang.Short" hostAE.Long] + )] + ($_ seq + + ))) + +(do-template [ ] + [(context: (format "Arithmetic " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " +") ] + [(format "jvm " " -") ] + [(format "jvm " " *") ] + [(format "jvm " " /") ] + [(format "jvm " " %") ] + )] + ($_ seq + + ))) + + (context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") hostAE.Boolean] + [(format "jvm " " <") hostAE.Boolean] + )] + ($_ seq + + ))) + + (context: (format "Bitwise " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " and") ] + [(format "jvm " " or") ] + [(format "jvm " " xor") ] + [(format "jvm " " shl") "java.lang.Integer" ] + [(format "jvm " " shr") "java.lang.Integer" ] + [(format "jvm " " ushr") "java.lang.Integer" ] + )] + ($_ seq + + )))] + + + ["int" "java.lang.Integer" hostAE.Integer] + ["long" "java.lang.Long" hostAE.Long] + ) + +(do-template [ ] + [(context: (format "Arithmetic " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " +") ] + [(format "jvm " " -") ] + [(format "jvm " " *") ] + [(format "jvm " " /") ] + [(format "jvm " " %") ] + )] + ($_ seq + + ))) + + (context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") hostAE.Boolean] + [(format "jvm " " <") hostAE.Boolean] + )] + ($_ seq + + )))] + + + ["float" "java.lang.Float" hostAE.Float] + ["double" "java.lang.Double" hostAE.Double] + ) + +(do-template [ ] + [(context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") hostAE.Boolean] + [(format "jvm " " <") hostAE.Boolean] + )] + ($_ seq + + )))] + + + ["char" "java.lang.Character" hostAE.Character] + ) + +(def: array-type + (r.Random [Text Text]) + (let [entries (dict.entries hostAE.boxes) + num-entries (list.size entries)] + (do r.Monad + [choice (|> r.nat (:: @ map (n/% (inc num-entries)))) + #let [[unboxed boxed] (: [Text Text] + (|> entries + (list.nth choice) + (maybe.default ["java.lang.Object" "java.lang.Object"])))]] + (wrap [unboxed boxed])))) + +(context: "Array." + (<| (times +100) + (do @ + [#let [cap (|>> (n/% +10) (n/max +1))] + [unboxed boxed] array-type + size (|> r.nat (:: @ map cap)) + idx (|> r.nat (:: @ map (n/% size))) + level (|> r.nat (:: @ map cap)) + #let [unboxedT (#.Primitive unboxed (list)) + arrayT (#.Primitive "#Array" (list unboxedT)) + arrayC (`' ("lux check" (+0 "#Array" (+1 (+0 (~ (code.text unboxed)) (+0)) (+0))) + ("jvm array new" (~ (code.nat size))))) + boxedT (#.Primitive boxed (list)) + boxedTC (` (+0 (~ (code.text boxed)) (+0))) + multi-arrayT (list/fold (function (_ _ innerT) + (|> innerT (list) (#.Primitive "#Array"))) + boxedT + (list.n/range +1 level))]] + ($_ seq + (test "jvm array new" + (success "jvm array new" + (list (code.nat size)) + arrayT)) + (test "jvm array new (no nesting)" + (failure "jvm array new" + (list (code.nat size)) + unboxedT)) + (test "jvm array new (nested/multi-level)" + (success "jvm array new" + (list (code.nat size)) + multi-arrayT)) + (test "jvm array length" + (success "jvm array length" + (list arrayC) + Nat)) + (test "jvm array read" + (success' (` ("jvm object cast" + ("jvm array read" (~ arrayC) (~ (code.nat idx))))) + boxedT)) + (test "jvm array write" + (success "jvm array write" + (list arrayC (code.nat idx) (`' ("lux coerce" (~ boxedTC) []))) + arrayT)) + )))) + +(def: throwables + (List Text) + (list "java.lang.Throwable" + "java.lang.Error" + "java.io.IOError" + "java.lang.VirtualMachineError" + "java.lang.Exception" + "java.io.IOException" + "java.lang.RuntimeException")) + +(context: "Object." + (<| (times +100) + (do @ + [[unboxed boxed] array-type + [!unboxed !boxed] (|> array-type + (r.filter (function (_ [!unboxed !boxed]) + (not (text/= boxed !boxed))))) + #let [boxedT (#.Primitive boxed (list)) + boxedC (`' ("lux check" (+0 (~ (code.text boxed)) (+0)) + ("jvm object null"))) + !boxedC (`' ("lux check" (+0 (~ (code.text !boxed)) (+0)) + ("jvm object null"))) + unboxedC (`' ("lux check" (+0 (~ (code.text unboxed)) (+0)) + ("jvm object null")))] + throwable (|> r.nat + (:: @ map (n/% (inc (list.size throwables)))) + (:: @ map (function (_ idx) + (|> throwables + (list.nth idx) + (maybe.default "java.lang.Object"))))) + #let [throwableC (`' ("lux check" (+0 (~ (code.text throwable)) (+0)) + ("jvm object null")))]] + ($_ seq + (test "jvm object null" + (success "jvm object null" + (list) + (#.Primitive boxed (list)))) + (test "jvm object null (no primitives)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object null" + (list) + (#.Primitive unboxed (list))))) + (test "jvm object null?" + (success "jvm object null?" + (list boxedC) + Bool)) + (test "jvm object synchronized" + (success "jvm object synchronized" + (list boxedC boxedC) + boxedT)) + (test "jvm object synchronized (no primitives)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object synchronized" + (list unboxedC boxedC) + boxedT))) + (test "jvm object throw" + (or (text/= "java.lang.Object" throwable) + (success "jvm object throw" + (list throwableC) + Nothing))) + (test "jvm object class" + (success "jvm object class" + (list (code.text boxed)) + (#.Primitive "java.lang.Class" (list boxedT)))) + (test "jvm object instance?" + (success "jvm object instance?" + (list (code.text boxed) + boxedC) + Bool)) + (test "jvm object instance? (lineage)" + (success "jvm object instance?" + (list (' "java.lang.Object") + boxedC) + Bool)) + (test "jvm object instance? (no lineage)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object instance?" + (list (code.text boxed) + !boxedC) + Bool))) + )))) + +(context: "Member [Static Field]." + ($_ seq + (test "jvm member static get" + (success "jvm member static get" + (list (code.text "java.lang.System") + (code.text "out")) + (#.Primitive "java.io.PrintStream" (list)))) + (test "jvm member static get (inheritance out)" + (success "jvm member static get" + (list (code.text "java.lang.System") + (code.text "out")) + (#.Primitive "java.lang.Object" (list)))) + (test "jvm member static put" + (success "jvm member static put" + (list (code.text "java.awt.datatransfer.DataFlavor") + (code.text "allHtmlFlavor") + (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0)) + ("jvm object null")))) + Any)) + (test "jvm member static put (final)" + (failure "jvm member static put" + (list (code.text "java.lang.System") + (code.text "out") + (`' ("lux check" (+0 "java.io.PrintStream" (+0)) + ("jvm object null")))) + Any)) + (test "jvm member static put (inheritance in)" + (success "jvm member static put" + (list (code.text "java.awt.datatransfer.DataFlavor") + (code.text "allHtmlFlavor") + (`' ("jvm object cast" + ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) + ("jvm object null"))))) + Any)) + )) + +(context: "Member [Virtual Field]." + ($_ seq + (test "jvm member virtual get" + (success "jvm member virtual get" + (list (code.text "org.omg.CORBA.ValueMember") + (code.text "id") + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (#.Primitive "java.lang.String" (list)))) + (test "jvm member virtual get (inheritance out)" + (success "jvm member virtual get" + (list (code.text "org.omg.CORBA.ValueMember") + (code.text "id") + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (#.Primitive "java.lang.Object" (list)))) + (test "jvm member virtual put" + (success "jvm member virtual put" + (list (code.text "org.omg.CORBA.ValueMember") + (code.text "id") + (`' ("lux check" (+0 "java.lang.String" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (primitive "org.omg.CORBA.ValueMember"))) + (test "jvm member virtual put (final)" + (failure "jvm member virtual put" + (list (code.text "javax.swing.text.html.parser.DTD") + (code.text "applet") + (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0)) + ("jvm object null")))) + (primitive "javax.swing.text.html.parser.DTD"))) + (test "jvm member virtual put (inheritance in)" + (success "jvm member virtual put" + (list (code.text "java.awt.GridBagConstraints") + (code.text "insets") + (`' ("jvm object cast" + ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) + ("jvm object null")))) + (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) + ("jvm object null")))) + (primitive "java.awt.GridBagConstraints"))) + )) + +(context: "Boxing/Unboxing." + ($_ seq + (test "jvm member static get" + (success "jvm member static get" + (list (code.text "java.util.GregorianCalendar") + (code.text "AD")) + (#.Primitive "java.lang.Integer" (list)))) + (test "jvm member virtual get" + (success "jvm member virtual get" + (list (code.text "javax.accessibility.AccessibleAttributeSequence") + (code.text "startIndex") + (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) + ("jvm object null")))) + (#.Primitive "java.lang.Integer" (list)))) + (test "jvm member virtual put" + (success "jvm member virtual put" + (list (code.text "javax.accessibility.AccessibleAttributeSequence") + (code.text "startIndex") + (`' ("jvm object cast" + ("lux check" (+0 "java.lang.Integer" (+0)) + ("jvm object null")))) + (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) + ("jvm object null")))) + (primitive "javax.accessibility.AccessibleAttributeSequence"))) + )) + +(context: "Member [Method]." + (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0)) + +123)) + intC (`' ("jvm convert long-to-int" (~ longC))) + stringC (' ("lux coerce" (+0 "java.lang.String" (+0)) + "YOLO")) + objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0))) + ("jvm member invoke constructor" "java.util.ArrayList" + ["int" ("jvm object cast" (~ intC))])))] + ($_ seq + (test "jvm member invoke static" + (success' (` ("jvm member invoke static" + "java.lang.Long" "decode" + ["java.lang.String" (~ stringC)])) + (#.Primitive "java.lang.Long" (list)))) + (test "jvm member invoke virtual" + (success' (` ("jvm object cast" + ("jvm member invoke virtual" + "java.lang.Object" "equals" + ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) + (#.Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke special" + (success' (` ("jvm object cast" + ("jvm member invoke special" + "java.lang.Long" "equals" + ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) + (#.Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke interface" + (success' (` ("jvm object cast" + ("jvm member invoke interface" + "java.util.Collection" "add" + ("jvm object cast" (~ objectC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) + (#.Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke constructor" + (success' (` ("jvm member invoke constructor" + "java.util.ArrayList" + ["int" ("jvm object cast" (~ intC))])) + (All [a] (#.Primitive "java.util.ArrayList" (list a))))) + ))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/reference.lux b/stdlib/test/test/lux/lang/compiler/analysis/reference.lux new file mode 100644 index 000000000..ff7ce3412 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/reference.lux @@ -0,0 +1,58 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error] + [ident "ident/" Eq]) + ["r" math/random] + [macro #+ Monad] + (macro [code]) + [lang] + (lang [type "type/" Eq] + [".L" scope] + [".L" module] + [".L" reference] + (compiler [".L" init] + [".L" analysis] + (analysis [".A" type] + [".A" expression]))) + test) + (// ["_." primitive])) + +(def: analyse (expressionA.analyser (:! lang.Eval []))) + +(context: "References" + (<| (times +100) + (do @ + [[expectedT _] _primitive.primitive + module-name (r.unicode +5) + scope-name (r.unicode +5) + var-name (r.unicode +5) + #let [def-name [module-name var-name]]] + ($_ seq + (test "Can analyse variable." + (|> (scopeL.with-scope scope-name + (scopeL.with-local [var-name expectedT] + (typeA.with-inference + (..analyse (code.local-symbol var-name))))) + (macro.run (initL.compiler [])) + (case> (^ (#e.Success [inferredT (#analysisL.Reference (referenceL.local var))])) + (and (type/= expectedT inferredT) + (n/= +0 var)) + + _ + false))) + (test "Can analyse definition." + (|> (do Monad + [_ (moduleL.define var-name [expectedT (' {}) []])] + (typeA.with-inference + (..analyse (code.symbol def-name)))) + (moduleL.with-module +0 module-name) + (macro.run (initL.compiler [])) + (case> (^ (#e.Success [_ inferredT (#analysisL.Reference (referenceL.constant constant-name))])) + (and (type/= expectedT inferredT) + (ident/= def-name constant-name)) + + _ + false))))))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/structure.lux b/stdlib/test/test/lux/lang/compiler/analysis/structure.lux new file mode 100644 index 000000000..2f3e369d6 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/structure.lux @@ -0,0 +1,292 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "bool/" Eq] + ["e" error] + [product] + [maybe] + [text] + text/format + (coll [list "list/" Functor] + (set ["set" unordered]))) + ["r" math/random "r/" Monad] + [macro] + (macro [code]) + [lang] + (lang [type "type/" Eq] + (type ["tc" check]) + [".L" module] + (compiler [".L" init] + [".L" analysis #+ Analysis Variant Tag] + (analysis [".A" type] + ["/" structure] + [".A" expression]))) + test) + (// ["_." primitive])) + +(def: analyse (expressionA.analyser (:! lang.Eval []))) + +(do-template [ ] + [(def: #export + (All [a] (-> (Meta a) Bool)) + (|>> (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + _ + )))] + + [check-succeeds true false] + [check-fails false true] + ) + +(def: (check-sum' size tag variant) + (-> Nat Tag (Variant Analysis) Bool) + (let [variant-tag (if (get@ #analysisL.right? variant) + (inc (get@ #analysisL.lefts variant)) + (get@ #analysisL.lefts variant))] + (|> size dec (n/= tag) + (bool/= (get@ #analysisL.right? variant)) + (and (n/= tag variant-tag))))) + +(def: (check-sum type size tag analysis) + (-> Type Nat Tag (Meta Analysis) Bool) + (|> analysis + (typeA.with-type type) + (macro.run (initL.compiler [])) + (case> (^multi (#e.Success sumA) + [(analysisL.variant sumA) + (#.Some variant)]) + (check-sum' size tag variant) + + _ + false))) + +(def: (tagged module tags type) + (All [a] (-> Text (List moduleL.Tag) Type (Meta a) (Meta [Module a]))) + (|>> (do macro.Monad + [_ (moduleL.declare-tags tags false type)]) + (moduleL.with-module +0 module))) + +(def: (check-variant module tags type size tag analysis) + (-> Text (List moduleL.Tag) Type Nat Tag (Meta Analysis) Bool) + (|> analysis + (tagged module tags type) + (typeA.with-type type) + (macro.run (initL.compiler [])) + (case> (^multi (#e.Success [_ sumA]) + [(analysisL.variant sumA) + (#.Some variant)]) + (check-sum' size tag variant) + + _ + false))) + +(def: (right-size? size) + (-> Nat (-> Analysis Bool)) + (|>> analysisL.tuple list.size (n/= size))) + +(def: (check-record-inference module tags type size analysis) + (-> Text (List moduleL.Tag) Type Nat (Meta [Type Analysis]) Bool) + (|> analysis + (tagged module tags type) + (macro.run (initL.compiler [])) + (case> (#e.Success [_ productT productA]) + (and (type/= type productT) + (right-size? size productA)) + + _ + false))) + +(context: "Sums" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + choice (|> r.nat (:: @ map (n/% size))) + primitives (r.list size _primitive.primitive) + +choice (|> r.nat (:: @ map (n/% (inc size)))) + [_ +valueC] _primitive.primitive + #let [variantT (type.variant (list/map product.left primitives)) + [valueT valueC] (maybe.assume (list.nth choice primitives)) + +size (inc size) + +primitives (list.concat (list (list.take choice primitives) + (list [(#.Bound +1) +valueC]) + (list.drop choice primitives))) + [+valueT +valueC] (maybe.assume (list.nth +choice +primitives)) + +variantT (type.variant (list/map product.left +primitives))]] + ($_ seq + (test "Can analyse sum." + (check-sum variantT size choice + (/.sum ..analyse choice valueC))) + (test "Can analyse sum through bound type-vars." + (|> (do macro.Monad + [[_ varT] (typeA.with-env tc.var) + _ (typeA.with-env + (tc.check varT variantT))] + (typeA.with-type varT + (/.sum ..analyse choice valueC))) + (macro.run (initL.compiler [])) + (case> (^multi (#e.Success sumA) + [(analysisL.variant sumA) + (#.Some variant)]) + (check-sum' size choice variant) + + _ + false))) + (test "Cannot analyse sum through unbound type-vars." + (|> (do macro.Monad + [[_ varT] (typeA.with-env tc.var)] + (typeA.with-type varT + (/.sum ..analyse choice valueC))) + check-fails)) + (test "Can analyse sum through existential quantification." + (|> (typeA.with-type (type.ex-q +1 +variantT) + (/.sum ..analyse +choice +valueC)) + check-succeeds)) + (test "Can analyse sum through universal quantification." + (let [check-outcome (if (not (n/= choice +choice)) + check-succeeds + check-fails)] + (|> (typeA.with-type (type.univ-q +1 +variantT) + (/.sum ..analyse +choice +valueC)) + check-outcome))) + )))) + +(context: "Products" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + primitives (r.list size _primitive.primitive) + choice (|> r.nat (:: @ map (n/% size))) + [_ +valueC] _primitive.primitive + #let [tupleT (type.tuple (list/map product.left primitives)) + [singletonT singletonC] (|> primitives (list.nth choice) maybe.assume) + +primitives (list.concat (list (list.take choice primitives) + (list [(#.Bound +1) +valueC]) + (list.drop choice primitives))) + +tupleT (type.tuple (list/map product.left +primitives))]] + ($_ seq + (test "Can analyse product." + (|> (typeA.with-type tupleT + (/.product ..analyse (list/map product.right primitives))) + (macro.run (initL.compiler [])) + (case> (#e.Success tupleA) + (right-size? size tupleA) + + _ + false))) + (test "Can infer product." + (|> (typeA.with-inference + (/.product ..analyse (list/map product.right primitives))) + (macro.run (initL.compiler [])) + (case> (#e.Success [_type tupleA]) + (and (type/= tupleT _type) + (right-size? size tupleA)) + + _ + false))) + (test "Can analyse pseudo-product (singleton tuple)" + (|> (typeA.with-type singletonT + (..analyse (` [(~ singletonC)]))) + check-succeeds)) + (test "Can analyse product through bound type-vars." + (|> (do macro.Monad + [[_ varT] (typeA.with-env tc.var) + _ (typeA.with-env + (tc.check varT (type.tuple (list/map product.left primitives))))] + (typeA.with-type varT + (/.product ..analyse (list/map product.right primitives)))) + (macro.run (initL.compiler [])) + (case> (#e.Success tupleA) + (right-size? size tupleA) + + _ + false))) + (test "Can analyse product through existential quantification." + (|> (typeA.with-type (type.ex-q +1 +tupleT) + (/.product ..analyse (list/map product.right +primitives))) + check-succeeds)) + (test "Cannot analyse product through universal quantification." + (|> (typeA.with-type (type.univ-q +1 +tupleT) + (/.product ..analyse (list/map product.right +primitives))) + check-fails)) + )))) + +(context: "Tagged Sums" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) + choice (|> r.nat (:: @ map (n/% size))) + other-choice (|> r.nat (:: @ map (n/% size)) (r.filter (|>> (n/= choice) not))) + primitives (r.list size _primitive.primitive) + module-name (r.unicode +5) + type-name (r.unicode +5) + #let [varT (#.Bound +1) + primitivesT (list/map product.left primitives) + [choiceT choiceC] (maybe.assume (list.nth choice primitives)) + [other-choiceT other-choiceC] (maybe.assume (list.nth other-choice primitives)) + variantT (type.variant primitivesT) + namedT (#.Named [module-name type-name] variantT) + named-polyT (|> (type.variant (list.concat (list (list.take choice primitivesT) + (list varT) + (list.drop (inc choice) primitivesT)))) + (type.univ-q +1) + (#.Named [module-name type-name])) + choice-tag (maybe.assume (list.nth choice tags)) + other-choice-tag (maybe.assume (list.nth other-choice tags))]] + ($_ seq + (test "Can infer tagged sum." + (|> (/.tagged-sum ..analyse [module-name choice-tag] choiceC) + (check-variant module-name tags namedT choice size))) + (test "Tagged sums specialize when type-vars get bound." + (|> (/.tagged-sum ..analyse [module-name choice-tag] choiceC) + (check-variant module-name tags named-polyT choice size))) + (test "Tagged sum inference retains universal quantification when type-vars are not bound." + (|> (/.tagged-sum ..analyse [module-name other-choice-tag] other-choiceC) + (check-variant module-name tags named-polyT other-choice size))) + (test "Can specialize generic tagged sums." + (|> (typeA.with-type variantT + (/.tagged-sum ..analyse [module-name other-choice-tag] other-choiceC)) + (check-variant module-name tags named-polyT other-choice size))) + )))) + +(context: "Records" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) + primitives (r.list size _primitive.primitive) + module-name (r.unicode +5) + type-name (r.unicode +5) + choice (|> r.nat (:: @ map (n/% size))) + #let [varT (#.Bound +1) + tagsC (list/map (|>> [module-name] code.tag) tags) + primitivesT (list/map product.left primitives) + primitivesC (list/map product.right primitives) + tupleT (type.tuple primitivesT) + namedT (#.Named [module-name type-name] tupleT) + recordC (list.zip2 tagsC primitivesC) + named-polyT (|> (type.tuple (list.concat (list (list.take choice primitivesT) + (list varT) + (list.drop (inc choice) primitivesT)))) + (type.univ-q +1) + (#.Named [module-name type-name]))]] + ($_ seq + (test "Can infer record." + (|> (typeA.with-inference + (/.record ..analyse recordC)) + (check-record-inference module-name tags namedT size))) + (test "Records specialize when type-vars get bound." + (|> (typeA.with-inference + (/.record ..analyse recordC)) + (check-record-inference module-name tags named-polyT size))) + (test "Can specialize generic records." + (|> (do macro.Monad + [recordA (typeA.with-type tupleT + (/.record ..analyse recordC))] + (wrap [tupleT recordA])) + (check-record-inference module-name tags named-polyT size))) + )))) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/case.lux b/stdlib/test/test/lux/lang/compiler/synthesis/case.lux new file mode 100644 index 000000000..228ed2920 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/synthesis/case.lux @@ -0,0 +1,82 @@ +(.module: + lux + (lux (control [monad #+ do] + pipe) + (data [error "error/" Functor]) + (lang ["///." reference] + ["///." compiler] + [".L" analysis #+ Branch Analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression]) + [".L" extension]) + ["r" math/random "r/" Monad] + test) + [//primitive]) + +(context: "Dummy variables." + (<| (times +100) + (do @ + [maskedA //primitive.primitive + temp (|> r.nat (:: @ map (n/% +100))) + #let [maskA (analysisL.control/case + [maskedA + [[(#analysisL.Bind temp) + (#analysisL.Reference (///reference.local temp))] + (list)]])]] + (test "Dummy variables created to mask expressions get eliminated during synthesis." + (|> maskA + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (error/map (//primitive.corresponds? maskedA)) + (error.default false)))))) + +(context: "Let expressions." + (<| (times +100) + (do @ + [registerA r.nat + inputA //primitive.primitive + outputA //primitive.primitive + #let [letA (analysisL.control/case + [inputA + [[(#analysisL.Bind registerA) + outputA] + (list)]])]] + (test "Can detect and reify simple 'let' expressions." + (|> letA + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.branch/let [inputS registerS outputS]))) + (and (n/= registerA registerS) + (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? outputA outputS)) + + _ + false)))))) + +(context: "If expressions." + (<| (times +100) + (do @ + [then|else r.bool + inputA //primitive.primitive + thenA //primitive.primitive + elseA //primitive.primitive + #let [thenB (: Branch + [(#analysisL.Simple (#analysisL.Bool true)) + thenA]) + elseB (: Branch + [(#analysisL.Simple (#analysisL.Bool false)) + elseA]) + ifA (if then|else + (analysisL.control/case [inputA [thenB (list elseB)]]) + (analysisL.control/case [inputA [elseB (list thenB)]]))]] + (test "Can detect and reify simple 'if' expressions." + (|> ifA + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.branch/if [inputS thenS elseS]))) + (and (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? thenA thenS) + (//primitive.corresponds? elseA elseS)) + + _ + false)))))) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/function.lux b/stdlib/test/test/lux/lang/compiler/synthesis/function.lux new file mode 100644 index 000000000..c7b16de27 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/synthesis/function.lux @@ -0,0 +1,168 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [product] + [maybe] + [error] + [number] + text/format + (coll [list "list/" Functor Fold] + (dictionary ["dict" unordered #+ Dict]) + (set ["set" unordered]))) + (lang ["///." reference #+ Variable "variable/" Equality] + ["///." compiler] + [".L" analysis #+ Arity Analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression]) + [".L" extension]) + ["r" math/random] + test) + [//primitive]) + +(def: constant-function + (r.Random [Arity Analysis Analysis]) + (r.rec + (function (_ constant-function) + (do r.Monad + [function? r.bool] + (if function? + (do @ + [[arity bodyA predictionA] constant-function] + (wrap [(inc arity) + (#analysisL.Function (list) bodyA) + predictionA])) + (do @ + [predictionA //primitive.primitive] + (wrap [+0 predictionA predictionA]))))))) + +(def: (pick scope-size) + (-> Nat (r.Random Nat)) + (|> r.nat (:: r.Monad map (n/% scope-size)))) + +(def: function-with-environment + (r.Random [Arity Analysis Variable]) + (do r.Monad + [num-locals (|> r.nat (:: @ map (|>> (n/% +100) (n/max +10)))) + #let [indices (list.n/range +0 (dec num-locals)) + local-env (list/map (|>> #///reference.Local) indices) + foreign-env (list/map (|>> #///reference.Foreign) indices)] + [arity bodyA predictionA] (: (r.Random [Arity Analysis Variable]) + (loop [arity +1 + current-env foreign-env] + (let [current-env/size (list.size current-env) + resolver (list/fold (function (_ [idx var] resolver) + (dict.put idx var resolver)) + (: (Dict Nat Variable) + (dict.new number.Hash)) + (list.enumerate current-env))] + (do @ + [nest? r.bool] + (if nest? + (do @ + [num-picks (:: @ map (n/max +1) (pick (inc current-env/size))) + picks (|> (r.set number.Hash num-picks (pick current-env/size)) + (:: @ map set.to-list)) + [arity bodyA predictionA] (recur (inc arity) + (list/map (function (_ pick) + (maybe.assume (list.nth pick current-env))) + picks)) + #let [picked-env (list/map (|>> #///reference.Foreign) picks)]] + (wrap [arity + (#analysisL.Function picked-env bodyA) + predictionA])) + (do @ + [chosen (pick (list.size current-env))] + (wrap [arity + (#analysisL.Reference (///reference.foreign chosen)) + (maybe.assume (dict.get chosen resolver))])))))))] + (wrap [arity + (#analysisL.Function local-env bodyA) + predictionA]))) + +(def: local-function + (r.Random [Arity Analysis Variable]) + (loop [arity +0 + nest? true] + (if nest? + (do r.Monad + [nest?' r.bool + [arity' bodyA predictionA] (recur (inc arity) nest?')] + (wrap [arity' + (#analysisL.Function (list) bodyA) + predictionA])) + (do r.Monad + [chosen (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2))))] + (wrap [arity + (#analysisL.Reference (///reference.local chosen)) + (|> chosen (n/+ (dec arity)) #///reference.Local)]))))) + +(context: "Function definition." + (<| (seed +13007429814532219492) + ## (times +100) + (do @ + [[arity//constant function//constant prediction//constant] constant-function + [arity//environment function//environment prediction//environment] function-with-environment + [arity//local function//local prediction//local] local-function] + ($_ seq + (test "Nested functions will get folded together." + (|> function//constant + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.function/abstraction [environment arity output]))) + (and (n/= arity//constant arity) + (//primitive.corresponds? prediction//constant output)) + + _ + (n/= +0 arity//constant)))) + (test "Folded functions provide direct access to environment variables." + (|> function//environment + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) + (and (n/= arity//environment arity) + (variable/= prediction//environment output)) + + _ + false))) + (test "Folded functions properly offset local variables." + (|> function//local + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) + (and (n/= arity//local arity) + (variable/= prediction//local output)) + + _ + false))) + )))) + +(context: "Function application." + (<| (times +100) + (do @ + [arity (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1)))) + funcA //primitive.primitive + argsA (r.list arity //primitive.primitive)] + ($_ seq + (test "Can synthesize function application." + (|> (analysisL.apply [funcA argsA]) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.function/apply [funcS argsS]))) + (and (//primitive.corresponds? funcA funcS) + (list.every? (product.uncurry //primitive.corresponds?) + (list.zip2 argsA argsS))) + + _ + false))) + (test "Function application on no arguments just synthesizes to the function itself." + (|> (analysisL.apply [funcA (list)]) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (#error.Success funcS) + (//primitive.corresponds? funcA funcS) + + _ + false))) + )))) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux b/stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux new file mode 100644 index 000000000..1c8368204 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux @@ -0,0 +1,92 @@ +(.module: + [lux #- primitive] + (lux [io] + (control [monad #+ do] + pipe) + (data [error] + text/format) + [lang] + (lang [".L" extension] + ["///." compiler] + [".L" analysis #+ Analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression])) + ["r" math/random] + test)) + +(def: #export primitive + (r.Random Analysis) + (do r.Monad + [primitive (: (r.Random analysisL.Primitive) + ($_ r.alt + (wrap []) + r.bool + r.nat + r.int + r.deg + r.frac + (r.unicode +5)))] + (wrap (#analysisL.Primitive primitive)))) + +(def: #export (corresponds? analysis synthesis) + (-> Analysis Synthesis Bool) + (case [synthesis analysis] + [(#//.Primitive (#//.Text valueS)) + (#analysisL.Primitive (#analysisL.Unit valueA))] + (is? valueS (:! Text valueA)) + + [(#//.Primitive (#//.Bool valueS)) + (#analysisL.Primitive (#analysisL.Bool valueA))] + (is? valueS valueA) + + [(#//.Primitive (#//.I64 valueS)) + (#analysisL.Primitive (#analysisL.Nat valueA))] + (is? valueS (.i64 valueA)) + + [(#//.Primitive (#//.I64 valueS)) + (#analysisL.Primitive (#analysisL.Int valueA))] + (is? valueS (.i64 valueA)) + + [(#//.Primitive (#//.I64 valueS)) + (#analysisL.Primitive (#analysisL.Deg valueA))] + (is? valueS (.i64 valueA)) + + [(#//.Primitive (#//.F64 valueS)) + (#analysisL.Primitive (#analysisL.Frac valueA))] + (is? valueS valueA) + + [(#//.Primitive (#//.Text valueS)) + (#analysisL.Primitive (#analysisL.Text valueA))] + (is? valueS valueA) + + _ + false)) + +(context: "Primitives." + (<| (times +100) + (do @ + [%bool% r.bool + %nat% r.nat + %int% r.int + %deg% r.deg + %frac% r.frac + %text% (r.unicode +5)] + (`` ($_ seq + (~~ (do-template [ ] + [(test (format "Can synthesize " ".") + (|> (#analysisL.Primitive ( )) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (#error.Success (#//.Primitive ( value))) + (is? value) + + _ + false)))] + + ["unit" #analysisL.Unit #//.Text //.unit] + ["bool" #analysisL.Bool #//.Bool %bool%] + ["nat" #analysisL.Nat #//.I64 (.i64 %nat%)] + ["int" #analysisL.Int #//.I64 (.i64 %int%)] + ["deg" #analysisL.Deg #//.I64 (.i64 %deg%)] + ["frac" #analysisL.Frac #//.F64 %frac%] + ["text" #analysisL.Text #//.Text %text%]))))))) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux b/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux new file mode 100644 index 000000000..e61386044 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux @@ -0,0 +1,57 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "bool/" Eq] + [product] + [error] + (coll [list])) + (lang ["///." compiler] + [".L" analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression]) + [".L" extension]) + ["r" math/random "r/" Monad] + test) + [//primitive]) + +(context: "Variants" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/+ +2)))) + tagA (|> r.nat (:: @ map (n/% size))) + memberA //primitive.primitive] + ($_ seq + (test "Can synthesize variants." + (|> (analysisL.sum-analysis size tagA memberA) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (#error.Success (#//.Structure (#//.Variant [leftsS right?S valueS]))) + (let [tagS (if right?S (inc leftsS) leftsS)] + (and (n/= tagA tagS) + (|> tagS (n/= (dec size)) (bool/= right?S)) + (//primitive.corresponds? memberA valueS))) + + _ + false))) + )))) + +(context: "Tuples" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + membersA (r.list size //primitive.primitive)] + ($_ seq + (test "Can synthesize tuple." + (|> (analysisL.product-analysis membersA) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (#error.Success (#//.Structure (#//.Tuple membersS))) + (and (n/= size (list.size membersS)) + (list.every? (product.uncurry //primitive.corresponds?) + (list.zip2 membersA membersS))) + + _ + false))) + )))) diff --git a/stdlib/test/test/lux/lang/synthesis/case.lux b/stdlib/test/test/lux/lang/synthesis/case.lux deleted file mode 100644 index 228ed2920..000000000 --- a/stdlib/test/test/lux/lang/synthesis/case.lux +++ /dev/null @@ -1,82 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - pipe) - (data [error "error/" Functor]) - (lang ["///." reference] - ["///." compiler] - [".L" analysis #+ Branch Analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression]) - [".L" extension]) - ["r" math/random "r/" Monad] - test) - [//primitive]) - -(context: "Dummy variables." - (<| (times +100) - (do @ - [maskedA //primitive.primitive - temp (|> r.nat (:: @ map (n/% +100))) - #let [maskA (analysisL.control/case - [maskedA - [[(#analysisL.Bind temp) - (#analysisL.Reference (///reference.local temp))] - (list)]])]] - (test "Dummy variables created to mask expressions get eliminated during synthesis." - (|> maskA - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (error/map (//primitive.corresponds? maskedA)) - (error.default false)))))) - -(context: "Let expressions." - (<| (times +100) - (do @ - [registerA r.nat - inputA //primitive.primitive - outputA //primitive.primitive - #let [letA (analysisL.control/case - [inputA - [[(#analysisL.Bind registerA) - outputA] - (list)]])]] - (test "Can detect and reify simple 'let' expressions." - (|> letA - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.branch/let [inputS registerS outputS]))) - (and (n/= registerA registerS) - (//primitive.corresponds? inputA inputS) - (//primitive.corresponds? outputA outputS)) - - _ - false)))))) - -(context: "If expressions." - (<| (times +100) - (do @ - [then|else r.bool - inputA //primitive.primitive - thenA //primitive.primitive - elseA //primitive.primitive - #let [thenB (: Branch - [(#analysisL.Simple (#analysisL.Bool true)) - thenA]) - elseB (: Branch - [(#analysisL.Simple (#analysisL.Bool false)) - elseA]) - ifA (if then|else - (analysisL.control/case [inputA [thenB (list elseB)]]) - (analysisL.control/case [inputA [elseB (list thenB)]]))]] - (test "Can detect and reify simple 'if' expressions." - (|> ifA - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.branch/if [inputS thenS elseS]))) - (and (//primitive.corresponds? inputA inputS) - (//primitive.corresponds? thenA thenS) - (//primitive.corresponds? elseA elseS)) - - _ - false)))))) diff --git a/stdlib/test/test/lux/lang/synthesis/function.lux b/stdlib/test/test/lux/lang/synthesis/function.lux deleted file mode 100644 index c7b16de27..000000000 --- a/stdlib/test/test/lux/lang/synthesis/function.lux +++ /dev/null @@ -1,168 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [product] - [maybe] - [error] - [number] - text/format - (coll [list "list/" Functor Fold] - (dictionary ["dict" unordered #+ Dict]) - (set ["set" unordered]))) - (lang ["///." reference #+ Variable "variable/" Equality] - ["///." compiler] - [".L" analysis #+ Arity Analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression]) - [".L" extension]) - ["r" math/random] - test) - [//primitive]) - -(def: constant-function - (r.Random [Arity Analysis Analysis]) - (r.rec - (function (_ constant-function) - (do r.Monad - [function? r.bool] - (if function? - (do @ - [[arity bodyA predictionA] constant-function] - (wrap [(inc arity) - (#analysisL.Function (list) bodyA) - predictionA])) - (do @ - [predictionA //primitive.primitive] - (wrap [+0 predictionA predictionA]))))))) - -(def: (pick scope-size) - (-> Nat (r.Random Nat)) - (|> r.nat (:: r.Monad map (n/% scope-size)))) - -(def: function-with-environment - (r.Random [Arity Analysis Variable]) - (do r.Monad - [num-locals (|> r.nat (:: @ map (|>> (n/% +100) (n/max +10)))) - #let [indices (list.n/range +0 (dec num-locals)) - local-env (list/map (|>> #///reference.Local) indices) - foreign-env (list/map (|>> #///reference.Foreign) indices)] - [arity bodyA predictionA] (: (r.Random [Arity Analysis Variable]) - (loop [arity +1 - current-env foreign-env] - (let [current-env/size (list.size current-env) - resolver (list/fold (function (_ [idx var] resolver) - (dict.put idx var resolver)) - (: (Dict Nat Variable) - (dict.new number.Hash)) - (list.enumerate current-env))] - (do @ - [nest? r.bool] - (if nest? - (do @ - [num-picks (:: @ map (n/max +1) (pick (inc current-env/size))) - picks (|> (r.set number.Hash num-picks (pick current-env/size)) - (:: @ map set.to-list)) - [arity bodyA predictionA] (recur (inc arity) - (list/map (function (_ pick) - (maybe.assume (list.nth pick current-env))) - picks)) - #let [picked-env (list/map (|>> #///reference.Foreign) picks)]] - (wrap [arity - (#analysisL.Function picked-env bodyA) - predictionA])) - (do @ - [chosen (pick (list.size current-env))] - (wrap [arity - (#analysisL.Reference (///reference.foreign chosen)) - (maybe.assume (dict.get chosen resolver))])))))))] - (wrap [arity - (#analysisL.Function local-env bodyA) - predictionA]))) - -(def: local-function - (r.Random [Arity Analysis Variable]) - (loop [arity +0 - nest? true] - (if nest? - (do r.Monad - [nest?' r.bool - [arity' bodyA predictionA] (recur (inc arity) nest?')] - (wrap [arity' - (#analysisL.Function (list) bodyA) - predictionA])) - (do r.Monad - [chosen (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2))))] - (wrap [arity - (#analysisL.Reference (///reference.local chosen)) - (|> chosen (n/+ (dec arity)) #///reference.Local)]))))) - -(context: "Function definition." - (<| (seed +13007429814532219492) - ## (times +100) - (do @ - [[arity//constant function//constant prediction//constant] constant-function - [arity//environment function//environment prediction//environment] function-with-environment - [arity//local function//local prediction//local] local-function] - ($_ seq - (test "Nested functions will get folded together." - (|> function//constant - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.function/abstraction [environment arity output]))) - (and (n/= arity//constant arity) - (//primitive.corresponds? prediction//constant output)) - - _ - (n/= +0 arity//constant)))) - (test "Folded functions provide direct access to environment variables." - (|> function//environment - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) - (and (n/= arity//environment arity) - (variable/= prediction//environment output)) - - _ - false))) - (test "Folded functions properly offset local variables." - (|> function//local - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) - (and (n/= arity//local arity) - (variable/= prediction//local output)) - - _ - false))) - )))) - -(context: "Function application." - (<| (times +100) - (do @ - [arity (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1)))) - funcA //primitive.primitive - argsA (r.list arity //primitive.primitive)] - ($_ seq - (test "Can synthesize function application." - (|> (analysisL.apply [funcA argsA]) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.function/apply [funcS argsS]))) - (and (//primitive.corresponds? funcA funcS) - (list.every? (product.uncurry //primitive.corresponds?) - (list.zip2 argsA argsS))) - - _ - false))) - (test "Function application on no arguments just synthesizes to the function itself." - (|> (analysisL.apply [funcA (list)]) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (#error.Success funcS) - (//primitive.corresponds? funcA funcS) - - _ - false))) - )))) diff --git a/stdlib/test/test/lux/lang/synthesis/primitive.lux b/stdlib/test/test/lux/lang/synthesis/primitive.lux deleted file mode 100644 index 1c8368204..000000000 --- a/stdlib/test/test/lux/lang/synthesis/primitive.lux +++ /dev/null @@ -1,92 +0,0 @@ -(.module: - [lux #- primitive] - (lux [io] - (control [monad #+ do] - pipe) - (data [error] - text/format) - [lang] - (lang [".L" extension] - ["///." compiler] - [".L" analysis #+ Analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression])) - ["r" math/random] - test)) - -(def: #export primitive - (r.Random Analysis) - (do r.Monad - [primitive (: (r.Random analysisL.Primitive) - ($_ r.alt - (wrap []) - r.bool - r.nat - r.int - r.deg - r.frac - (r.unicode +5)))] - (wrap (#analysisL.Primitive primitive)))) - -(def: #export (corresponds? analysis synthesis) - (-> Analysis Synthesis Bool) - (case [synthesis analysis] - [(#//.Primitive (#//.Text valueS)) - (#analysisL.Primitive (#analysisL.Unit valueA))] - (is? valueS (:! Text valueA)) - - [(#//.Primitive (#//.Bool valueS)) - (#analysisL.Primitive (#analysisL.Bool valueA))] - (is? valueS valueA) - - [(#//.Primitive (#//.I64 valueS)) - (#analysisL.Primitive (#analysisL.Nat valueA))] - (is? valueS (.i64 valueA)) - - [(#//.Primitive (#//.I64 valueS)) - (#analysisL.Primitive (#analysisL.Int valueA))] - (is? valueS (.i64 valueA)) - - [(#//.Primitive (#//.I64 valueS)) - (#analysisL.Primitive (#analysisL.Deg valueA))] - (is? valueS (.i64 valueA)) - - [(#//.Primitive (#//.F64 valueS)) - (#analysisL.Primitive (#analysisL.Frac valueA))] - (is? valueS valueA) - - [(#//.Primitive (#//.Text valueS)) - (#analysisL.Primitive (#analysisL.Text valueA))] - (is? valueS valueA) - - _ - false)) - -(context: "Primitives." - (<| (times +100) - (do @ - [%bool% r.bool - %nat% r.nat - %int% r.int - %deg% r.deg - %frac% r.frac - %text% (r.unicode +5)] - (`` ($_ seq - (~~ (do-template [ ] - [(test (format "Can synthesize " ".") - (|> (#analysisL.Primitive ( )) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (#error.Success (#//.Primitive ( value))) - (is? value) - - _ - false)))] - - ["unit" #analysisL.Unit #//.Text //.unit] - ["bool" #analysisL.Bool #//.Bool %bool%] - ["nat" #analysisL.Nat #//.I64 (.i64 %nat%)] - ["int" #analysisL.Int #//.I64 (.i64 %int%)] - ["deg" #analysisL.Deg #//.I64 (.i64 %deg%)] - ["frac" #analysisL.Frac #//.F64 %frac%] - ["text" #analysisL.Text #//.Text %text%]))))))) diff --git a/stdlib/test/test/lux/lang/synthesis/structure.lux b/stdlib/test/test/lux/lang/synthesis/structure.lux deleted file mode 100644 index e61386044..000000000 --- a/stdlib/test/test/lux/lang/synthesis/structure.lux +++ /dev/null @@ -1,57 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "bool/" Eq] - [product] - [error] - (coll [list])) - (lang ["///." compiler] - [".L" analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression]) - [".L" extension]) - ["r" math/random "r/" Monad] - test) - [//primitive]) - -(context: "Variants" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/+ +2)))) - tagA (|> r.nat (:: @ map (n/% size))) - memberA //primitive.primitive] - ($_ seq - (test "Can synthesize variants." - (|> (analysisL.sum-analysis size tagA memberA) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (#error.Success (#//.Structure (#//.Variant [leftsS right?S valueS]))) - (let [tagS (if right?S (inc leftsS) leftsS)] - (and (n/= tagA tagS) - (|> tagS (n/= (dec size)) (bool/= right?S)) - (//primitive.corresponds? memberA valueS))) - - _ - false))) - )))) - -(context: "Tuples" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - membersA (r.list size //primitive.primitive)] - ($_ seq - (test "Can synthesize tuple." - (|> (analysisL.product-analysis membersA) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (#error.Success (#//.Structure (#//.Tuple membersS))) - (and (n/= size (list.size membersS)) - (list.every? (product.uncurry //primitive.corresponds?) - (list.zip2 membersA membersS))) - - _ - false))) - )))) -- cgit v1.2.3