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 - 72 files changed, 6109 insertions(+), 6197 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 (limited to 'stdlib/source') 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])))) -- cgit v1.2.3