diff options
author | Eduardo Julian | 2018-06-17 22:27:40 -0400 |
---|---|---|
committer | Eduardo Julian | 2018-06-17 22:27:40 -0400 |
commit | b7b0dd9bd952ede4710da157b40304d714229e04 (patch) | |
tree | 26362697e783723fc5da52dad5369b714d6579fe | |
parent | b6ccfc87c52e1a98ead3b04b45bccc119418a4dc (diff) |
- Heavy refactoring to integrate extensions better with the rest of the compiler.
-rw-r--r-- | stdlib/source/lux/lang.lux | 112 | ||||
-rw-r--r-- | stdlib/source/lux/lang/analysis/expression.lux | 122 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler.lux | 57 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/analysis.lux (renamed from stdlib/source/lux/lang/analysis.lux) | 92 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/case.lux (renamed from stdlib/source/lux/lang/analysis/case.lux) | 159 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/case/coverage.lux (renamed from stdlib/source/lux/lang/analysis/case/coverage.lux) | 55 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/expression.lux | 121 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/function.lux (renamed from stdlib/source/lux/lang/analysis/function.lux) | 45 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/inference.lux (renamed from stdlib/source/lux/lang/analysis/inference.lux) | 126 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/primitive.lux (renamed from stdlib/source/lux/lang/analysis/primitive.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/reference.lux (renamed from stdlib/source/lux/lang/analysis/reference.lux) | 25 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/structure.lux (renamed from stdlib/source/lux/lang/analysis/structure.lux) | 148 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/type.lux (renamed from stdlib/source/lux/lang/analysis/type.lux) | 47 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/extension.lux | 68 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/extension/analysis.lux (renamed from stdlib/source/lux/lang/extension/analysis.lux) | 4 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/extension/analysis/common.lux | 396 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux (renamed from stdlib/source/lux/lang/extension/analysis/host.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/extension/bundle.lux | 31 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/extension/synthesis.lux (renamed from stdlib/source/lux/lang/extension/synthesis.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/extension/translation.lux (renamed from stdlib/source/lux/lang/extension/translation.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/init.lux | 51 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/synthesis.lux (renamed from stdlib/source/lux/lang/synthesis.lux) | 30 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/synthesis/case.lux (renamed from stdlib/source/lux/lang/synthesis/case.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/synthesis/expression.lux (renamed from stdlib/source/lux/lang/synthesis/expression.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/synthesis/function.lux (renamed from stdlib/source/lux/lang/synthesis/function.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/synthesis/loop.lux (renamed from stdlib/source/lux/lang/synthesis/loop.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/translation.lux (renamed from stdlib/source/lux/lang/translation.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/case.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/expression.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/extension.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/function.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/loop.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/reference.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/structure.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/source/lux/lang/extension.lux | 131 | ||||
-rw-r--r-- | stdlib/source/lux/lang/extension/analysis/common.lux | 444 | ||||
-rw-r--r-- | stdlib/source/lux/lang/host.lux (renamed from stdlib/source/lux/lang/target.lux) | 4 | ||||
-rw-r--r-- | stdlib/source/lux/lang/init.lux | 61 | ||||
-rw-r--r-- | stdlib/source/lux/lang/module.lux | 51 | ||||
-rw-r--r-- | stdlib/test/test/lux/lang/compiler/analysis/case.lux (renamed from stdlib/test/test/lux/lang/analysis/case.lux) | 16 | ||||
-rw-r--r-- | stdlib/test/test/lux/lang/compiler/analysis/function.lux (renamed from stdlib/test/test/lux/lang/analysis/function.lux) | 10 | ||||
-rw-r--r-- | stdlib/test/test/lux/lang/compiler/analysis/primitive.lux (renamed from stdlib/test/test/lux/lang/analysis/primitive.lux) | 8 | ||||
-rw-r--r-- | stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux (renamed from stdlib/test/test/lux/lang/analysis/procedure/common.lux) | 0 | ||||
-rw-r--r-- | stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux (renamed from stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux) | 0 | ||||
-rw-r--r-- | stdlib/test/test/lux/lang/compiler/analysis/reference.lux (renamed from stdlib/test/test/lux/lang/analysis/reference.lux) | 8 | ||||
-rw-r--r-- | stdlib/test/test/lux/lang/compiler/analysis/structure.lux (renamed from stdlib/test/test/lux/lang/analysis/structure.lux) | 10 | ||||
-rw-r--r-- | stdlib/test/test/lux/lang/compiler/synthesis/case.lux (renamed from stdlib/test/test/lux/lang/synthesis/case.lux) | 0 | ||||
-rw-r--r-- | stdlib/test/test/lux/lang/compiler/synthesis/function.lux (renamed from stdlib/test/test/lux/lang/synthesis/function.lux) | 0 | ||||
-rw-r--r-- | stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux (renamed from stdlib/test/test/lux/lang/synthesis/primitive.lux) | 0 | ||||
-rw-r--r-- | stdlib/test/test/lux/lang/compiler/synthesis/structure.lux (renamed from stdlib/test/test/lux/lang/synthesis/structure.lux) | 0 |
53 files changed, 1172 insertions, 1260 deletions
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>] - 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<Meta> - [[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<Meta> (~' 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/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 [<name>] - [(exception: #export (<name> {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<Meta> - [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 [<tag> <analyser>] - (<tag> value) - (<analyser> value)) - ([#.Bool primitiveA.bool] - [#.Nat primitiveA.nat] - [#.Int primitiveA.int] - [#.Deg primitiveA.deg] - [#.Frac primitiveA.frac] - [#.Text primitiveA.text]) - - (^template [<tag> <analyser>] - (^ (#.Form (list& [_ (<tag> tag)] - values))) - (case values - (#.Cons value #.Nil) - (<analyser> analyse tag value) - - _ - (<analyser> 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<Meta> - [procedure (extensionL.find-analysis proc-name)] - (procedure analyse eval proc-args)) - - ## (^ (#.Form (list& func args))) - ## (do macro.Monad<Meta> - ## [[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/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<Operation> + (state.Monad<State'> error.Monad<Error>)) + +(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<Error> map product.right))) +(def: #export fail + (-> Text Operation) + (|>> error.fail (state.lift error.Monad<Error>))) + (def: #export (throw exception parameters) (All [e] (-> (Exception e) e Operation)) (state.lift error.Monad<Error> (ex.throw exception parameters))) +(syntax: #export (assert exception message test) + (wrap (list (` (if (~ test) + (:: ..Monad<Operation> (~' 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<Operation> - (state.Monad<State'> error.Monad<Error>)) +(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<Error> + [[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/analysis.lux b/stdlib/source/lux/lang/compiler/analysis.lux index 6efa934d8..235e399fb 100644 --- a/stdlib/source/lux/lang/analysis.lux +++ b/stdlib/source/lux/lang/compiler/analysis.lux @@ -1,9 +1,12 @@ (.module: [lux #- nat int deg] - (lux [function] - (data (coll [list "list/" Fold<List>]))) - [// #+ Extension] - [//reference #+ Register Variable Reference]) + (lux (data [product] + [error] + [text "text/" Eq<Text>] + (coll [list "list/" Fold<List>])) + [function]) + [///reference #+ Register Variable Reference] + [//]) (type: #export #rec Primitive #Unit @@ -41,8 +44,13 @@ (#Reference Reference) (#Case Analysis (Match' Analysis)) (#Function Environment Analysis) - (#Apply Analysis Analysis) - (#Extension (Extension Analysis))) + (#Apply Analysis Analysis)) + +(type: #export Operation + (//.Operation .Lux)) + +(type: #export Compiler + (//.Compiler .Lux Code Analysis)) (type: #export Branch (Branch' Analysis)) @@ -88,7 +96,7 @@ (n/= (dec size) tag)) (template: #export (no-op value) - (|> +1 #//reference.Local #//reference.Variable #..Reference + (|> +1 #///reference.Local #///reference.Variable #..Reference (#..Function (list)) (#..Apply value))) @@ -138,9 +146,6 @@ (-> (Application Analysis) Analysis) (list/fold (function (_ arg func) (#Apply arg func)) func args)) -(type: #export Analyser - (-> Code (Meta Analysis))) - (do-template [<name> <type> <tag>] [(def: #export (<name> value) (-> <type> (Tuple <type>)) @@ -207,3 +212,70 @@ [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/analysis/case.lux b/stdlib/source/lux/lang/compiler/analysis/case.lux index 744d3cf24..9e67a24f9 100644 --- a/stdlib/source/lux/lang/analysis/case.lux +++ b/stdlib/source/lux/lang/compiler/analysis/case.lux @@ -1,27 +1,22 @@ (.module: [lux #- case] (lux (control [monad #+ do] - ["ex" exception #+ exception:] - [equality #+ Eq]) - (data [bool] - [number] - [product] - ["e" error] + ["ex" exception #+ exception:]) + (data [product] + [error] [maybe] - [text] text/format (coll [list "list/" Fold<List> Monoid<List> Functor<List>])) - [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]))))) + (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)] @@ -62,21 +57,21 @@ ## 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)) + (-> Type (Operation Type)) (loop [envs (: (List (List Type)) (list)) caseT caseT] (.case caseT (#.Var id) - (do macro.Monad<Meta> - [?caseT' (typeA.with-env + (do ///.Monad<Operation> + [?caseT' (//type.with-env (tc.read id))] (.case ?caseT' (#.Some caseT') (recur envs caseT') _ - (lang.throw cannot-simplify-type-for-pattern-matching caseT))) + (///.throw cannot-simplify-type-for-pattern-matching caseT))) (#.Named name unnamedT) (recur envs unnamedT) @@ -85,16 +80,16 @@ (recur (#.Cons env envs) unquantifiedT) (#.ExQ _) - (do macro.Monad<Meta> - [[ex-id exT] (typeA.with-env + (do ///.Monad<Operation> + [[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 macro.Monad<Meta> - [funcT' (typeA.with-env + (do ///.Monad<Operation> + [funcT' (//type.with-env (do tc.Monad<Check> [?funct' (tc.read funcT-id)] (.case ?funct' @@ -111,23 +106,23 @@ (recur envs outputT) #.None - (lang.throw cannot-simplify-type-for-pattern-matching caseT))) + (///.throw cannot-simplify-type-for-pattern-matching caseT))) (#.Product _) (|> caseT type.flatten-tuple (list/map (re-quantify envs)) type.tuple - (:: macro.Monad<Meta> wrap)) + (:: ///.Monad<Operation> wrap)) _ - (:: macro.Monad<Meta> wrap (re-quantify envs caseT))))) + (:: ///.Monad<Operation> 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<Meta> - [_ (typeA.with-env + (All [a] (-> Type Type Cursor Pattern (Operation a) (Operation [Pattern a]))) + (//.with-cursor cursor + (do ///.Monad<Operation> + [_ (//type.with-env (tc.check inputT type)) outputA next] (wrap [output outputA])))) @@ -149,33 +144,33 @@ ## 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]))) + (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) (.case pattern [cursor (#.Symbol ["" name])] - (lang.with-cursor cursor - (do macro.Monad<Meta> - [outputA (scopeL.with-local [name inputT] + (//.with-cursor cursor + (do ///.Monad<Operation> + [outputA (scope.with-local [name inputT] next) - idx scopeL.next-local] - (wrap [(#analysisL.Bind idx) outputA]))) + idx scope.next-local] + (wrap [(#//.Bind idx) outputA]))) (^template [<type> <input> <output>] [cursor <input>] - (analyse-primitive <type> inputT cursor (#analysisL.Simple <output>) 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]) + (analyse-primitive <type> inputT cursor (#//.Simple <output>) 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)] - (lang.with-cursor cursor - (do macro.Monad<Meta> + (//.with-cursor cursor + (do ///.Monad<Operation> [inputT' (simplify-case-type inputT)] (.case inputT' (#.Product _) @@ -195,11 +190,11 @@ (list.zip2 sub-types sub-patterns))] (do @ [[memberP+ thenA] (list/fold (: (All [a] - (-> [Type Code] (Meta [(List Pattern) a]) - (Meta [(List Pattern) 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 (Meta a) (Meta [Pattern a]))) + [[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])))) @@ -207,28 +202,28 @@ [nextA next] (wrap [(list) nextA])) (list.reverse matches))] - (wrap [(analysisL.product-pattern memberP+) + (wrap [(//.product-pattern memberP+) thenA]))) _ - (lang.throw cannot-match-type-with-pattern [inputT pattern]) + (///.throw cannot-match-type-with-pattern [inputT pattern]) ))) [cursor (#.Record record)] - (do macro.Monad<Meta> - [record (structureA.normalize record) - [members recordT] (structureA.order record) - _ (typeA.with-env + (do ///.Monad<Operation> + [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)] - (lang.with-cursor cursor + (//.with-cursor cursor (analyse-pattern #.None inputT (` ((~ pattern))) next)) (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))]) - (lang.with-cursor cursor - (do macro.Monad<Meta> + (//.with-cursor cursor + (do ///.Monad<Operation> [inputT' (simplify-case-type inputT)] (.case inputT' (#.Sum _) @@ -238,7 +233,7 @@ (.case (list.nth idx flat-sum) (^multi (#.Some case-type) (n/< num-cases idx)) - (do macro.Monad<Meta> + (do ///.Monad<Operation> [[testP nextA] (if (and (n/> num-cases size-sum) (n/= (dec num-cases) idx)) (analyse-pattern #.None @@ -246,50 +241,50 @@ (` [(~+ values)]) next) (analyse-pattern #.None case-type (` [(~+ values)]) next))] - (wrap [(analysisL.sum-pattern num-cases idx testP) + (wrap [(//.sum-pattern num-cases idx testP) nextA])) _ - (lang.throw sum-type-has-no-case [idx inputT]))) + (///.throw sum-type-has-no-case [idx inputT]))) _ - (lang.throw cannot-match-type-with-pattern [inputT pattern])))) + (///.throw cannot-match-type-with-pattern [inputT pattern])))) (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) - (lang.with-cursor cursor - (do macro.Monad<Meta> + (//.with-cursor cursor + (do ///.Monad<Operation> [tag (macro.normalize tag) [idx group variantT] (macro.resolve-tag tag) - _ (typeA.with-env + _ (//type.with-env (tc.check inputT variantT))] (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next))) _ - (lang.throw unrecognized-pattern-syntax pattern) + (///.throw unrecognized-pattern-syntax pattern) )) (def: #export (case analyse inputC branches) - (-> Analyser Code (List [Code Code]) (Meta Analysis)) + (-> Compiler Code (List [Code Code]) (Operation Analysis)) (.case branches #.Nil - (lang.throw cannot-have-empty-branches "") + (///.throw cannot-have-empty-branches "") (#.Cons [patternH bodyH] branchesT) - (do macro.Monad<Meta> - [[inputT inputA] (typeA.with-inference + (do ///.Monad<Operation> + [[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 coverageA.determine) - outputTC (monad.map @ (|>> product.left coverageA.determine) outputT) - _ (.case (monad.fold e.Monad<Error> 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]))))) + outputHC (|> outputH product.left /coverage.determine) + outputTC (monad.map @ (|>> product.left /coverage.determine) outputT) + _ (.case (monad.fold error.Monad<Error> /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/analysis/case/coverage.lux b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux index a5958001f..6a965742a 100644 --- a/stdlib/source/lux/lang/analysis/case/coverage.lux +++ b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux @@ -9,10 +9,9 @@ [maybe] text/format (coll [list "list/" Fold<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad<Meta>] - [lang] - (lang [".L" analysis #+ Pattern Variant]))) + (dictionary ["dict" unordered #+ Dict])))) + [//// "operation/" Monad<Operation>] + [/// #+ Pattern Variant Operation]) (def: cases (-> (Maybe Nat) Nat) @@ -25,18 +24,18 @@ (case variantP (#.Left valueP) (case valueP - (#analysisL.Complex (#analysisL.Sum value-side)) + (#///.Complex (#///.Sum value-side)) (recur (inc lefts) value-side) _ - {#analysisL.lefts lefts - #analysisL.right? false - #analysisL.value valueP}) + {#///.lefts lefts + #///.right? false + #///.value valueP}) (#.Right valueP) - {#analysisL.lefts lefts - #analysisL.right? true - #analysisL.value 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 @@ -68,33 +67,33 @@ false)) (def: #export (determine pattern) - (-> Pattern (Meta Coverage)) + (-> Pattern (Operation Coverage)) (case pattern - (^or (#analysisL.Simple #analysisL.Unit) - (#analysisL.Bind _)) - (macro/wrap #Exhaustive) + (^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 [<tag>] - (#analysisL.Simple (<tag> _)) - (macro/wrap #Partial)) - ([#analysisL.Nat] - [#analysisL.Int] - [#analysisL.Deg] - [#analysisL.Frac] - [#analysisL.Text]) + (#///.Simple (<tag> _)) + (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. - (#analysisL.Simple (#analysisL.Bool value)) - (macro/wrap (#Bool value)) + (#///.Simple (#///.Bool value)) + (operation/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<Meta> + (#///.Complex (#///.Product [left right])) + (do ////.Monad<Operation> [left (determine left) right (determine right)] (case right @@ -104,11 +103,11 @@ _ (wrap (#Seq left right)))) - (#analysisL.Complex (#analysisL.Sum sum-side)) + (#///.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 macro.Monad<Meta> + (do ////.Monad<Operation> [value-coverage (determine variant-value) #let [variant-idx (if variant-right? (inc variant-lefts) 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 [<name>] + [(exception: #export (<name> {code Code}) + (%code code))] + + [macro-call-must-have-single-expansion] + [unrecognized-syntax] + ) + +(def: #export (analyser eval) + (-> Eval Compiler) + (function (compile code) + (do ///.Monad<Operation> + [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 [<tag> <analyser>] + (<tag> value) + (<analyser> value)) + ([#.Bool //primitive.bool] + [#.Nat //primitive.nat] + [#.Int //primitive.int] + [#.Deg //primitive.deg] + [#.Frac //primitive.frac] + [#.Text //primitive.text]) + + (^template [<tag> <analyser>] + (^ (#.Form (list& [_ (<tag> tag)] + values))) + (case values + (#.Cons value #.Nil) + (<analyser> compile tag value) + + _ + (<analyser> 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<Operation> + ## [extension (extensionL.find-analysis extension-name)] + ## (extension compile eval extension-args)) + + ## (^ (#.Form (list& func args))) + ## (do ///.Monad<Operation> + ## [[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/analysis/function.lux b/stdlib/source/lux/lang/compiler/analysis/function.lux index f6fea9bb0..b6e09f11a 100644 --- a/stdlib/source/lux/lang/analysis/function.lux +++ b/stdlib/source/lux/lang/compiler/analysis/function.lux @@ -8,13 +8,13 @@ (coll [list "list/" Fold<List> Monoid<List> Monad<List>])) [macro] (macro [code]) - [lang] (lang [type] (type ["tc" check]) - [".L" scope] - [".L" analysis #+ Analysis Analyser] - (analysis [".A" type] - [".A" inference])))) + [".L" scope])) + [///] + [// #+ Analysis Compiler] + [//type] + [//inference]) (exception: #export (cannot-analyse {expected Type} {function Text} {argument Text} {body Code}) (ex.report ["Type" (%type expected)] @@ -30,13 +30,12 @@ (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)) + (-> Compiler Text Text Code (Meta Analysis)) (do macro.Monad<Meta> [functionT macro.expected-type] (loop [expectedT functionT] - (lang.with-stacked-errors + (///.with-stacked-errors (.function (_ _) (ex.construct cannot-analyse [expectedT function-name arg-name body])) (case expectedT @@ -49,56 +48,56 @@ (recur value) #.None - (lang.fail (ex.construct cannot-analyse [expectedT function-name arg-name body]))) + (///.fail (ex.construct cannot-analyse [expectedT function-name arg-name body]))) (^template [<tag> <instancer>] (<tag> _) (do @ - [[_ instanceT] (typeA.with-env <instancer>)] + [[_ instanceT] (//type.with-env <instancer>)] (recur (maybe.assume (type.apply (list instanceT) expectedT))))) ([#.UnivQ tc.existential] [#.ExQ tc.var]) (#.Var id) (do @ - [?expectedT' (typeA.with-env + [?expectedT' (//type.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) + [[input-id inputT] (//type.with-env tc.var) + [output-id outputT] (//type.with-env tc.var) #let [functionT (#.Function inputT outputT)] functionA (recur functionT) - _ (typeA.with-env + _ (//type.with-env (tc.check expectedT functionT))] (wrap functionA)) )) (#.Function inputT outputT) (<| (:: @ map (.function (_ [scope bodyA]) - (#analysisL.Function (scopeL.environment scope) bodyA))) - lang.with-scope + (#//.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]) - (typeA.with-type outputT) + (//type.with-type outputT) (analyse body)) _ - (lang.fail "") + (///.fail "") ))))) (def: #export (apply analyse functionT functionA args) - (-> Analyser Type Analysis (List Code) (Meta Analysis)) - (lang.with-stacked-errors + (-> Compiler Type Analysis (List Code) (Meta Analysis)) + (///.with-stacked-errors (.function (_ _) (ex.construct cannot-apply [functionT args])) (do macro.Monad<Meta> - [[applyT argsA] (inferenceA.general analyse functionT args)] - (wrap (analysisL.apply [functionA argsA]))))) + [[applyT argsA] (//inference.general analyse functionT args)] + (wrap (//.apply [functionA argsA]))))) diff --git a/stdlib/source/lux/lang/analysis/inference.lux b/stdlib/source/lux/lang/compiler/analysis/inference.lux index 732a8e6e3..abf1529d6 100644 --- a/stdlib/source/lux/lang/analysis/inference.lux +++ b/stdlib/source/lux/lang/compiler/analysis/inference.lux @@ -6,16 +6,16 @@ [text] text/format (coll [list "list/" Functor<List>])) - [macro "macro/" Monad<Meta>] - [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}) + [macro]) + (//// [type] + (type ["tc" check])) + [/// #+ "operation/" Monad<Operation>] + [// #+ 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" (%n size)] + ["Variant size" (%i (.int size))] ["Variant type" (%type type)])) (exception: #export (cannot-infer {type Type} {args (List Code)}) @@ -43,16 +43,16 @@ [invalid-type-application] ) -(def: (replace-bound bound-idx replacementT type) +(def: (replace bound-idx replacement type) (-> Nat Type Type Type) (case type (#.Primitive name params) - (#.Primitive name (list/map (replace-bound bound-idx replacementT) params)) + (#.Primitive name (list/map (replace bound-idx replacement) params)) (^template [<tag>] (<tag> left right) - (<tag> (replace-bound bound-idx replacementT left) - (replace-bound bound-idx replacementT right))) + (<tag> (replace bound-idx replacement left) + (replace bound-idx replacement right))) ([#.Sum] [#.Product] [#.Function] @@ -60,13 +60,13 @@ (#.Bound idx) (if (n/= bound-idx idx) - replacementT + replacement type) (^template [<tag>] (<tag> env quantified) - (<tag> (list/map (replace-bound bound-idx replacementT) env) - (replace-bound (n/+ +2 bound-idx) replacementT quantified))) + (<tag> (list/map (replace bound-idx replacement) env) + (replace (n/+ +2 bound-idx) replacement quantified))) ([#.UnivQ] [#.ExQ]) @@ -74,13 +74,13 @@ type)) (def: new-named-type - (Meta Type) - (do macro.Monad<Meta> - [[_module _line _column] macro.cursor - [ex-id exT] (typeA.with-env tc.existential)] - (wrap (#.Primitive (format "{New Type @ " (%t _module) - "," (%n _line) - "," (%n _column) + (Operation Type) + (do ///.Monad<Operation> + [[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))))) @@ -92,11 +92,11 @@ ## 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)])) + (-> Compiler Type (List Code) (Operation [Type (List Analysis)])) (case args #.Nil - (do macro.Monad<Meta> - [_ (typeA.infer inferT)] + (do ///.Monad<Operation> + [_ (//type.infer inferT)] (wrap [inferT (list)])) (#.Cons argC args') @@ -105,23 +105,23 @@ (general analyse unnamedT args) (#.UnivQ _) - (do macro.Monad<Meta> - [[var-id varT] (typeA.with-env tc.var)] + (do ///.Monad<Operation> + [[var-id varT] (//type.with-env tc.var)] (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) (#.ExQ _) - (do macro.Monad<Meta> - [[var-id varT] (typeA.with-env tc.var) + (do ///.Monad<Operation> + [[var-id varT] (//type.with-env tc.var) output (general analyse (maybe.assume (type.apply (list varT) inferT)) args) - bound? (typeA.with-env + bound? (//type.with-env (tc.bound? var-id)) _ (if bound? (wrap []) (do @ [newT new-named-type] - (typeA.with-env + (//type.with-env (tc.check varT newT))))] (wrap output)) @@ -131,7 +131,7 @@ (general analyse outputT args) #.None - (lang.throw invalid-type-application inferT)) + (///.throw invalid-type-application inferT)) ## Arguments are inferred back-to-front because, by convention, ## Lux functions take the most important arguments *last*, which @@ -141,39 +141,39 @@ ## avoided in Lux code, since the inference algorithm can piece ## things together more easily. (#.Function inputT outputT) - (do macro.Monad<Meta> + (do ///.Monad<Operation> [[outputT' args'A] (general analyse outputT args') - argA (lang.with-stacked-errors + argA (///.with-stacked-errors (function (_ _) (ex.construct cannot-infer-argument [inputT argC])) - (typeA.with-type inputT + (//type.with-type inputT (analyse argC)))] (wrap [outputT' (list& argA args'A)])) (#.Var infer-id) - (do macro.Monad<Meta> - [?inferT' (typeA.with-env (tc.read infer-id))] + (do ///.Monad<Operation> + [?inferT' (//type.with-env (tc.read infer-id))] (case ?inferT' (#.Some inferT') (general analyse inferT' args) _ - (lang.throw cannot-infer [inferT args]))) + (///.throw cannot-infer [inferT args]))) _ - (lang.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 (Meta Type)) + (-> Type (Operation Type)) (case inferT (#.Named name unnamedT) (record unnamedT) (^template [<tag>] (<tag> env bodyT) - (do macro.Monad<Meta> + (do ///.Monad<Operation> [bodyT+ (record bodyT)] (wrap (<tag> env bodyT+)))) ([#.UnivQ] @@ -185,28 +185,28 @@ (record outputT) #.None - (lang.throw invalid-type-application inferT)) + (///.throw invalid-type-application inferT)) (#.Product _) - (macro/wrap (type.function (type.flatten-tuple inferT) inferT)) + (operation/wrap (type.function (type.flatten-tuple inferT) inferT)) _ - (lang.throw not-a-record-type 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 (Meta Type)) + (-> Nat Nat Type (Operation Type)) (loop [depth +0 currentT inferT] (case currentT (#.Named name unnamedT) - (do macro.Monad<Meta> + (do ///.Monad<Operation> [unnamedT+ (recur depth unnamedT)] (wrap unnamedT+)) (^template [<tag>] (<tag> env bodyT) - (do macro.Monad<Meta> + (do ///.Monad<Operation> [bodyT+ (recur (inc depth) bodyT)] (wrap (<tag> env bodyT+)))) ([#.UnivQ] @@ -221,28 +221,28 @@ (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))))) + (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 - (lang.throw variant-tag-out-of-bounds [expected-size tag inferT])) + (///.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]) + (///.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)))))) + (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 - (lang.throw variant-tag-out-of-bounds [expected-size tag inferT]))) + (///.throw variant-tag-out-of-bounds [expected-size tag inferT]))) (#.Apply inputT funcT) (case (type.apply (list inputT) funcT) @@ -250,7 +250,7 @@ (variant tag expected-size outputT) #.None - (lang.throw invalid-type-application inferT)) + (///.throw invalid-type-application inferT)) _ - (lang.throw not-a-variant-type inferT)))) + (///.throw not-a-variant-type inferT)))) diff --git a/stdlib/source/lux/lang/analysis/primitive.lux b/stdlib/source/lux/lang/compiler/analysis/primitive.lux index 74596fba2..74596fba2 100644 --- a/stdlib/source/lux/lang/analysis/primitive.lux +++ b/stdlib/source/lux/lang/compiler/analysis/primitive.lux diff --git a/stdlib/source/lux/lang/analysis/reference.lux b/stdlib/source/lux/lang/compiler/analysis/reference.lux index cceb4db7d..6f4908f9d 100644 --- a/stdlib/source/lux/lang/analysis/reference.lux +++ b/stdlib/source/lux/lang/compiler/analysis/reference.lux @@ -4,15 +4,16 @@ [macro] (macro [code]) (lang (type ["tc" check]))) - [// #+ Analysis] + [///] + [// #+ Analysis Operation] [//type] - [///reference] - [///scope]) + [////reference] + [////scope]) ## [Analysers] (def: (definition def-name) - (-> Ident (Meta Analysis)) - (do macro.Monad<Meta> + (-> Ident (Operation Analysis)) + (do ///.Monad<Operation> [[actualT def-anns _] (macro.find-def def-name)] (case (macro.get-symbol-ann (ident-for #.alias) def-anns) (#.Some real-def-name) @@ -21,27 +22,27 @@ _ (do @ [_ (//type.infer actualT)] - (:: @ map (|>> ///reference.constant #//.Reference) + (:: @ map (|>> ////reference.constant #//.Reference) (macro.normalize def-name)))))) (def: (variable var-name) - (-> Text (Meta (Maybe Analysis))) - (do macro.Monad<Meta> - [?var (///scope.find var-name)] + (-> Text (Operation (Maybe Analysis))) + (do ///.Monad<Operation> + [?var (////scope.find var-name)] (case ?var (#.Some [actualT ref]) (do @ [_ (//type.infer actualT)] - (wrap (#.Some (|> ref ///reference.variable #//.Reference)))) + (wrap (#.Some (|> ref ////reference.variable #//.Reference)))) #.None (wrap #.None)))) (def: #export (reference reference) - (-> Ident (Meta Analysis)) + (-> Ident (Operation Analysis)) (case reference ["" simple-name] - (do macro.Monad<Meta> + (do ///.Monad<Operation> [?var (variable simple-name)] (case ?var (#.Some varA) diff --git a/stdlib/source/lux/lang/analysis/structure.lux b/stdlib/source/lux/lang/compiler/analysis/structure.lux index bc527cd49..78b36bc32 100644 --- a/stdlib/source/lux/lang/analysis/structure.lux +++ b/stdlib/source/lux/lang/compiler/analysis/structure.lux @@ -10,16 +10,16 @@ (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}) + (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)])) @@ -37,7 +37,7 @@ (%type type)) (do-template [<name>] - [(exception: #export (<name> {type Type} {tag analysis.Tag} {code Code}) + [(exception: #export (<name> {type Type} {tag Tag} {code Code}) (ex.report ["Type" (%type type)] ["Tag" (%n tag)] ["Expression" (%code code)]))] @@ -74,10 +74,10 @@ code.record))])) (def: #export (sum analyse tag valueC) - (-> Analyser Nat Code (Meta Analysis)) - (do macro.Monad<Meta> + (-> Compiler Nat Code (Operation Analysis)) + (do ///.Monad<Operation> [expectedT macro.expected-type] - (lang.with-stacked-errors + (///.with-stacked-errors (function (_ _) (ex.construct cannot-analyse-variant [expectedT tag valueC])) (case expectedT @@ -87,38 +87,38 @@ (case (list.nth tag flat) (#.Some variant-type) (do @ - [valueA (typeA.with-type variant-type + [valueA (//type.with-type variant-type (analyse valueC))] - (wrap (analysis.sum-analysis type-size tag valueA))) + (wrap (//.sum-analysis type-size tag valueA))) #.None - (lang.throw inferenceA.variant-tag-out-of-bounds [type-size tag expectedT]))) + (///.throw //inference.variant-tag-out-of-bounds [type-size tag expectedT]))) (#.Named name unnamedT) - (typeA.with-type unnamedT + (//type.with-type unnamedT (sum analyse tag valueC)) (#.Var id) (do @ - [?expectedT' (typeA.with-env + [?expectedT' (//type.with-env (tc.read id))] (case ?expectedT' (#.Some expectedT') - (typeA.with-type 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. - (lang.throw cannot-infer-numeric-tag [expectedT tag valueC]) + (///.throw cannot-infer-numeric-tag [expectedT tag valueC]) )) (^template [<tag> <instancer>] (<tag> _) (do @ - [[instance-id instanceT] (typeA.with-env <instancer>)] - (typeA.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + [[instance-id instanceT] (//type.with-env <instancer>)] + (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) (sum analyse tag valueC)))) ([#.UnivQ tc.existential] [#.ExQ tc.var]) @@ -127,30 +127,30 @@ (case funT (#.Var funT-id) (do @ - [?funT' (typeA.with-env (tc.read funT-id))] + [?funT' (//type.with-env (tc.read funT-id))] (case ?funT' (#.Some funT') - (typeA.with-type (#.Apply inputT funT') + (//type.with-type (#.Apply inputT funT') (sum analyse tag valueC)) _ - (lang.throw invalid-variant-type [expectedT tag valueC]))) + (///.throw invalid-variant-type [expectedT tag valueC]))) _ (case (type.apply (list inputT) funT) #.None - (lang.throw not-a-quantified-type funT) + (///.throw not-a-quantified-type funT) (#.Some outputT) - (typeA.with-type outputT + (//type.with-type outputT (sum analyse tag valueC)))) _ - (lang.throw invalid-variant-type [expectedT tag valueC]))))) + (///.throw invalid-variant-type [expectedT tag valueC]))))) (def: (typed-product analyse membersC+) - (-> Analyser (List Code) (Meta Analysis)) - (do macro.Monad<Meta> + (-> Compiler (List Code) (Operation Analysis)) + (do ///.Monad<Operation> [expectedT macro.expected-type] (loop [expectedT expectedT membersC+ membersC+] @@ -158,17 +158,17 @@ ## If the tuple runs out, whatever expression is the last gets ## matched to the remaining type. [tailT (#.Cons tailC #.Nil)] - (typeA.with-type tailT + (//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 (typeA.with-type leftT + [leftA (//type.with-type leftT (analyse leftC)) rightA (recur rightT rightC)] - (wrap (#analysis.Structure (#analysis.Product leftA rightA)))) + (wrap (#//.Structure (#//.Product leftA rightA)))) ## If, however, the type runs out but there is still enough ## tail, the remaining elements get packaged into another @@ -184,14 +184,14 @@ (|> tailC code.tuple analyse - (typeA.with-type tailT) - (:: @ map (|>> analysis.no-op))))))) + (//type.with-type tailT) + (:: @ map (|>> //.no-op))))))) (def: #export (product analyse membersC) - (-> Analyser (List Code) (Meta Analysis)) - (do macro.Monad<Meta> + (-> Compiler (List Code) (Operation Analysis)) + (do ///.Monad<Operation> [expectedT macro.expected-type] - (lang.with-stacked-errors + (///.with-stacked-errors (function (_ _) (ex.construct cannot-analyse-tuple [expectedT membersC])) (case expectedT @@ -199,33 +199,33 @@ (..typed-product analyse membersC) (#.Named name unnamedT) - (typeA.with-type unnamedT + (//type.with-type unnamedT (product analyse membersC)) (#.Var id) (do @ - [?expectedT' (typeA.with-env + [?expectedT' (//type.with-env (tc.read id))] (case ?expectedT' (#.Some expectedT') - (typeA.with-type expectedT' + (//type.with-type expectedT' (product analyse membersC)) _ ## Must do inference... (do @ - [membersTA (monad.map @ (|>> analyse typeA.with-inference) + [membersTA (monad.map @ (|>> analyse //type.with-inference) membersC) - _ (typeA.with-env + _ (//type.with-env (tc.check expectedT (type.tuple (list/map product.left membersTA))))] - (wrap (analysis.product-analysis (list/map product.right membersTA)))))) + (wrap (//.product-analysis (list/map product.right membersTA)))))) (^template [<tag> <instancer>] (<tag> _) (do @ - [[instance-id instanceT] (typeA.with-env <instancer>)] - (typeA.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + [[instance-id instanceT] (//type.with-env <instancer>)] + (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) (product analyse membersC)))) ([#.UnivQ tc.existential] [#.ExQ tc.var]) @@ -234,31 +234,31 @@ (case funT (#.Var funT-id) (do @ - [?funT' (typeA.with-env (tc.read funT-id))] + [?funT' (//type.with-env (tc.read funT-id))] (case ?funT' (#.Some funT') - (typeA.with-type (#.Apply inputT funT') + (//type.with-type (#.Apply inputT funT') (product analyse membersC)) _ - (lang.throw invalid-tuple-type [expectedT membersC]))) + (///.throw invalid-tuple-type [expectedT membersC]))) _ (case (type.apply (list inputT) funT) #.None - (lang.throw not-a-quantified-type funT) + (///.throw not-a-quantified-type funT) (#.Some outputT) - (typeA.with-type outputT + (//type.with-type outputT (product analyse membersC)))) _ - (lang.throw invalid-tuple-type [expectedT membersC]) + (///.throw invalid-tuple-type [expectedT membersC]) )))) (def: #export (tagged-sum analyse tag valueC) - (-> Analyser Ident Code (Meta Analysis)) - (do macro.Monad<Meta> + (-> Compiler Ident Code (Operation Analysis)) + (do ///.Monad<Operation> [tag (macro.normalize tag) [idx group variantT] (macro.resolve-tag tag) expectedT macro.expected-type] @@ -266,9 +266,9 @@ (#.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)))) + 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)))) @@ -278,38 +278,38 @@ ## 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<Meta> + (-> (List [Code Code]) (Operation (List [Ident Code]))) + (monad.map ///.Monad<Operation> (function (_ [key val]) (case key [_ (#.Tag key)] - (do macro.Monad<Meta> + (do ///.Monad<Operation> [key (macro.normalize key)] (wrap [key val])) _ - (lang.throw record-keys-must-be-tags [key record]))) + (///.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])) + (-> (List [Ident Code]) (Operation [(List Code) Type])) (case record ## empty-record = empty-tuple = unit = [] #.Nil - (:: macro.Monad<Meta> wrap [(list) Any]) + (:: ///.Monad<Operation> wrap [(list) Any]) (#.Cons [head-k head-v] _) - (do macro.Monad<Meta> + (do ///.Monad<Operation> [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])) + (///.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<Ident> (list.zip2 tag-set tuple-range))] idx->val (monad.fold @ @@ -318,11 +318,11 @@ [key (macro.normalize key)] (case (dict.get key tag->idx) #.None - (lang.throw tag-does-not-belong-to-record [key recordT]) + (///.throw tag-does-not-belong-to-record [key recordT]) (#.Some idx) (if (dict.contains? idx idx->val) - (lang.throw cannot-repeat-tag [key record]) + (///.throw cannot-repeat-tag [key record]) (wrap (dict.put idx val idx->val)))))) (: (Dict Nat Code) (dict.new number.Hash<Nat>)) @@ -333,13 +333,13 @@ )) (def: #export (record analyse members) - (-> Analyser (List [Code Code]) (Meta Analysis)) - (do macro.Monad<Meta> + (-> Compiler (List [Code Code]) (Operation Analysis)) + (do ///.Monad<Operation> [members (normalize members) [membersC recordT] (order members)] (case membersC (^ (list)) - primitiveA.unit + //primitive.unit (^ (list singletonC)) (analyse singletonC) @@ -350,9 +350,9 @@ (case expectedT (#.Var _) (do @ - [inferenceT (inferenceA.record recordT) - [inferredT membersA] (inferenceA.general analyse inferenceT membersC)] - (wrap (analysis.product-analysis membersA))) + [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/analysis/type.lux b/stdlib/source/lux/lang/compiler/analysis/type.lux index a7f9b3b29..9fcfb2743 100644 --- a/stdlib/source/lux/lang/analysis/type.lux +++ b/stdlib/source/lux/lang/compiler/analysis/type.lux @@ -1,56 +1,57 @@ (.module: lux (lux (control [monad #+ do]) - (data ["e" error]) + (data [error]) [macro] - [lang] - (lang (type ["tc" check])))) + (lang (type ["tc" check]))) + [///] + [// #+ Operation]) (def: #export (with-type expected action) - (All [a] (-> Type (Meta a) (Meta a))) + (All [a] (-> Type (Operation a) (Operation a))) (function (_ compiler) (case (action (set@ #.expected (#.Some expected) compiler)) - (#e.Success [compiler' output]) + (#error.Success [compiler' output]) (let [old-expected (get@ #.expected compiler)] - (#e.Success [(set@ #.expected old-expected compiler') - output])) + (#error.Success [(set@ #.expected old-expected compiler') + output])) - (#e.Error error) - (#e.Error error)))) + (#error.Error error) + (#error.Error error)))) (def: #export (with-env action) - (All [a] (-> (tc.Check a) (Meta a))) + (All [a] (-> (tc.Check a) (Operation a))) (function (_ compiler) (case (action (get@ #.type-context compiler)) - (#e.Error error) - ((lang.fail error) compiler) + (#error.Error error) + ((///.fail error) compiler) - (#e.Success [context' output]) - (#e.Success [(set@ #.type-context context' compiler) - output])))) + (#error.Success [context' output]) + (#error.Success [(set@ #.type-context context' compiler) + output])))) (def: #export (with-fresh-env action) - (All [a] (-> (Meta a) (Meta a))) + (All [a] (-> (Operation a) (Operation 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]) + (#error.Success [compiler' output]) + (#error.Success [(set@ #.type-context old compiler') + output]) output output)))) (def: #export (infer actualT) - (-> Type (Meta Any)) - (do macro.Monad<Meta> + (-> Type (Operation Any)) + (do ///.Monad<Operation> [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<Meta> + (All [a] (-> (Operation a) (Operation [Type a]))) + (do ///.Monad<Operation> [[_ varT] (..with-env tc.var) output (with-type varT 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 [<Bundle> (as-is (Dict Text (-> Text (Handler s i o))))] + (type: #export (Handler s i o) + (-> (Compiler [s <Bundle>] (Extension i) (Extension o)) + (Compiler [s <Bundle>] (List (Extension i)) (Extension o)))) + + (type: #export (Bundle s i o) + <Bundle>)) + +(do-template [<name>] + [(exception: #export (<name> {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<Error> + [[stateB' output] (compiler input' stateB)] + (wrap [[stateB' bundle] (#Base output)])) + + (#Extension name parameters) + (case (dict.get name bundle) + (#.Some handler) + (do error.Monad<Error> + [[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<Text>)) diff --git a/stdlib/source/lux/lang/extension/analysis.lux b/stdlib/source/lux/lang/compiler/extension/analysis.lux index b412e28df..77439643e 100644 --- a/stdlib/source/lux/lang/extension/analysis.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis.lux @@ -3,12 +3,14 @@ (lux (data [text] (coll [list "list/" Functor<List>] (dictionary ["dict" unordered #+ Dict])))) + [///analysis #+ Analysis State] + [///synthesis #+ Synthesis] [//] [/common] [/host]) (def: #export defaults - (//.Extension //.Analysis) + (//.Bundle State Analysis Synthesis) (|> /common.extensions (dict.merge /host.extensions) dict.entries 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<List>] + [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<Operation> + [_ (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<Operation> + [[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<Operation> + [[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 [<name> <type>] +## [(def: (<name> extension) +## (-> Text ..Handler) +## (function (_ analyse args) +## (case args +## (^ (list typeC valueC)) +## (do compiler.Monad<Operation> +## [actualT (eval Type typeC) +## _ (typeA.infer (:! Type actualT))] +## (typeA.with-type <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<Operation> + [_ (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<Operation> + [[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<Operation> + [[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<Operation> + [[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<Operation> + [[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<Operation> + [[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<Operation> + [[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<Operation> + [[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<Operation> + [[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<Operation> + [[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/extension/analysis/host.jvm.lux b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux index 56da166c5..56da166c5 100644 --- a/stdlib/source/lux/lang/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux 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<List>] + (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<Text>))) diff --git a/stdlib/source/lux/lang/extension/synthesis.lux b/stdlib/source/lux/lang/compiler/extension/synthesis.lux index c48f3e3a5..c48f3e3a5 100644 --- a/stdlib/source/lux/lang/extension/synthesis.lux +++ b/stdlib/source/lux/lang/compiler/extension/synthesis.lux diff --git a/stdlib/source/lux/lang/extension/translation.lux b/stdlib/source/lux/lang/compiler/extension/translation.lux index bc95ed1f4..bc95ed1f4 100644 --- a/stdlib/source/lux/lang/extension/translation.lux +++ b/stdlib/source/lux/lang/compiler/extension/translation.lux 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/synthesis.lux b/stdlib/source/lux/lang/compiler/synthesis.lux index 1bf06cdd0..eece3c7ab 100644 --- a/stdlib/source/lux/lang/synthesis.lux +++ b/stdlib/source/lux/lang/compiler/synthesis.lux @@ -3,10 +3,9 @@ (lux (control [monad #+ do]) (data [error #+ Error] (coll (dictionary ["dict" unordered #+ Dict])))) - [// #+ Extension] - [//reference #+ Register Variable Reference] - [//analysis #+ Environment Arity Analysis] - [//compiler #+ Operation Compiler]) + [///reference #+ Register Variable Reference] + [// #+ Operation Compiler] + [//analysis #+ Environment Arity Analysis]) (type: #export Resolver (Dict Variable Variable)) @@ -18,7 +17,7 @@ (def: #export fresh-resolver Resolver - (dict.new //reference.Hash<Variable>)) + (dict.new ///reference.Hash<Variable>)) (def: #export init State @@ -88,8 +87,7 @@ (#Primitive Primitive) (#Structure (Structure Synthesis)) (#Reference Reference) - (#Control (Control Synthesis)) - (#Extension (Extension Synthesis))) + (#Control (Control Synthesis))) (type: #export Path (Path' Synthesis)) @@ -151,7 +149,7 @@ (do-template [<name> <value>] [(def: #export <name> (All [a] (-> (Operation ..State a) (Operation ..State a))) - (//compiler.localized (set@ #direct? <value>)))] + (//.localized (set@ #direct? <value>)))] [indirectly false] [directly true] @@ -160,7 +158,7 @@ (do-template [<name> <type> <tag>] [(def: #export (<name> value) (-> <type> (All [a] (-> (Operation ..State a) (Operation ..State a)))) - (//compiler.localized (set@ <tag> value)))] + (//.localized (set@ <tag> value)))] [with-scope-arity Arity #scope-arity] [with-resolver Resolver #resolver] @@ -171,10 +169,10 @@ (All [o] (-> Arity Resolver (-> (Operation ..State o) (Operation ..State o)))) - (//compiler.with-state {#scope-arity arity - #resolver resolver - #direct? true - #locals arity})) + (//.with-state {#scope-arity arity + #resolver resolver + #direct? true + #locals arity})) (do-template [<name> <tag> <type>] [(def: #export <name> @@ -190,7 +188,7 @@ (def: #export with-new-local (All [a] (-> (Operation ..State a) (Operation ..State a))) - (<<| (do //compiler.Monad<Operation> + (<<| (do //.Monad<Operation> [locals ..locals]) (..with-locals (inc locals)))) @@ -220,8 +218,8 @@ <tag> content))] - [variable/local //reference.local] - [variable/foreign //reference.foreign] + [variable/local ///reference.local] + [variable/foreign ///reference.foreign] ) (do-template [<name> <family> <tag>] diff --git a/stdlib/source/lux/lang/synthesis/case.lux b/stdlib/source/lux/lang/compiler/synthesis/case.lux index b7f224168..b7f224168 100644 --- a/stdlib/source/lux/lang/synthesis/case.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/case.lux diff --git a/stdlib/source/lux/lang/synthesis/expression.lux b/stdlib/source/lux/lang/compiler/synthesis/expression.lux index 52ea33805..52ea33805 100644 --- a/stdlib/source/lux/lang/synthesis/expression.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/expression.lux diff --git a/stdlib/source/lux/lang/synthesis/function.lux b/stdlib/source/lux/lang/compiler/synthesis/function.lux index 35b9e047e..35b9e047e 100644 --- a/stdlib/source/lux/lang/synthesis/function.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/function.lux diff --git a/stdlib/source/lux/lang/synthesis/loop.lux b/stdlib/source/lux/lang/compiler/synthesis/loop.lux index eb57eb7ad..eb57eb7ad 100644 --- a/stdlib/source/lux/lang/synthesis/loop.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/loop.lux diff --git a/stdlib/source/lux/lang/translation.lux b/stdlib/source/lux/lang/compiler/translation.lux index c117bc019..c117bc019 100644 --- a/stdlib/source/lux/lang/translation.lux +++ b/stdlib/source/lux/lang/compiler/translation.lux diff --git a/stdlib/source/lux/lang/translation/scheme/case.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux index e5d12a005..e5d12a005 100644 --- a/stdlib/source/lux/lang/translation/scheme/case.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux index 96bb17126..96bb17126 100644 --- a/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux index 6475caf68..6475caf68 100644 --- a/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux index 140045aaf..140045aaf 100644 --- a/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/function.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux index 11c64076c..11c64076c 100644 --- a/stdlib/source/lux/lang/translation/scheme/function.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux index 6f305336e..6f305336e 100644 --- a/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux index ac775fa82..ac775fa82 100644 --- a/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux index 453d4edb6..453d4edb6 100644 --- a/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux index b30aff3a2..b30aff3a2 100644 --- a/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux index a11434594..a11434594 100644 --- a/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux 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 [<name>] - [(exception: #export (<name> {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<Text>) - #synthesis (dict.new text.Hash<Text>) - #translation (dict.new text.Hash<Text>) - #statement (dict.new text.Hash<Text>)}) - -(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 [<name> <type> <category> <exception>] - [(def: #export (<name> name) - (-> Text (Meta <type>)) - (do //compiler.Monad<Operation> - [extensions ..get] - (case (dict.get name (get@ <category> extensions)) - (#.Some extension) - (wrap extension) - - #.None - (//compiler.throw <exception> 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<Text>)) - -(do-template [<params> <all> <state> <type> <category>] - [(def: #export <all> - (All <params> (Operation <state> (Extension <type>))) - (|> ..get - (:: //compiler.Monad<Operation> map (get@ <category>))))] - - [[] 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 [<name> <type> <category> <exception>] - [(def: #export (<name> name extension) - (-> Text <type> (Meta Any)) - (do //compiler.Monad<Operation> - [extensions ..get - _ (if (not (dict.contains? name (get@ <category> extensions))) - (wrap []) - (//compiler.throw <exception> name)) - _ (..set (update@ <category> (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/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<List>] - [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<Text>))) - -(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<Meta> - [_ (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<Meta> - [[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<Meta> - [[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 [<name> <type>] - [(def: (<name> proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) - (case args - (^ (list typeC valueC)) - (do macro.Monad<Meta> - [actualT (eval Type typeC) - _ (typeA.infer (:! Type actualT))] - (typeA.with-type <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<Meta> - [_ (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<Text>) - (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<Text>) - (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<Text>) - (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<Text>) - (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<Text>) - (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<Text>) - (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<Text>) - (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<Meta> - [[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<Meta> - [[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<Meta> - [[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<Text>) - (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<Text>) - (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<Meta> - [[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<Meta> - [[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<Meta> - [[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<Text>) - (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<Meta> - [[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<Meta> - [[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<Meta> - [[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<Text>) - (install "new" box//new) - (install "read" box//read) - (install "write" box//write) - ))) - -(def: process-procs - Bundle - (<| (prefix "process") - (|> (dict.new text.Hash<Text>) - (install "parallelism-level" (nullary Nat)) - (install "schedule" (binary Nat (type (io.IO Any)) Any)) - ))) - -(def: #export extensions - Bundle - (<| (prefix "lux") - (|> (dict.new text.Hash<Text>) - (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/target.lux b/stdlib/source/lux/lang/host.lux index ee0eee74d..218de67a4 100644 --- a/stdlib/source/lux/lang/target.lux +++ b/stdlib/source/lux/lang/host.lux @@ -1,10 +1,10 @@ (.module: lux) -(type: #export Target Text) +(type: #export Host Text) (do-template [<name> <value>] - [(def: #export <name> Target <value>)] + [(def: #export <name> Host <value>)] [common-lisp "Common Lisp"] [js "JavaScript"] 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<List> Functor<List>] (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 [<name>] [(exception: #export (<name> {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<Meta> [_ (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 <tag> module)) compiler) []]) - ((//.throw can-only-change-state-of-active-module [module-name <tag>]) + ((//compiler.throw can-only-change-state-of-active-module [module-name <tag>]) compiler))) #.None - ((//.throw unknown-module module-name) compiler)))) + ((//compiler.throw unknown-module module-name) compiler)))) (def: #export (<asker> 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@ <tag> 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/test/test/lux/lang/analysis/case.lux b/stdlib/test/test/lux/lang/compiler/analysis/case.lux index 9e775f8a3..d2836558e 100644 --- a/stdlib/test/test/lux/lang/analysis/case.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/case.lux @@ -14,12 +14,12 @@ ["r" math/random "r/" Monad<Random>] [macro #+ Monad<Meta>] (macro [code]) - [lang] (lang [type "type/" Eq<Type>] (type ["tc" check]) [".L" module] - (analysis [".A" type] - ["/" case])) + (compiler [analysis] + (analysis [".A" type] + ["/" case]))) test) (// ["_." primitive] ["_." structure])) @@ -145,8 +145,8 @@ variantTC (list.zip2 variant-tags+ primitivesC)] inputC (input variant-tags+ record-tags+ primitivesC) [outputT outputC] _primitive.primitive - [heterogeneousT heterogeneousC] (|> _primitive.primitive - (r.filter (|>> product.left (tc.checks? outputT) not))) + [heterogeneousT heterogeneousC] (r.filter (|>> product.left (tc.checks? outputT) not) + _primitive.primitive) exhaustive-patterns (exhaustive-branches true variantTC inputC) redundant-patterns (exhaustive-branches false variantTC inputC) redundancy-idx (|> r.nat (:: @ map (n/% (list.size redundant-patterns)))) @@ -166,7 +166,7 @@ (list.drop (inc heterogeneous-idx) exhaustive-branchesC))) analyse-pm (|>> (/.case _primitive.analyse inputC) (typeA.with-type outputT) - lang.with-scope + analysis.with-scope (do Monad<Meta> [_ (moduleL.declare-tags variant-tags false (#.Named [module-name variant-name] @@ -190,5 +190,5 @@ _structure.check-fails)) (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." (|> (analyse-pm heterogeneous-branchesC) - _structure.check-fails)) - )))) + _structure.check-fails))) + ))) diff --git a/stdlib/test/test/lux/lang/analysis/function.lux b/stdlib/test/test/lux/lang/compiler/analysis/function.lux index a99504045..147cbcc9e 100644 --- a/stdlib/test/test/lux/lang/analysis/function.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/function.lux @@ -14,12 +14,12 @@ (macro [code]) [lang] (lang [type "type/" Eq<Type>] - [".L" init] [".L" reference] - [".L" analysis #+ Analysis] - (analysis [".A" type] - [".A" expression] - ["/" function])) + (compiler [".L" init] + [".L" analysis #+ Analysis] + (analysis [".A" type] + [".A" expression] + ["/" function]))) test) (// ["_." primitive] ["_." structure])) diff --git a/stdlib/test/test/lux/lang/analysis/primitive.lux b/stdlib/test/test/lux/lang/compiler/analysis/primitive.lux index 6e2a8aae9..18b8f6c46 100644 --- a/stdlib/test/test/lux/lang/analysis/primitive.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/primitive.lux @@ -11,10 +11,10 @@ (macro [code]) [lang] (lang [".L" type "type/" Eq<Type>] - [".L" init] - [analysis #+ Analysis] - (analysis [".A" type] - [".A" expression])) + (compiler [".L" init] + [analysis #+ Analysis] + (analysis [".A" type] + [".A" expression]))) test)) (def: #export analyse (expressionA.analyser (:! lang.Eval []))) diff --git a/stdlib/test/test/lux/lang/analysis/procedure/common.lux b/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux index 898376045..898376045 100644 --- a/stdlib/test/test/lux/lang/analysis/procedure/common.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux diff --git a/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux b/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux index 0a60149d5..0a60149d5 100644 --- a/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux diff --git a/stdlib/test/test/lux/lang/analysis/reference.lux b/stdlib/test/test/lux/lang/compiler/analysis/reference.lux index 6551e3cba..ff7ce3412 100644 --- a/stdlib/test/test/lux/lang/analysis/reference.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/reference.lux @@ -12,11 +12,11 @@ (lang [type "type/" Eq<Type>] [".L" scope] [".L" module] - [".L" init] [".L" reference] - [".L" analysis] - (analysis [".A" type] - [".A" expression])) + (compiler [".L" init] + [".L" analysis] + (analysis [".A" type] + [".A" expression]))) test) (// ["_." primitive])) diff --git a/stdlib/test/test/lux/lang/analysis/structure.lux b/stdlib/test/test/lux/lang/compiler/analysis/structure.lux index 20b911714..2f3e369d6 100644 --- a/stdlib/test/test/lux/lang/analysis/structure.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/structure.lux @@ -18,11 +18,11 @@ (lang [type "type/" Eq<Type>] (type ["tc" check]) [".L" module] - [".L" init] - [".L" analysis #+ Analysis Variant Tag] - (analysis [".A" type] - ["/" structure] - [".A" expression])) + (compiler [".L" init] + [".L" analysis #+ Analysis Variant Tag] + (analysis [".A" type] + ["/" structure] + [".A" expression]))) test) (// ["_." primitive])) diff --git a/stdlib/test/test/lux/lang/synthesis/case.lux b/stdlib/test/test/lux/lang/compiler/synthesis/case.lux index 228ed2920..228ed2920 100644 --- a/stdlib/test/test/lux/lang/synthesis/case.lux +++ b/stdlib/test/test/lux/lang/compiler/synthesis/case.lux diff --git a/stdlib/test/test/lux/lang/synthesis/function.lux b/stdlib/test/test/lux/lang/compiler/synthesis/function.lux index c7b16de27..c7b16de27 100644 --- a/stdlib/test/test/lux/lang/synthesis/function.lux +++ b/stdlib/test/test/lux/lang/compiler/synthesis/function.lux diff --git a/stdlib/test/test/lux/lang/synthesis/primitive.lux b/stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux index 1c8368204..1c8368204 100644 --- a/stdlib/test/test/lux/lang/synthesis/primitive.lux +++ b/stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux diff --git a/stdlib/test/test/lux/lang/synthesis/structure.lux b/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux index e61386044..e61386044 100644 --- a/stdlib/test/test/lux/lang/synthesis/structure.lux +++ b/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux |