diff options
Diffstat (limited to '')
36 files changed, 1668 insertions, 1627 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 56fa96018..ecf5584d6 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -4084,7 +4084,7 @@ (fail "only/exclude requires symbols.")))) defs)) -(def: (parse-short-referrals tokens) +(def: (parse-referrals tokens) (-> (List Code) (Meta [Referrals (List Code)])) (case tokens (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "+"])] defs))] tokens')) @@ -4106,7 +4106,7 @@ _ (return [#Nothing tokens]))) -(def: (parse-short-openings parts) +(def: (parse-openings parts) (-> (List Code) (Meta [(List Openings) (List Code)])) (case parts #.Nil @@ -4123,7 +4123,7 @@ _ (fail "Expected all structures of opening form to be symbols."))) structs) - next+remainder (parse-short-openings parts')] + next+remainder (parse-openings parts')] (let [[next remainder] next+remainder] (return [(#.Cons [prefix structs'] next) remainder]))) @@ -4131,19 +4131,6 @@ _ (return [#.Nil parts]))) -(def: (decorate-sub-importations super-name) - (-> Text (List Importation) (List Importation)) - (list/map (: (-> Importation Importation) - (function (_ importation) - (let [{#import-name _name - #import-alias _alias - #import-refer {#refer-defs _referrals - #refer-open _openings}} importation] - {#import-name ($_ text/compose super-name "/" _name) - #import-alias _alias - #import-refer {#refer-defs _referrals - #refer-open _openings}}))))) - (def: (split at x) (-> Nat Text (Maybe [Text Text])) (case [(..clip2 +0 at x) (..clip1 at x)] @@ -4192,11 +4179,13 @@ [_ (#Cons _ a+')] (list/drop (n/- +1 amount) a+'))) -(def: (clean-module relative-root module) - (-> Text Text (Meta Text)) +(def: (clean-module nested? relative-root module) + (-> Bool Text Text (Meta Text)) (case (count-ups +0 module) +0 - (return module) + (return (if nested? + ($_ "lux text concat" relative-root "/" module) + module)) ups (let [parts (text/split "/" relative-root)] @@ -4217,8 +4206,8 @@ "Importing module: " module "\n" " Relative Root: " relative-root "\n")))))) -(def: (parse-imports relative-root imports) - (-> Text (List Code) (Meta (List Importation))) +(def: (parse-imports nested? relative-root imports) + (-> Bool Text (List Code) (Meta (List Importation))) (do Monad<Meta> [imports' (monad/map Monad<Meta> (: (-> Code (Meta (List Importation))) @@ -4226,7 +4215,7 @@ (case token [_ (#Symbol ["" m-name])] (do Monad<Meta> - [m-name (clean-module relative-root m-name)] + [m-name (clean-module nested? relative-root m-name)] (wrap (list {#import-name m-name #import-alias #None #import-refer {#refer-defs #All @@ -4234,7 +4223,7 @@ (^ [_ (#Tuple (list [_ (#Symbol ["" m-name])]))]) (do Monad<Meta> - [import-name (clean-module relative-root m-name)] + [import-name (clean-module nested? relative-root m-name)] (wrap (list {#import-name import-name #import-alias (#Some m-name) #import-refer {#refer-defs #Nothing @@ -4242,13 +4231,12 @@ (^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Symbol ["" m-name])] extra))]) (do Monad<Meta> - [import-name (clean-module relative-root m-name) - referral+extra (parse-short-referrals extra) + [import-name (clean-module nested? relative-root m-name) + referral+extra (parse-referrals extra) #let [[referral extra] referral+extra] - openings+extra (parse-short-openings extra) + openings+extra (parse-openings extra) #let [[openings extra] openings+extra] - sub-imports (parse-imports relative-root extra) - #let [sub-imports (decorate-sub-importations import-name sub-imports)]] + sub-imports (parse-imports true import-name extra)] (wrap (list& {#import-name import-name #import-alias (#Some (replace-all "." m-name alias)) #import-refer {#refer-defs referral @@ -4257,13 +4245,12 @@ (^ [_ (#Tuple (list& [_ (#Symbol ["" m-name])] extra))]) (do Monad<Meta> - [import-name (clean-module relative-root m-name) - referral+extra (parse-short-referrals extra) + [import-name (clean-module nested? relative-root m-name) + referral+extra (parse-referrals extra) #let [[referral extra] referral+extra] - openings+extra (parse-short-openings extra) + openings+extra (parse-openings extra) #let [[openings extra] openings+extra] - sub-imports (parse-imports relative-root extra) - #let [sub-imports (decorate-sub-importations import-name sub-imports)]] + sub-imports (parse-imports true import-name extra)] (wrap (case [referral openings] [#Nothing #Nil] sub-imports _ (list& {#import-name import-name @@ -4752,9 +4739,9 @@ (def: (read-refer module-name options) (-> Text (List Code) (Meta Refer)) (do Monad<Meta> - [referral+options (parse-short-referrals options) + [referral+options (parse-referrals options) #let [[referral options] referral+options] - openings+options (parse-short-openings options) + openings+options (parse-openings options) #let [[openings options] openings+options] current-module current-module-name #let [test-referrals (: (-> Text (List Text) (List Text) (Meta (List Any))) @@ -4895,7 +4882,7 @@ _ [(list) tokens]))] current-module current-module-name - imports (parse-imports current-module _imports) + imports (parse-imports false current-module _imports) #let [=imports (list/map (: (-> Importation Code) (function (_ [m-name m-alias =refer]) (` [(~ (text$ m-name)) (~ (text$ (default "" m-alias)))]))) diff --git a/stdlib/source/lux/function.lux b/stdlib/source/lux/function.lux index f883e36df..4d4af846a 100644 --- a/stdlib/source/lux/function.lux +++ b/stdlib/source/lux/function.lux @@ -8,10 +8,10 @@ (-> (-> b c) (-> a b) (-> a c))) (|>> g f)) -(def: #export (constant c) +(def: #export (constant value) {#.doc "Create constant functions."} - (All [a b] (-> a (-> b a))) - (function (_ _) c)) + (All [o] (-> o (All [i] (-> i o)))) + (function (_ _) value)) (def: #export (flip f) {#.doc "Flips the order of the arguments of a function."} diff --git a/stdlib/source/lux/language/compiler.lux b/stdlib/source/lux/language/compiler.lux index d8b622c31..e714773b7 100644 --- a/stdlib/source/lux/language/compiler.lux +++ b/stdlib/source/lux/language/compiler.lux @@ -9,7 +9,6 @@ [error (#+ Error)] ["." text format]] - [function] [macro ["s" syntax (#+ syntax:)]]]) (type: #export (Operation s o) @@ -21,6 +20,11 @@ (type: #export (Compiler s i o) (-> i (Operation s o))) +(def: #export (run' state operation) + (All [s o] + (-> s (Operation s o) (Error [s o]))) + (operation state)) + (def: #export (run state operation) (All [s o] (-> s (Operation s o) (Error o))) @@ -42,23 +46,6 @@ (:: ..Monad<Operation> (~' wrap) []) (..throw (~ exception) (~ message))))))) -(def: #export (localized transform) - (All [s o] - (-> (-> s s) - (-> (Operation s o) (Operation s o)))) - (function (_ operation) - (function (_ state) - (case (operation (transform state)) - (#error.Error error) - (#error.Error error) - - (#error.Success [state' output]) - (#error.Success [state output]))))) - -(def: #export (with-state state) - (All [s o] (-> s (-> (Operation s o) (Operation s o)))) - (localized (function.constant state))) - (def: #export (with-stack exception message action) (All [e s o] (-> (Exception e) e (Operation s o) (Operation s o))) (<<| (ex.with-stack exception message) diff --git a/stdlib/source/lux/language/compiler/analysis.lux b/stdlib/source/lux/language/compiler/analysis.lux index 6956cd0b4..0ca620e42 100644 --- a/stdlib/source/lux/language/compiler/analysis.lux +++ b/stdlib/source/lux/language/compiler/analysis.lux @@ -6,8 +6,10 @@ [text ("text/" Equivalence<Text>)] [collection [list ("list/" Fold<List>)]]] [function]] - [///reference (#+ Register Variable Reference)] - [//]) + [// + [extension (#+ Extension)] + [// + [reference (#+ Register Variable Reference)]]]) (type: #export #rec Primitive #Unit @@ -45,13 +47,20 @@ (#Reference Reference) (#Case Analysis (Match' Analysis)) (#Function Environment Analysis) - (#Apply Analysis Analysis)) + (#Apply Analysis Analysis) + (#Extension (Extension Analysis))) (type: #export Operation - (//.Operation .Lux)) + (extension.Operation .Lux Code Analysis)) (type: #export Compiler - (//.Compiler .Lux Code Analysis)) + (extension.Compiler .Lux Code Analysis)) + +(type: #export Handler + (extension.Handler .Lux .Code Analysis)) + +(type: #export Bundle + (extension.Bundle .Lux .Code Analysis)) (type: #export Branch (Branch' Analysis)) @@ -97,7 +106,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))) @@ -216,14 +225,14 @@ (def: #export (with-source-code source action) (All [a] (-> Source (Operation a) (Operation a))) - (function (_ compiler) + (function (_ [bundle compiler]) (let [old-source (get@ #.source compiler)] - (case (action (set@ #.source source compiler)) + (case (action [bundle (set@ #.source source compiler)]) (#error.Error error) (#error.Error error) - (#error.Success [compiler' output]) - (#error.Success [(set@ #.source old-source compiler') + (#error.Success [[bundle' compiler'] output]) + (#error.Success [[bundle' (set@ #.source old-source compiler')] output]))))) (def: fresh-bindings @@ -240,42 +249,35 @@ (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]) + (function (_ [bundle compiler]) + (case (action [bundle (update@ #.scopes (|>> (#.Cons fresh-scope)) compiler)]) + (#error.Success [[bundle' compiler'] output]) (case (get@ #.scopes compiler') #.Nil (#error.Error "Impossible error: Drained scopes!") (#.Cons head tail) - (#error.Success [(set@ #.scopes tail compiler') + (#error.Success [[bundle' (set@ #.scopes tail compiler')] [head output]])) (#error.Error error) (#error.Error error)))) -(def: #export (with-current-module name action) +(def: #export (with-current-module name) (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)))) + (extension.localized (get@ #.current-module) + (set@ #.current-module) + (function.constant (#.Some name)))) (def: #export (with-cursor cursor action) (All [a] (-> Cursor (Operation a) (Operation a))) (if (text/= "" (product.left cursor)) action - (function (_ compiler) + (function (_ [bundle compiler]) (let [old-cursor (get@ #.cursor compiler)] - (case (action (set@ #.cursor cursor compiler)) - (#error.Success [compiler' output]) - (#error.Success [(set@ #.cursor old-cursor compiler') + (case (action [bundle (set@ #.cursor cursor compiler)]) + (#error.Success [[bundle' compiler'] output]) + (#error.Success [[bundle' (set@ #.cursor old-cursor compiler')] output]) (#error.Error error) diff --git a/stdlib/source/lux/language/compiler/analysis/case.lux b/stdlib/source/lux/language/compiler/analysis/case.lux index d1ef6ece1..760ea3b03 100644 --- a/stdlib/source/lux/language/compiler/analysis/case.lux +++ b/stdlib/source/lux/language/compiler/analysis/case.lux @@ -12,15 +12,17 @@ [collection [list ("list/" Fold<List> Monoid<List> Functor<List>)]]] ["." macro [code]]] - [//// - ["." type - ["tc" check]] - [scope]] - [///] - [// (#+ Pattern Analysis Operation Compiler)] - [//type] - [//structure] - [/coverage]) + [// (#+ Pattern Analysis Operation Compiler) + [scope] + ["//." type] + [structure] + ["/." // + [extension] + [// + ["." type + ["tc" check]]]]] + [/ + [coverage]]) (exception: #export (cannot-match-type-with-pattern {type Type} {pattern Code}) (ex.report ["Type" (%type type)] @@ -215,8 +217,8 @@ [cursor (#.Record record)] (do ///.Monad<Operation> - [record (//structure.normalize record) - [members recordT] (//structure.order record) + [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)) @@ -257,8 +259,8 @@ (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) (//.with-cursor cursor (do ///.Monad<Operation> - [tag (macro.normalize tag) - [idx group variantT] (macro.resolve-tag tag) + [tag (extension.lift (macro.normalize tag)) + [idx group variantT] (extension.lift (macro.resolve-tag tag)) _ (//type.with-env (tc.check inputT variantT))] (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next))) @@ -282,12 +284,12 @@ (function (_ [patternT bodyT]) (analyse-pattern #.None inputT patternT (analyse bodyT))) branchesT) - outputHC (|> outputH product.left /coverage.determine) - outputTC (monad.map @ (|>> product.left /coverage.determine) outputT) - _ (.case (monad.fold error.Monad<Error> /coverage.merge outputHC outputTC) + 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)) + (coverage.exhaustive? coverage)) (#error.Error error) (///.fail error))] diff --git a/stdlib/source/lux/language/compiler/analysis/expression.lux b/stdlib/source/lux/language/compiler/analysis/expression.lux index f6ec5d11a..1c5c8794c 100644 --- a/stdlib/source/lux/language/compiler/analysis/expression.lux +++ b/stdlib/source/lux/language/compiler/analysis/expression.lux @@ -9,16 +9,16 @@ [text format]] [macro]] - [//// (#+ Eval) - ## [".L" macro] - ## [".L" extension] - ] - [///] - [// (#+ Analysis Operation Compiler)] - [//type] - [//primitive] - [//structure] - [//reference]) + ["." /// + [extension]] + [// (#+ Analysis Operation Compiler) + [type] + [primitive] + [structure] + [reference] + ["/." /// (#+ Eval) + ## [".L" macro] + ]]) (exception: #export (macro-expansion-failed {message Text}) message) @@ -35,7 +35,7 @@ (-> Eval Compiler) (function (compile code) (do ///.Monad<Operation> - [expectedT macro.expected-type] + [expectedT (extension.lift macro.expected-type)] (let [[cursor code'] code] ## The cursor must be set in the compiler for the sake ## of having useful error messages. @@ -44,12 +44,12 @@ (^template [<tag> <analyser>] (<tag> value) (<analyser> value)) - ([#.Bool //primitive.bool] - [#.Nat //primitive.nat] - [#.Int //primitive.int] - [#.Rev //primitive.rev] - [#.Frac //primitive.frac] - [#.Text //primitive.text]) + ([#.Bool primitive.bool] + [#.Nat primitive.nat] + [#.Int primitive.int] + [#.Rev primitive.rev] + [#.Frac primitive.frac] + [#.Text primitive.text]) (^template [<tag> <analyser>] (^ (#.Form (list& [_ (<tag> tag)] @@ -60,42 +60,39 @@ _ (<analyser> compile tag (` [(~+ values)])))) - ([#.Nat //structure.sum] - [#.Tag //structure.tagged-sum]) + ([#.Nat structure.sum] + [#.Tag structure.tagged-sum]) (#.Tag tag) - (//structure.tagged-sum compile tag (' [])) + (structure.tagged-sum compile tag (' [])) (^ (#.Tuple (list))) - //primitive.unit + primitive.unit (^ (#.Tuple (list singleton))) (compile singleton) (^ (#.Tuple elems)) - (//structure.product compile elems) + (structure.product compile elems) (^ (#.Record pairs)) - (//structure.record compile pairs) + (structure.record compile pairs) (#.Symbol reference) - (//reference.reference 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)) + (extension.apply compile [extension-name extension-args]) ## (^ (#.Form (list& func args))) ## (do ///.Monad<Operation> - ## [[funcT funcA] (//type.with-inference + ## [[funcT funcA] (type.with-inference ## (compile func))] ## (case funcA ## [_ (#.Symbol def-name)] ## (do @ ## [?macro (///.with-error-tracking - ## (macro.find-macro def-name))] + ## (extension.lift (macro.find-macro def-name)))] ## (case ?macro ## (#.Some macro) ## (do @ diff --git a/stdlib/source/lux/language/compiler/analysis/function.lux b/stdlib/source/lux/language/compiler/analysis/function.lux index 95eacc47e..51f1892de 100644 --- a/stdlib/source/lux/language/compiler/analysis/function.lux +++ b/stdlib/source/lux/language/compiler/analysis/function.lux @@ -12,12 +12,13 @@ [code]] [language ["." type - ["tc" check]] - [".L" scope]]] - [///] - [// (#+ Analysis Compiler)] - [//type] - [//inference]) + ["tc" check]]]] + [// (#+ Analysis Operation Compiler) + [scope] + ["//." type] + [inference] + ["/." // + [extension]]]) (exception: #export (cannot-analyse {expected Type} {function Text} {argument Text} {body Code}) (ex.report ["Type" (%type expected)] @@ -34,9 +35,9 @@ (text.join-with ""))])) (def: #export (function analyse function-name arg-name body) - (-> Compiler Text Text Code (Meta Analysis)) - (do macro.Monad<Meta> - [functionT macro.expected-type] + (-> Compiler Text Text Code (Operation Analysis)) + (do ///.Monad<Operation> + [functionT (extension.lift macro.expected-type)] (loop [expectedT functionT] (///.with-stack cannot-analyse [expectedT function-name arg-name body] (case expectedT @@ -81,12 +82,12 @@ (#.Function inputT outputT) (<| (:: @ map (.function (_ [scope bodyA]) - (#//.Function (scopeL.environment scope) bodyA))) + (#//.Function (scope.environment scope) bodyA))) //.with-scope ## Functions have access not only to their argument, but ## also to themselves, through a local variable. - (scopeL.with-local [function-name expectedT]) - (scopeL.with-local [arg-name inputT]) + (scope.with-local [function-name expectedT]) + (scope.with-local [arg-name inputT]) (//type.with-type outputT) (analyse body)) @@ -94,9 +95,9 @@ (///.fail "") ))))) -(def: #export (apply analyse functionT functionA args) - (-> Compiler Type Analysis (List Code) (Meta Analysis)) - (<| (///.with-stack cannot-apply [functionT args]) - (do macro.Monad<Meta> - [[applyT argsA] (//inference.general analyse functionT args)]) - (wrap (//.apply [functionA argsA])))) +(def: #export (apply analyse functionT functionA argsC+) + (-> Compiler Type Analysis (List Code) (Operation Analysis)) + (<| (///.with-stack cannot-apply [functionT argsC+]) + (do ///.Monad<Operation> + [[applyT argsA+] (inference.general analyse functionT argsC+)]) + (wrap (//.apply [functionA argsA+])))) diff --git a/stdlib/source/lux/language/compiler/analysis/inference.lux b/stdlib/source/lux/language/compiler/analysis/inference.lux index 1539e1a0d..403ad0092 100644 --- a/stdlib/source/lux/language/compiler/analysis/inference.lux +++ b/stdlib/source/lux/language/compiler/analysis/inference.lux @@ -9,9 +9,11 @@ format] [collection [list ("list/" Functor<List>)]]] [macro]] - [//// ["." type - ["tc" check]]] - [/// ("operation/" Monad<Operation>)] + [//// + ["." type + ["tc" check]]] + [/// ("operation/" Monad<Operation>) + [extension]] [// (#+ Tag Analysis Operation Compiler)] [//type]) @@ -75,16 +77,17 @@ _ type)) +(def: (named-type cursor id) + (-> Cursor Nat Type) + (let [name (format "{New Type @ " (.cursor-description cursor) " " (%n id) "}")] + (#.Primitive name (list)))) + (def: new-named-type (Operation Type) (do ///.Monad<Operation> - [[module line column] macro.cursor + [cursor (extension.lift macro.cursor) [ex-id _] (//type.with-env tc.existential)] - (wrap (#.Primitive (format "{New Type @ " (%t module) - "," (%n line) - "," (%n column) - "} " (%n ex-id)) - (list))))) + (wrap (named-type cursor ex-id)))) ## Type-inference works by applying some (potentially quantified) type ## to a sequence of values. diff --git a/stdlib/source/lux/language/compiler/analysis/module.lux b/stdlib/source/lux/language/compiler/analysis/module.lux new file mode 100644 index 000000000..2a2aef5c3 --- /dev/null +++ b/stdlib/source/lux/language/compiler/analysis/module.lux @@ -0,0 +1,255 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)] + pipe] + [data + [text ("text/" Equivalence<Text>) + format] + ["e" error] + [collection + [list ("list/" Fold<List> Functor<List>)] + [dictionary + [plist]]]] + [macro]] + [// (#+ Operation) + ["/." // + [extension]]]) + +(type: #export Tag Text) + +(exception: #export (unknown-module {module Text}) + module) + +(exception: #export (cannot-declare-tag-twice {module Text} {tag Text}) + (ex.report ["Module" module] + ["Tag" tag])) + +(do-template [<name>] + [(exception: #export (<name> {tags (List Text)} {owner Type}) + (ex.report ["Tags" (text.join-with " " tags)] + ["Type" (%type owner)]))] + + [cannot-declare-tags-for-unnamed-type] + [cannot-declare-tags-for-foreign-type] + ) + +(exception: #export (cannot-define-more-than-once {name Ident}) + (%ident name)) + +(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State}) + (ex.report ["Module" module] + ["Desired state" (case state + #.Active "Active" + #.Compiled "Compiled" + #.Cached "Cached")])) + +(exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code}) + (ex.report ["Module" module] + ["Old annotations" (%code old)] + ["New annotations" (%code new)])) + +(def: (new hash) + (-> Nat Module) + {#.module-hash hash + #.module-aliases (list) + #.definitions (list) + #.imports (list) + #.tags (list) + #.types (list) + #.module-annotations #.None + #.module-state #.Active}) + +(def: #export (set-annotations annotations) + (-> Code (Operation Any)) + (do ///.Monad<Operation> + [self-name (extension.lift macro.current-module-name) + self (extension.lift macro.current-module)] + (case (get@ #.module-annotations self) + #.None + (extension.lift + (function (_ state) + (#e.Success [(update@ #.modules + (plist.put self-name (set@ #.module-annotations (#.Some annotations) self)) + state) + []]))) + + (#.Some old) + (///.throw cannot-set-module-annotations-more-than-once [self-name old annotations])))) + +(def: #export (import module) + (-> Text (Operation Any)) + (do ///.Monad<Operation> + [self-name (extension.lift macro.current-module-name)] + (extension.lift + (function (_ state) + (#e.Success [(update@ #.modules + (plist.update self-name (update@ #.imports (|>> (#.Cons module)))) + state) + []]))))) + +(def: #export (alias alias module) + (-> Text Text (Operation Any)) + (do ///.Monad<Operation> + [self-name (extension.lift macro.current-module-name)] + (extension.lift + (function (_ state) + (#e.Success [(update@ #.modules + (plist.update self-name (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text])) + (|>> (#.Cons [alias module]))))) + state) + []]))))) + +(def: #export (exists? module) + (-> Text (Operation Bool)) + (extension.lift + (function (_ state) + (|> state + (get@ #.modules) + (plist.get module) + (case> (#.Some _) true #.None false) + [state] #e.Success)))) + +(def: #export (define name definition) + (-> Text Definition (Operation [])) + (do ///.Monad<Operation> + [self-name (extension.lift macro.current-module-name) + self (extension.lift macro.current-module)] + (extension.lift + (function (_ state) + (case (plist.get name (get@ #.definitions self)) + #.None + (#e.Success [(update@ #.modules + (plist.put self-name + (update@ #.definitions + (: (-> (List [Text Definition]) (List [Text Definition])) + (|>> (#.Cons [name definition]))) + self)) + state) + []]) + + (#.Some already-existing) + ((///.throw cannot-define-more-than-once [self-name name]) state)))))) + +(def: #export (create hash name) + (-> Nat Text (Operation [])) + (extension.lift + (function (_ state) + (let [module (new hash)] + (#e.Success [(update@ #.modules + (plist.put name module) + state) + []]))))) + +(def: #export (with-module hash name action) + (All [a] (-> Nat Text (Operation a) (Operation [Module a]))) + (do ///.Monad<Operation> + [_ (create hash name) + output (//.with-current-module name + action) + module (extension.lift (macro.find-module name))] + (wrap [module output]))) + +(do-template [<setter> <asker> <tag>] + [(def: #export (<setter> module-name) + (-> Text (Operation Any)) + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (let [active? (case (get@ #.module-state module) + #.Active true + _ false)] + (if active? + (#e.Success [(update@ #.modules + (plist.put module-name (set@ #.module-state <tag> module)) + state) + []]) + ((///.throw can-only-change-state-of-active-module [module-name <tag>]) + state))) + + #.None + ((///.throw unknown-module module-name) state))))) + + (def: #export (<asker> module-name) + (-> Text (Operation Bool)) + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (#e.Success [state + (case (get@ #.module-state module) + <tag> true + _ false)]) + + #.None + ((///.throw unknown-module module-name) state)))))] + + [set-active active? #.Active] + [set-compiled compiled? #.Compiled] + [set-cached cached? #.Cached] + ) + +(do-template [<name> <tag> <type>] + [(def: (<name> module-name) + (-> Text (Operation <type>)) + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (#e.Success [state (get@ <tag> module)]) + + #.None + ((///.throw unknown-module module-name) state)))))] + + [tags #.tags (List [Text [Nat (List Ident) Bool Type]])] + [types #.types (List [Text [(List Ident) Bool Type]])] + [hash #.module-hash Nat] + ) + +(def: (ensure-undeclared-tags module-name tags) + (-> Text (List Tag) (Operation Any)) + (do ///.Monad<Operation> + [bindings (..tags module-name) + _ (monad.map @ + (function (_ tag) + (case (plist.get tag bindings) + #.None + (wrap []) + + (#.Some _) + (///.throw cannot-declare-tag-twice [module-name tag]))) + tags)] + (wrap []))) + +(def: #export (declare-tags tags exported? type) + (-> (List Tag) Bool Type (Operation Any)) + (do ///.Monad<Operation> + [self-name (extension.lift macro.current-module-name) + [type-module type-name] (case type + (#.Named type-ident _) + (wrap type-ident) + + _ + (///.throw cannot-declare-tags-for-unnamed-type [tags type])) + _ (ensure-undeclared-tags self-name tags) + _ (///.assert cannot-declare-tags-for-foreign-type [tags type] + (text/= self-name type-module))] + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get self-name)) + (#.Some module) + (let [namespaced-tags (list/map (|>> [self-name]) tags)] + (#e.Success [(update@ #.modules + (plist.update self-name + (|>> (update@ #.tags (function (_ tag-bindings) + (list/fold (function (_ [idx tag] table) + (plist.put tag [idx namespaced-tags exported? type] table)) + tag-bindings + (list.enumerate tags)))) + (update@ #.types (plist.put type-name [namespaced-tags exported? type])))) + state) + []])) + #.None + ((///.throw unknown-module self-name) state)))))) diff --git a/stdlib/source/lux/language/compiler/analysis/primitive.lux b/stdlib/source/lux/language/compiler/analysis/primitive.lux index cbfef367f..eabbcb7d8 100644 --- a/stdlib/source/lux/language/compiler/analysis/primitive.lux +++ b/stdlib/source/lux/language/compiler/analysis/primitive.lux @@ -2,14 +2,15 @@ [lux (#- nat int rev) [control monad] [macro]] - [// (#+ Analysis) - [".A" type]]) + [// (#+ Analysis Operation) + [".A" type] + ["/." //]]) ## [Analysers] (do-template [<name> <type> <tag>] [(def: #export (<name> value) - (-> <type> (Meta Analysis)) - (do macro.Monad<Meta> + (-> <type> (Operation Analysis)) + (do ///.Monad<Operation> [_ (typeA.infer <type>)] (wrap (#//.Primitive (<tag> value)))))] @@ -22,7 +23,7 @@ ) (def: #export unit - (Meta Analysis) - (do macro.Monad<Meta> + (Operation Analysis) + (do ///.Monad<Operation> [_ (typeA.infer Any)] (wrap (#//.Primitive #//.Unit)))) diff --git a/stdlib/source/lux/language/compiler/analysis/reference.lux b/stdlib/source/lux/language/compiler/analysis/reference.lux index cdffd6870..af134ebe3 100644 --- a/stdlib/source/lux/language/compiler/analysis/reference.lux +++ b/stdlib/source/lux/language/compiler/analysis/reference.lux @@ -5,15 +5,19 @@ ["ex" exception (#+ exception:)]] ["." macro [code]] - [language [type ["tc" check]]] + [language + [type + ["tc" check]]] [data [text ("text/" Equivalence<Text>) format]]] - [///] - [// (#+ Analysis Operation)] - [//type] - [////reference] - [////scope]) + [// (#+ Analysis Operation) + [scope] + [type] + ["/." // + [extension] + [// + [reference]]]]) (exception: #export (foreign-module-has-not-been-imported {current Text} {foreign Text}) (ex.report ["Current" current] @@ -25,23 +29,23 @@ ## [Analysers] (def: (definition def-name) (-> Ident (Operation Analysis)) - (with-expansions [<return> (wrap (|> def-name ////reference.constant #//.Reference))] + (with-expansions [<return> (wrap (|> def-name reference.constant #//.Reference))] (do ///.Monad<Operation> - [[actualT def-anns _] (macro.find-def def-name)] + [[actualT def-anns _] (extension.lift (macro.find-def def-name))] (case (macro.get-symbol-ann (ident-for #.alias) def-anns) (#.Some real-def-name) (definition real-def-name) _ (do @ - [_ (//type.infer actualT) - (^@ def-name [::module ::name]) (macro.normalize def-name) - current macro.current-module-name] + [_ (type.infer actualT) + (^@ def-name [::module ::name]) (extension.lift (macro.normalize def-name)) + current (extension.lift macro.current-module-name)] (if (text/= current ::module) <return> (if (macro.export? def-anns) (do @ - [imported! (macro.imported-by? ::module current)] + [imported! (extension.lift (macro.imported-by? ::module current))] (if imported! <return> (///.throw foreign-module-has-not-been-imported [current ::module]))) @@ -50,12 +54,12 @@ (def: (variable var-name) (-> Text (Operation (Maybe Analysis))) (do ///.Monad<Operation> - [?var (////scope.find var-name)] + [?var (scope.find var-name)] (case ?var (#.Some [actualT ref]) (do @ - [_ (//type.infer actualT)] - (wrap (#.Some (|> ref ////reference.variable #//.Reference)))) + [_ (type.infer actualT)] + (wrap (#.Some (|> ref reference.variable #//.Reference)))) #.None (wrap #.None)))) @@ -72,7 +76,7 @@ #.None (do @ - [this-module macro.current-module-name] + [this-module (extension.lift macro.current-module-name)] (definition [this-module simple-name])))) _ diff --git a/stdlib/source/lux/language/compiler/analysis/scope.lux b/stdlib/source/lux/language/compiler/analysis/scope.lux new file mode 100644 index 000000000..2468ede27 --- /dev/null +++ b/stdlib/source/lux/language/compiler/analysis/scope.lux @@ -0,0 +1,196 @@ +(.module: + [lux #* + [control + monad] + [data + [text ("text/" Equivalence<Text>) + format] + [maybe ("maybe/" Monad<Maybe>)] + [product] + ["e" error] + [collection + [list ("list/" Functor<List> Fold<List> Monoid<List>)] + [dictionary [plist]]]]] + [// (#+ Operation Compiler) + ["compiler" // + [extension] + [// + [reference (#+ Register Variable)]]]]) + +(type: Local (Bindings Text [Type Register])) +(type: Foreign (Bindings Text [Type Variable])) + +(def: (local? name scope) + (-> Text Scope Bool) + (|> scope + (get@ [#.locals #.mappings]) + (plist.contains? name))) + +(def: (local name scope) + (-> Text Scope (Maybe [Type Variable])) + (|> scope + (get@ [#.locals #.mappings]) + (plist.get name) + (maybe/map (function (_ [type value]) + [type (#reference.Local value)])))) + +(def: (captured? name scope) + (-> Text Scope Bool) + (|> scope + (get@ [#.captured #.mappings]) + (plist.contains? name))) + +(def: (captured name scope) + (-> Text Scope (Maybe [Type Variable])) + (loop [idx +0 + mappings (get@ [#.captured #.mappings] scope)] + (case mappings + #.Nil + #.None + + (#.Cons [_name [_source-type _source-ref]] mappings') + (if (text/= name _name) + (#.Some [_source-type (#reference.Foreign idx)]) + (recur (inc idx) mappings'))))) + +(def: (reference? name scope) + (-> Text Scope Bool) + (or (local? name scope) + (captured? name scope))) + +(def: (reference name scope) + (-> Text Scope (Maybe [Type Variable])) + (case (..local name scope) + (#.Some type) + (#.Some type) + + _ + (..captured name scope))) + +(def: #export (find name) + (-> Text (Operation (Maybe [Type Variable]))) + (extension.lift + (function (_ state) + (let [[inner outer] (|> state + (get@ #.scopes) + (list.split-with (|>> (reference? name) not)))] + (case outer + #.Nil + (#.Right [state #.None]) + + (#.Cons top-outer _) + (let [[ref-type init-ref] (maybe.default (undefined) + (..reference name top-outer)) + [ref inner'] (list/fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)]) + (function (_ scope ref+inner) + [(#reference.Foreign (get@ [#.captured #.counter] scope)) + (#.Cons (update@ #.captured + (: (-> Foreign Foreign) + (|>> (update@ #.counter inc) + (update@ #.mappings (plist.put name [ref-type (product.left ref+inner)])))) + scope) + (product.right ref+inner))])) + [init-ref #.Nil] + (list.reverse inner)) + scopes (list/compose inner' outer)] + (#.Right [(set@ #.scopes scopes state) + (#.Some [ref-type ref])])) + ))))) + +(def: #export (with-local [name type] action) + (All [a] (-> [Text Type] (Operation a) (Operation a))) + (function (_ [bundle state]) + (case (get@ #.scopes state) + (#.Cons head tail) + (let [old-mappings (get@ [#.locals #.mappings] head) + new-var-id (get@ [#.locals #.counter] head) + new-head (update@ #.locals + (: (-> Local Local) + (|>> (update@ #.counter inc) + (update@ #.mappings (plist.put name [type new-var-id])))) + head)] + (case (compiler.run' [bundle (set@ #.scopes (#.Cons new-head tail) state)] + action) + (#e.Success [[bundle' state'] output]) + (case (get@ #.scopes state') + (#.Cons head' tail') + (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head') + tail')] + (#e.Success [[bundle' (set@ #.scopes scopes' state')] + output])) + + _ + (error! "Invalid scope alteration/")) + + (#e.Error error) + (#e.Error error))) + + _ + (#e.Error "Cannot create local binding without a scope.")) + )) + +(do-template [<name> <val-type>] + [(def: <name> + (Bindings Text [Type <val-type>]) + {#.counter +0 + #.mappings (list)})] + + [init-locals Nat] + [init-captured Variable] + ) + +(def: (scope parent-name child-name) + (-> (List Text) Text Scope) + {#.name (list& child-name parent-name) + #.inner +0 + #.locals init-locals + #.captured init-captured}) + +(def: #export (with-scope name action) + (All [a] (-> Text (Operation a) (Operation a))) + (function (_ [bundle state]) + (let [parent-name (case (get@ #.scopes state) + #.Nil + (list) + + (#.Cons top _) + (get@ #.name top))] + (case (action [bundle (update@ #.scopes + (|>> (#.Cons (scope parent-name name))) + state)]) + (#e.Error error) + (#e.Error error) + + (#e.Success [[bundle' state'] output]) + (#e.Success [[bundle' (update@ #.scopes + (|>> list.tail (maybe.default (list))) + state')] + output]) + )) + )) + +(def: #export next-local + (Operation Register) + (extension.lift + (function (_ state) + (case (get@ #.scopes state) + #.Nil + (#e.Error "Cannot get next reference when there is no scope.") + + (#.Cons top _) + (#e.Success [state (get@ [#.locals #.counter] top)]))))) + +(def: (ref-to-variable ref) + (-> Ref Variable) + (case ref + (#.Local register) + (#reference.Local register) + + (#.Captured register) + (#reference.Foreign register))) + +(def: #export (environment scope) + (-> Scope (List Variable)) + (|> scope + (get@ [#.captured #.mappings]) + (list/map (function (_ [_ [_ ref]]) (ref-to-variable ref))))) diff --git a/stdlib/source/lux/language/compiler/analysis/structure.lux b/stdlib/source/lux/language/compiler/analysis/structure.lux index e30d22bad..382eab486 100644 --- a/stdlib/source/lux/language/compiler/analysis/structure.lux +++ b/stdlib/source/lux/language/compiler/analysis/structure.lux @@ -13,14 +13,15 @@ ["dict" dictionary (#+ Dictionary)]]] ["." macro [code]]] - [//// - ["." type - ["tc" check]]] - [///] - [// (#+ Tag Analysis Operation Compiler)] - [//type] - [//primitive] - [//inference]) + [// (#+ Tag Analysis Operation Compiler) + ["//." type] + [primitive] + [inference] + ["/." // + [extension] + ["//." // + ["." type + ["tc" check]]]]]) (exception: #export (invalid-variant-type {type Type} {tag Tag} {code Code}) (ex.report ["Type" (%type type)] @@ -79,7 +80,7 @@ (def: #export (sum analyse tag valueC) (-> Compiler Nat Code (Operation Analysis)) (do ///.Monad<Operation> - [expectedT macro.expected-type] + [expectedT (extension.lift macro.expected-type)] (///.with-stack cannot-analyse-variant [expectedT tag valueC] (case expectedT (#.Sum _) @@ -93,7 +94,7 @@ (wrap (//.sum-analysis type-size tag valueA))) #.None - (///.throw //inference.variant-tag-out-of-bounds [type-size tag expectedT]))) + (///.throw inference.variant-tag-out-of-bounds [type-size tag expectedT]))) (#.Named name unnamedT) (//type.with-type unnamedT @@ -152,7 +153,7 @@ (def: (typed-product analyse membersC+) (-> Compiler (List Code) (Operation Analysis)) (do ///.Monad<Operation> - [expectedT macro.expected-type] + [expectedT (extension.lift macro.expected-type)] (loop [expectedT expectedT membersC+ membersC+] (case [expectedT membersC+] @@ -191,7 +192,7 @@ (def: #export (product analyse membersC) (-> Compiler (List Code) (Operation Analysis)) (do ///.Monad<Operation> - [expectedT macro.expected-type] + [expectedT (extension.lift macro.expected-type)] (///.with-stack cannot-analyse-tuple [expectedT membersC] (case expectedT (#.Product _) @@ -258,15 +259,15 @@ (def: #export (tagged-sum analyse tag valueC) (-> Compiler Ident Code (Operation Analysis)) (do ///.Monad<Operation> - [tag (macro.normalize tag) - [idx group variantT] (macro.resolve-tag tag) - expectedT macro.expected-type] + [tag (extension.lift (macro.normalize tag)) + [idx group variantT] (extension.lift (macro.resolve-tag tag)) + expectedT (extension.lift macro.expected-type)] (case expectedT (#.Var _) (do @ [#let [case-size (list.size group)] - inferenceT (//inference.variant idx case-size variantT) - [inferredT valueA+] (//inference.general analyse inferenceT (list valueC))] + 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)))) _ @@ -283,7 +284,7 @@ (case key [_ (#.Tag key)] (do ///.Monad<Operation> - [key (macro.normalize key)] + [key (extension.lift (macro.normalize key))] (wrap [key val])) _ @@ -302,8 +303,8 @@ (#.Cons [head-k head-v] _) (do ///.Monad<Operation> - [head-k (macro.normalize head-k) - [_ tag-set recordT] (macro.resolve-tag head-k) + [head-k (extension.lift (macro.normalize head-k)) + [_ tag-set recordT] (extension.lift (macro.resolve-tag head-k)) #let [size-record (list.size record) size-ts (list.size tag-set)] _ (if (n/= size-ts size-record) @@ -314,7 +315,7 @@ idx->val (monad.fold @ (function (_ [key val] idx->val) (do @ - [key (macro.normalize key)] + [key (extension.lift (macro.normalize key))] (case (dict.get key tag->idx) #.None (///.throw tag-does-not-belong-to-record [key recordT]) @@ -338,19 +339,19 @@ [membersC recordT] (order members)] (case membersC (^ (list)) - //primitive.unit + primitive.unit (^ (list singletonC)) (analyse singletonC) _ (do @ - [expectedT macro.expected-type] + [expectedT (extension.lift macro.expected-type)] (case expectedT (#.Var _) (do @ - [inferenceT (//inference.record recordT) - [inferredT membersA] (//inference.general analyse inferenceT membersC)] + [inferenceT (inference.record recordT) + [inferredT membersA] (inference.general analyse inferenceT membersC)] (wrap (//.product-analysis membersA))) _ diff --git a/stdlib/source/lux/language/compiler/analysis/type.lux b/stdlib/source/lux/language/compiler/analysis/type.lux index 0c73dedab..f87a96758 100644 --- a/stdlib/source/lux/language/compiler/analysis/type.lux +++ b/stdlib/source/lux/language/compiler/analysis/type.lux @@ -1,51 +1,42 @@ (.module: [lux #* - [control [monad (#+ do)]] - [data [error]] + [control + [monad (#+ do)]] + [data + [error]] + [function] [macro] - [language [type ["tc" check]]]] - [///] - [// (#+ Operation)]) + [language + [type ["tc" check]]]] + [// (#+ Operation) + ["/." // + [extension]]]) -(def: #export (with-type expected action) +(def: #export (with-type expected) (All [a] (-> Type (Operation a) (Operation a))) - (function (_ compiler) - (case (action (set@ #.expected (#.Some expected) compiler)) - (#error.Success [compiler' output]) - (let [old-expected (get@ #.expected compiler)] - (#error.Success [(set@ #.expected old-expected compiler') - output])) - - (#error.Error error) - (#error.Error error)))) + (extension.localized (get@ #.expected) (set@ #.expected) + (function.constant (#.Some expected)))) (def: #export (with-env action) (All [a] (-> (tc.Check a) (Operation a))) - (function (_ compiler) - (case (action (get@ #.type-context compiler)) + (function (_ (^@ stateE [bundle state])) + (case (action (get@ #.type-context state)) (#error.Error error) - ((///.fail error) compiler) + ((///.fail error) stateE) (#error.Success [context' output]) - (#error.Success [(set@ #.type-context context' compiler) + (#error.Success [[bundle (set@ #.type-context context' state)] output])))) -(def: #export (with-fresh-env action) +(def: #export with-fresh-env (All [a] (-> (Operation a) (Operation a))) - (function (_ compiler) - (let [old (get@ #.type-context compiler)] - (case (action (set@ #.type-context tc.fresh-context compiler)) - (#error.Success [compiler' output]) - (#error.Success [(set@ #.type-context old compiler') - output]) - - output - output)))) + (extension.localized (get@ #.type-context) (set@ #.type-context) + (function.constant tc.fresh-context))) (def: #export (infer actualT) (-> Type (Operation Any)) (do ///.Monad<Operation> - [expectedT macro.expected-type] + [expectedT (extension.lift macro.expected-type)] (with-env (tc.check expectedT actualT)))) diff --git a/stdlib/source/lux/language/compiler/extension.lux b/stdlib/source/lux/language/compiler/extension.lux index 478c90564..fc41aa30d 100644 --- a/stdlib/source/lux/language/compiler/extension.lux +++ b/stdlib/source/lux/language/compiler/extension.lux @@ -6,61 +6,108 @@ [data [error (#+ Error)] [text] - [collection ["dict" dictionary (#+ Dictionary)]]]] - [// (#+ Operation Compiler)]) + [collection ["dict" dictionary (#+ Dictionary)]]] + [function]] + [//]) (type: #export (Extension i) - (#Base i) - (#Extension [Text (List (Extension i))])) + [Text (List i)]) -(with-expansions [<Bundle> (as-is (Dictionary Text (-> Text (Handler s i o))))] +(with-expansions [<Bundle> (as-is (Dictionary 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)))) + (-> Text + (//.Compiler [<Bundle> s] i o) + (//.Compiler [<Bundle> s] (List i) o))) (type: #export (Bundle s i o) <Bundle>)) +(type: #export (Operation s i o v) + (//.Operation [(Bundle s i o) s] v)) + +(type: #export (Compiler s i o) + (//.Compiler [(Bundle s i o) s] i o)) + (do-template [<name>] [(exception: #export (<name> {name Text}) (ex.report ["Name" name]))] - [unknown-extension] - [cannot-overwrite-existing-extension] + [unknown] + [cannot-overwrite] ) -(def: #export (extend compiler) +(def: #export (install name handler) + (All [s i o] + (-> Text (Handler s i o) (Operation s i o Any))) + (function (_ [bundle state]) + (if (dict.contains? name bundle) + (ex.throw cannot-overwrite name) + (#error.Success [[(dict.put name handler bundle) state] + []])))) + +(def: #export (apply compiler [name parameters]) (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)])) + (-> (Compiler s i o) (Extension i) (Operation s i o o))) + (function (_ (^@ stateE [bundle state])) + (case (dict.get name bundle) + #.None + (ex.throw unknown name) - (#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))))) + (#.Some handler) + ((handler name compiler) parameters stateE)))) -(def: #export (install name handler) +(def: #export (localized get set transform) + (All [s s' i o v] + (-> (-> s s') (-> s' s s) (-> s' s') + (-> (Operation s i o v) (Operation s i o v)))) + (function (_ operation) + (function (_ [bundle state]) + (let [old (get state)] + (case (operation [bundle (set (transform old) state)]) + (#error.Error error) + (#error.Error error) + + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set old state')] output])))))) + +(def: #export (temporary transform) + (All [s i o v] + (-> (-> s s) + (-> (Operation s i o v) (Operation s i o v)))) + (function (_ operation) + (function (_ [bundle state]) + (case (operation [bundle (transform state)]) + (#error.Error error) + (#error.Error error) + + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' state] output]))))) + +(def: #export (with-state state) + (All [s i o v] + (-> s (-> (Operation s i o v) (Operation s i o v)))) + (..temporary (function.constant state))) + +(def: #export (read get) + (All [s i o v] + (-> (-> s v) (Operation s i o v))) + (function (_ [bundle state]) + (#error.Success [[bundle state] (get state)]))) + +(def: #export (update transform) (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)])))) + (-> (-> s s) (Operation s i o Any))) + (function (_ [bundle state]) + (#error.Success [[bundle (transform state)] []]))) + +(def: #export (lift action) + (All [s i o v] + (-> (//.Operation s v) + (//.Operation [(Bundle s i o) s] v))) + (function (_ [bundle state]) + (case (action state) + (#error.Error error) + (#error.Error error) -(def: #export fresh - Bundle - (dict.new text.Hash<Text>)) + (#error.Success [state' output]) + (#error.Success [[bundle state] output])))) diff --git a/stdlib/source/lux/language/compiler/extension/analysis.lux b/stdlib/source/lux/language/compiler/extension/analysis.lux index ba37b4578..0f57de1ff 100644 --- a/stdlib/source/lux/language/compiler/extension/analysis.lux +++ b/stdlib/source/lux/language/compiler/extension/analysis.lux @@ -1,20 +1,15 @@ (.module: [lux #* [data - [text] [collection - [list ("list/" Functor<List>)] - ["dict" dictionary (#+ Dictionary)]]]] - [///analysis (#+ Analysis State)] - [///synthesis (#+ Synthesis)] - [//] - [/common] - [/host]) + [dictionary]]]] + [/// + [analysis (#+ Bundle)]] + [/ + [common] + [host]]) -(def: #export defaults - (//.Bundle State Analysis Synthesis) - (|> /common.extensions - (dict.merge /host.extensions) - dict.entries - (list/map (function (_ [name proc]) [name (proc name)])) - (dict.from-list text.Hash<Text>))) +(def: #export bundle + Bundle + (dictionary.merge host.bundle + common.bundle)) diff --git a/stdlib/source/lux/language/compiler/extension/analysis/common.lux b/stdlib/source/lux/language/compiler/extension/analysis/common.lux index 0dac69ced..55d479052 100644 --- a/stdlib/source/lux/language/compiler/extension/analysis/common.lux +++ b/stdlib/source/lux/language/compiler/extension/analysis/common.lux @@ -15,23 +15,19 @@ ["." language [type ["tc" check]]] [io (#+ IO)]] - [////] - [//// - [analysis (#+ Analysis) + ["." //// + [analysis (#+ Analysis Bundle) [".A" type] [".A" case] [".A" function]]] - [///] - [///bundle]) - -(type: Handler - (///.Handler .Lux .Code Analysis)) + ["." /// + [bundle]]) ## [Utils] -(def: (simple extension inputsT+ outputT) - (-> Text (List Type) Type ..Handler) +(def: (simple inputsT+ outputT) + (-> (List Type) Type analysis.Handler) (let [num-expected (list.size inputsT+)] - (function (_ analyse args) + (function (_ extension-name analyse args) (let [num-actual (list.size args)] (if (n/= num-expected num-actual) (do ////.Monad<Operation> @@ -41,40 +37,40 @@ (typeA.with-type argT (analyse argC))) (list.zip2 inputsT+ args))] - (wrap (#///.Extension extension argsA))) - (language.throw ///bundle.incorrect-arity [extension num-expected num-actual])))))) + (wrap (#analysis.Extension extension-name argsA))) + (////.throw bundle.incorrect-arity [extension-name num-expected num-actual])))))) -(def: #export (nullary valueT extension) - (-> Type Text ..Handler) - (simple extension (list) valueT)) +(def: #export (nullary valueT) + (-> Type analysis.Handler) + (simple (list) valueT)) -(def: #export (unary inputT outputT extension) - (-> Type Type Text ..Handler) - (simple extension (list inputT) outputT)) +(def: #export (unary inputT outputT) + (-> Type Type analysis.Handler) + (simple (list inputT) outputT)) -(def: #export (binary subjectT paramT outputT extension) - (-> Type Type Type Text ..Handler) - (simple extension (list subjectT paramT) outputT)) +(def: #export (binary subjectT paramT outputT) + (-> Type Type Type analysis.Handler) + (simple (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)) +(def: #export (trinary subjectT param0T param1T outputT) + (-> Type Type Type Type analysis.Handler) + (simple (list subjectT param0T param1T) outputT)) ## [Analysers] ## "lux is" represents reference/pointer equality. -(def: (lux//is extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: lux::is + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[var-id varT] (typeA.with-env tc.var)] - ((binary varT varT Bool extension) + ((binary varT varT Bool extension-name) 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) +(def: lux::try + analysis.Handler + (function (_ extension-name analyse args) (case args (^ (list opC)) (do ////.Monad<Operation> @@ -82,26 +78,26 @@ _ (typeA.infer (type (Either Text varT))) opA (typeA.with-type (type (IO varT)) (analyse opC))] - (wrap (#///.Extension extension (list opA)))) + (wrap (#analysis.Extension extension-name (list opA)))) _ - (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (lux//in-module extension) - (-> Text ..Handler) - (function (_ analyse argsC+) +(def: lux::in-module + analysis.Handler + (function (_ extension-name analyse argsC+) (case argsC+ (^ (list [_ (#.Text module-name)] exprC)) - (language.with-current-module module-name + (analysis.with-current-module module-name (analyse exprC)) _ - (language.throw ///bundle.invalid-syntax [extension])))) + (////.throw bundle.invalid-syntax [extension-name])))) ## (do-template [<name> <type>] -## [(def: (<name> extension) -## (-> Text ..Handler) -## (function (_ analyse args) +## [(def: <name> +## analysis.Handler +## (function (_ extension-name analyse args) ## (case args ## (^ (list typeC valueC)) ## (do ////.Monad<Operation> @@ -111,15 +107,15 @@ ## (analyse valueC))) ## _ -## (language.throw ///bundle.incorrect-arity [extension +2 (list.size args)]))))] +## (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)]))))] -## [lux//check (:coerce Type actualT)] -## [lux//coerce Any] +## [lux::check (:coerce Type actualT)] +## [lux::coerce Any] ## ) -(def: (lux//check//type extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: lux::check::type + analysis.Handler + (function (_ extension-name analyse args) (case args (^ (list valueC)) (do ////.Monad<Operation> @@ -129,145 +125,145 @@ (wrap valueA)) _ - (language.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)) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) + +(def: bundle::lux + Bundle + (|> bundle.empty + (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") + (|> bundle.empty + (bundle.install "log" (unary Text Any)) + (bundle.install "error" (unary Text Nothing)) + (bundle.install "exit" (unary Int Nothing)) + (bundle.install "current-time" (nullary Int))))) + +(def: bundle::bit + Bundle + (<| (bundle.prefix "bit") + (|> bundle.empty + (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 "to-frac" (unary Int Frac)) - (///bundle.install "char" (unary Int Text))))) - -(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 "to-rev" (unary Frac Rev)) - (///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 "char" (binary Text Nat (type (Maybe Nat)))) - (///bundle.install "clip" (trinary Text Nat Nat (type (Maybe Text)))) +(def: bundle::int + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (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 "to-frac" (unary Int Frac)) + (bundle.install "char" (unary Int Text))))) + +(def: bundle::frac + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary Frac Frac Frac)) + (bundle.install "-" (binary Frac Frac Frac)) + (bundle.install "*" (binary Frac Frac Frac)) + (bundle.install "/" (binary Frac Frac Frac)) + (bundle.install "%" (binary Frac Frac Frac)) + (bundle.install "=" (binary Frac Frac Bool)) + (bundle.install "<" (binary Frac Frac Bool)) + (bundle.install "smallest" (nullary Frac)) + (bundle.install "min" (nullary Frac)) + (bundle.install "max" (nullary Frac)) + (bundle.install "to-rev" (unary Frac Rev)) + (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") + (|> bundle.empty + (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 "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) +(def: array::get + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[var-id varT] (typeA.with-env tc.var)] - ((binary (type (Array varT)) Nat (type (Maybe varT)) extension) + ((binary (type (Array varT)) Nat (type (Maybe varT)) extension-name) analyse args)))) -(def: (array//put extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: array::put + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[var-id varT] (typeA.with-env tc.var)] - ((trinary (type (Array varT)) Nat varT (type (Array varT)) extension) + ((trinary (type (Array varT)) Nat varT (type (Array varT)) extension-name) analyse args)))) -(def: (array//remove extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: array::remove + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[var-id varT] (typeA.with-env tc.var)] - ((binary (type (Array varT)) Nat (type (Array varT)) extension) + ((binary (type (Array varT)) Nat (type (Array varT)) extension-name) 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::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (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: bundle::math + Bundle + (<| (bundle.prefix "math") + (|> bundle.empty + (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) +(def: atom::new + analysis.Handler + (function (_ extension-name analyse args) (case args (^ (list initC)) (do ////.Monad<Operation> @@ -275,39 +271,39 @@ _ (typeA.infer (type (Atom varT))) initA (typeA.with-type varT (analyse initC))] - (wrap (#///.Extension extension (list initA)))) + (wrap (#analysis.Extension extension-name (list initA)))) _ - (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (atom-read extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: atom::read + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[var-id varT] (typeA.with-env tc.var)] - ((unary (type (Atom varT)) varT extension) + ((unary (type (Atom varT)) varT extension-name) analyse args)))) -(def: (atom//compare-and-swap extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: atom::compare-and-swap + analysis.Handler + (function (_ extension-name analyse args) (do ////.Monad<Operation> [[var-id varT] (typeA.with-env tc.var)] - ((trinary (type (Atom varT)) varT varT Bool extension) + ((trinary (type (Atom varT)) varT varT Bool extension-name) 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: bundle::atom + Bundle + (<| (bundle.prefix "atom") + (|> bundle.empty + (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) +(def: box::new + analysis.Handler + (function (_ extension-name analyse args) (case args (^ (list initC)) (do ////.Monad<Operation> @@ -315,59 +311,59 @@ _ (typeA.infer (type (All [!] (Box ! varT)))) initA (typeA.with-type varT (analyse initC))] - (wrap (#///.Extension extension (list initA)))) + (wrap (#analysis.Extension extension-name (list initA)))) _ - (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (box//read extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: box::read + analysis.Handler + (function (_ extension-name analyse args) (do ////.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) + ((unary (type (Box threadT varT)) varT extension-name) analyse args)))) -(def: (box//write extension) - (-> Text ..Handler) - (function (_ analyse args) +(def: box::write + analysis.Handler + (function (_ extension-name analyse args) (do ////.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) + ((binary varT (type (Box threadT varT)) Any extension-name) 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::box + Bundle + (<| (bundle.prefix "box") + (|> bundle.empty + (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: bundle::process + Bundle + (<| (bundle.prefix "process") + (|> bundle.empty + (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/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)) + Bundle + (<| (bundle.prefix "lux") + (|> bundle.empty + (dict.merge bundle::lux) + (dict.merge bundle::bit) + (dict.merge bundle::int) + (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/language/compiler/extension/analysis/host.jvm.lux b/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux index e13b32c08..d25be6e40 100644 --- a/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux @@ -3,43 +3,50 @@ [control [monad (#+ do)] ["p" parser] - ["ex" exception (#+ exception:)]] + ["ex" exception (#+ exception:)] + pipe] [data ["e" error] [maybe] [product] - [bool ("bool/" Equivalence<Bool>)] [text ("text/" Equivalence<Text>) - format - ["l" lexer]] + format] [collection [list ("list/" Fold<List> Functor<List> Monoid<List>)] [array] - ["dict" dictionary (#+ Dictionary)]]] - [macro ("macro/" Monad<Meta>) - [code] + [dictionary (#+ Dictionary)]]] + ["." macro ["s" syntax]] - ["." language + [language ["." type - ["tc" check]]] + [check]]] [host]] - ["/" //common] - [//// - [".L" analysis (#+ Analysis) - [".A" type] - [".A" inference]]] - [///] + [// + [common] + ["/." // + [bundle] + ["//." // ("operation/" Monad<Operation>) + [analysis (#+ Analysis Operation Handler Bundle) + [".A" type] + [".A" inference]]]]] ) +(type: Method-Signature + {#method Type + #exceptions (List Type)}) + (host.import: #long java/lang/reflect/Type (getTypeName [] String)) -(def: jvm-type-name - (-> java/lang/reflect/Type Text) - (java/lang/reflect/Type::getTypeName [])) +(do-template [<name>] + [(exception: #export (<name> {jvm-type java/lang/reflect/Type}) + (ex.report ["JVM Type" (java/lang/reflect/Type::getTypeName [] jvm-type)]))] -(exception: #export (jvm-type-is-not-a-class {jvm-type java/lang/reflect/Type}) - (jvm-type-name jvm-type)) + [jvm-type-is-not-a-class] + [cannot-convert-to-a-class] + [cannot-convert-to-a-parameter] + [cannot-convert-to-a-lux-type] + ) (do-template [<name>] [(exception: #export (<name> {type Type}) @@ -77,20 +84,19 @@ [cannot-possibly-be-an-instance] - [cannot-convert-to-a-class] - [cannot-convert-to-a-parameter] - [cannot-convert-to-a-lux-type] [unknown-type-var] [type-parameter-mismatch] [cannot-correspond-type-with-a-class] ) (do-template [<name>] - [(exception: #export (<name> {class Text} {method Text} {hints (List [Type (List Type)])}) + [(exception: #export (<name> {class Text} + {method Text} + {hints (List Method-Signature)}) (ex.report ["Class" class] ["Method" method] ["Hints" (|> hints - (list/map (|>> %type (format "\n\t"))) + (list/map (|>> product.left %type (format "\n\t"))) (text.join-with ""))]))] [no-candidates] @@ -122,83 +128,83 @@ [char "char"] ) -(def: conversion-procs - /.Bundle - (<| (/.prefix "convert") - (|> (dict.new text.Hash<Text>) - (/.install "double-to-float" (/.unary Double Float)) - (/.install "double-to-int" (/.unary Double Integer)) - (/.install "double-to-long" (/.unary Double Long)) - (/.install "float-to-double" (/.unary Float Double)) - (/.install "float-to-int" (/.unary Float Integer)) - (/.install "float-to-long" (/.unary Float Long)) - (/.install "int-to-byte" (/.unary Integer Byte)) - (/.install "int-to-char" (/.unary Integer Character)) - (/.install "int-to-double" (/.unary Integer Double)) - (/.install "int-to-float" (/.unary Integer Float)) - (/.install "int-to-long" (/.unary Integer Long)) - (/.install "int-to-short" (/.unary Integer Short)) - (/.install "long-to-double" (/.unary Long Double)) - (/.install "long-to-float" (/.unary Long Float)) - (/.install "long-to-int" (/.unary Long Integer)) - (/.install "long-to-short" (/.unary Long Short)) - (/.install "long-to-byte" (/.unary Long Byte)) - (/.install "char-to-byte" (/.unary Character Byte)) - (/.install "char-to-short" (/.unary Character Short)) - (/.install "char-to-int" (/.unary Character Integer)) - (/.install "char-to-long" (/.unary Character Long)) - (/.install "byte-to-long" (/.unary Byte Long)) - (/.install "short-to-long" (/.unary Short Long)) +(def: bundle::conversion + Bundle + (<| (bundle.prefix "convert") + (|> bundle.empty + (bundle.install "double-to-float" (common.unary Double Float)) + (bundle.install "double-to-int" (common.unary Double Integer)) + (bundle.install "double-to-long" (common.unary Double Long)) + (bundle.install "float-to-double" (common.unary Float Double)) + (bundle.install "float-to-int" (common.unary Float Integer)) + (bundle.install "float-to-long" (common.unary Float Long)) + (bundle.install "int-to-byte" (common.unary Integer Byte)) + (bundle.install "int-to-char" (common.unary Integer Character)) + (bundle.install "int-to-double" (common.unary Integer Double)) + (bundle.install "int-to-float" (common.unary Integer Float)) + (bundle.install "int-to-long" (common.unary Integer Long)) + (bundle.install "int-to-short" (common.unary Integer Short)) + (bundle.install "long-to-double" (common.unary Long Double)) + (bundle.install "long-to-float" (common.unary Long Float)) + (bundle.install "long-to-int" (common.unary Long Integer)) + (bundle.install "long-to-short" (common.unary Long Short)) + (bundle.install "long-to-byte" (common.unary Long Byte)) + (bundle.install "char-to-byte" (common.unary Character Byte)) + (bundle.install "char-to-short" (common.unary Character Short)) + (bundle.install "char-to-int" (common.unary Character Integer)) + (bundle.install "char-to-long" (common.unary Character Long)) + (bundle.install "byte-to-long" (common.unary Byte Long)) + (bundle.install "short-to-long" (common.unary Short Long)) ))) (do-template [<name> <prefix> <type>] [(def: <name> - /.Bundle - (<| (/.prefix <prefix>) - (|> (dict.new text.Hash<Text>) - (/.install "+" (/.binary <type> <type> <type>)) - (/.install "-" (/.binary <type> <type> <type>)) - (/.install "*" (/.binary <type> <type> <type>)) - (/.install "/" (/.binary <type> <type> <type>)) - (/.install "%" (/.binary <type> <type> <type>)) - (/.install "=" (/.binary <type> <type> Boolean)) - (/.install "<" (/.binary <type> <type> Boolean)) - (/.install "and" (/.binary <type> <type> <type>)) - (/.install "or" (/.binary <type> <type> <type>)) - (/.install "xor" (/.binary <type> <type> <type>)) - (/.install "shl" (/.binary <type> Integer <type>)) - (/.install "shr" (/.binary <type> Integer <type>)) - (/.install "ushr" (/.binary <type> Integer <type>)) + Bundle + (<| (bundle.prefix <prefix>) + (|> bundle.empty + (bundle.install "+" (common.binary <type> <type> <type>)) + (bundle.install "-" (common.binary <type> <type> <type>)) + (bundle.install "*" (common.binary <type> <type> <type>)) + (bundle.install "/" (common.binary <type> <type> <type>)) + (bundle.install "%" (common.binary <type> <type> <type>)) + (bundle.install "=" (common.binary <type> <type> Boolean)) + (bundle.install "<" (common.binary <type> <type> Boolean)) + (bundle.install "and" (common.binary <type> <type> <type>)) + (bundle.install "or" (common.binary <type> <type> <type>)) + (bundle.install "xor" (common.binary <type> <type> <type>)) + (bundle.install "shl" (common.binary <type> Integer <type>)) + (bundle.install "shr" (common.binary <type> Integer <type>)) + (bundle.install "ushr" (common.binary <type> Integer <type>)) )))] - [int-procs "int" Integer] - [long-procs "long" Long] + [bundle::int "int" Integer] + [bundle::long "long" Long] ) (do-template [<name> <prefix> <type>] [(def: <name> - /.Bundle - (<| (/.prefix <prefix>) - (|> (dict.new text.Hash<Text>) - (/.install "+" (/.binary <type> <type> <type>)) - (/.install "-" (/.binary <type> <type> <type>)) - (/.install "*" (/.binary <type> <type> <type>)) - (/.install "/" (/.binary <type> <type> <type>)) - (/.install "%" (/.binary <type> <type> <type>)) - (/.install "=" (/.binary <type> <type> Boolean)) - (/.install "<" (/.binary <type> <type> Boolean)) + Bundle + (<| (bundle.prefix <prefix>) + (|> bundle.empty + (bundle.install "+" (common.binary <type> <type> <type>)) + (bundle.install "-" (common.binary <type> <type> <type>)) + (bundle.install "*" (common.binary <type> <type> <type>)) + (bundle.install "/" (common.binary <type> <type> <type>)) + (bundle.install "%" (common.binary <type> <type> <type>)) + (bundle.install "=" (common.binary <type> <type> Boolean)) + (bundle.install "<" (common.binary <type> <type> Boolean)) )))] - [float-procs "float" Float] - [double-procs "double" Double] + [bundle::float "float" Float] + [bundle::double "double" Double] ) -(def: char-procs - /.Bundle - (<| (/.prefix "char") - (|> (dict.new text.Hash<Text>) - (/.install "=" (/.binary Character Character Boolean)) - (/.install "<" (/.binary Character Character Boolean)) +(def: bundle::char + Bundle + (<| (bundle.prefix "char") + (|> bundle.empty + (bundle.install "=" (common.binary Character Character Boolean)) + (bundle.install "<" (common.binary Character Character Boolean)) ))) (def: #export boxes @@ -211,33 +217,33 @@ ["float" "java.lang.Float"] ["double" "java.lang.Double"] ["char" "java.lang.Character"]) - (dict.from-list text.Hash<Text>))) + (dictionary.from-list text.Hash<Text>))) -(def: (array//length proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: array::length + Handler + (function (_ extension-name analyse args) (case args (^ (list arrayC)) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [_ (typeA.infer Nat) - [var-id varT] (typeA.with-env tc.var) + [var-id varT] (typeA.with-env check.var) arrayA (typeA.with-type (type (Array varT)) (analyse arrayC))] - (wrap (#analysisL.Extension proc (list arrayA)))) + (wrap (#analysis.Extension extension-name (list arrayA)))) _ - (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (array//new proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: array::new + Handler + (function (_ extension-name analyse args) (case args (^ (list lengthC)) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [lengthA (typeA.with-type Nat (analyse lengthC)) - expectedT macro.expected-type - [level elem-class] (: (Meta [Nat Text]) + expectedT (///.lift macro.expected-type) + [level elem-class] (: (Operation [Nat Text]) (loop [analysisT expectedT level +0] (case analysisT @@ -247,7 +253,7 @@ (recur outputT level) #.None - (language.throw non-array expectedT)) + (////.throw non-array expectedT)) (^ (#.Primitive "#Array" (list elemT))) (recur elemT (inc level)) @@ -256,28 +262,28 @@ (wrap [level class]) _ - (language.throw non-array expectedT)))) + (////.throw non-array expectedT)))) _ (if (n/> +0 level) (wrap []) - (language.throw non-array expectedT))] - (wrap (#analysisL.Extension proc (list (analysisL.nat (dec level)) - (analysisL.text elem-class) - lengthA)))) + (////.throw non-array expectedT))] + (wrap (#analysis.Extension extension-name (list (analysis.nat (dec level)) + (analysis.text elem-class) + lengthA)))) _ - (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) (def: (check-jvm objectT) - (-> Type (Meta Text)) + (-> Type (Operation Text)) (case objectT (#.Primitive name _) - (macro/wrap name) + (operation/wrap name) (#.Named name unnamed) (check-jvm unnamed) (#.Var id) - (macro/wrap "java.lang.Object") + (operation/wrap "java.lang.Object") (^template [<tag>] (<tag> env unquantified) @@ -291,130 +297,130 @@ (check-jvm outputT) #.None - (language.throw non-object objectT)) + (////.throw non-object objectT)) _ - (language.throw non-object objectT))) + (////.throw non-object objectT))) (def: (check-object objectT) - (-> Type (Meta Text)) - (do macro.Monad<Meta> + (-> Type (Operation Text)) + (do ////.Monad<Operation> [name (check-jvm objectT)] - (if (dict.contains? name boxes) - (language.throw primitives-are-not-objects name) - (macro/wrap name)))) + (if (dictionary.contains? name boxes) + (////.throw primitives-are-not-objects name) + (operation/wrap name)))) (def: (box-array-element-type elemT) - (-> Type (Meta [Type Text])) + (-> Type (Operation [Type Text])) (case elemT (#.Primitive name #.Nil) - (let [boxed-name (|> (dict.get name boxes) + (let [boxed-name (|> (dictionary.get name boxes) (maybe.default name))] - (macro/wrap [(#.Primitive boxed-name #.Nil) - boxed-name])) + (operation/wrap [(#.Primitive boxed-name #.Nil) + boxed-name])) (#.Primitive name _) - (if (dict.contains? name boxes) - (language.throw primitives-cannot-have-type-parameters name) - (macro/wrap [elemT name])) + (if (dictionary.contains? name boxes) + (////.throw primitives-cannot-have-type-parameters name) + (operation/wrap [elemT name])) _ - (language.throw invalid-type-for-array-element (%type elemT)))) + (////.throw invalid-type-for-array-element (%type elemT)))) -(def: (array//read proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: array::read + Handler + (function (_ extension-name analyse args) (case args (^ (list arrayC idxC)) - (do macro.Monad<Meta> - [[var-id varT] (typeA.with-env tc.var) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env check.var) _ (typeA.infer varT) arrayA (typeA.with-type (type (Array varT)) (analyse arrayC)) ?elemT (typeA.with-env - (tc.read var-id)) + (check.read var-id)) [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) idxA (typeA.with-type Nat (analyse idxC))] - (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA arrayA)))) + (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA arrayA)))) _ - (language.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)])))) -(def: (array//write proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: array::write + Handler + (function (_ extension-name analyse args) (case args (^ (list arrayC idxC valueC)) - (do macro.Monad<Meta> - [[var-id varT] (typeA.with-env tc.var) + (do ////.Monad<Operation> + [[var-id varT] (typeA.with-env check.var) _ (typeA.infer (type (Array varT))) arrayA (typeA.with-type (type (Array varT)) (analyse arrayC)) ?elemT (typeA.with-env - (tc.read var-id)) + (check.read var-id)) [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) idxA (typeA.with-type Nat (analyse idxC)) valueA (typeA.with-type valueT (analyse valueC))] - (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA valueA arrayA)))) + (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA valueA arrayA)))) _ - (language.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) - -(def: array-procs - /.Bundle - (<| (/.prefix "array") - (|> (dict.new text.Hash<Text>) - (/.install "length" array//length) - (/.install "new" array//new) - (/.install "read" array//read) - (/.install "write" array//write) + (////.throw bundle.incorrect-arity [extension-name +3 (list.size args)])))) + +(def: bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "length" array::length) + (bundle.install "new" array::new) + (bundle.install "read" array::read) + (bundle.install "write" array::write) ))) -(def: (object//null proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::null + Handler + (function (_ extension-name analyse args) (case args (^ (list)) - (do macro.Monad<Meta> - [expectedT macro.expected-type + (do ////.Monad<Operation> + [expectedT (///.lift macro.expected-type) _ (check-object expectedT)] - (wrap (#analysisL.Extension proc (list)))) + (wrap (#analysis.Extension extension-name (list)))) _ - (language.throw /.incorrect-extension-arity [proc +0 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +0 (list.size args)])))) -(def: (object//null? proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::null? + Handler + (function (_ extension-name analyse args) (case args (^ (list objectC)) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [_ (typeA.infer Bool) [objectT objectA] (typeA.with-inference (analyse objectC)) _ (check-object objectT)] - (wrap (#analysisL.Extension proc (list objectA)))) + (wrap (#analysis.Extension extension-name (list objectA)))) _ - (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (object//synchronized proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::synchronized + Handler + (function (_ extension-name analyse args) (case args (^ (list monitorC exprC)) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [[monitorT monitorA] (typeA.with-inference (analyse monitorC)) _ (check-object monitorT) exprA (analyse exprC)] - (wrap (#analysisL.Extension proc (list monitorA exprA)))) + (wrap (#analysis.Extension extension-name (list monitorA exprA)))) _ - (language.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)])))) (host.import: java/lang/Object (equals [Object] boolean)) @@ -476,110 +482,110 @@ (getDeclaredMethods [] (Array Method))) (def: (load-class name) - (-> Text (Meta (Class Object))) - (do macro.Monad<Meta> + (-> Text (Operation (Class Object))) + (do ////.Monad<Operation> [] (case (Class::forName [name]) (#e.Success [class]) (wrap class) (#e.Error error) - (language.throw unknown-class name)))) + (////.throw unknown-class name)))) (def: (sub-class? super sub) - (-> Text Text (Meta Bool)) - (do macro.Monad<Meta> + (-> Text Text (Operation Bool)) + (do ////.Monad<Operation> [super (load-class super) sub (load-class sub)] (wrap (Class::isAssignableFrom [sub] super)))) -(def: (object//throw proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::throw + Handler + (function (_ extension-name analyse args) (case args (^ (list exceptionC)) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [_ (typeA.infer Nothing) [exceptionT exceptionA] (typeA.with-inference (analyse exceptionC)) exception-class (check-object exceptionT) ? (sub-class? "java.lang.Throwable" exception-class) - _ (: (Meta Any) + _ (: (Operation Any) (if ? (wrap []) - (language.throw non-throwable exception-class)))] - (wrap (#analysisL.Extension proc (list exceptionA)))) + (////.throw non-throwable exception-class)))] + (wrap (#analysis.Extension extension-name (list exceptionA)))) _ - (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (object//class proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::class + Handler + (function (_ extension-name analyse args) (case args (^ (list classC)) (case classC [_ (#.Text class)] - (do macro.Monad<Meta> + (do ////.Monad<Operation> [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) _ (load-class class)] - (wrap (#analysisL.Extension proc (list (analysisL.text class))))) + (wrap (#analysis.Extension extension-name (list (analysis.text class))))) _ - (language.throw /.invalid-syntax [proc args])) + (////.throw bundle.invalid-syntax extension-name)) _ - (language.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)])))) -(def: (object//instance? proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::instance? + Handler + (function (_ extension-name analyse args) (case args (^ (list classC objectC)) (case classC [_ (#.Text class)] - (do macro.Monad<Meta> + (do ////.Monad<Operation> [_ (typeA.infer Bool) [objectT objectA] (typeA.with-inference (analyse objectC)) object-class (check-object objectT) ? (sub-class? class object-class)] (if ? - (wrap (#analysisL.Extension proc (list (analysisL.text class)))) - (language.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) + (wrap (#analysis.Extension extension-name (list (analysis.text class)))) + (////.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) _ - (language.throw /.invalid-syntax [proc args])) + (////.throw bundle.invalid-syntax extension-name)) _ - (language.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)])))) -(def: (java-type-to-class type) - (-> java/lang/reflect/Type (Meta Text)) - (cond (host.instance? Class type) - (macro/wrap (Class::getName [] (:coerce Class type))) +(def: (java-type-to-class jvm-type) + (-> java/lang/reflect/Type (Operation Text)) + (cond (host.instance? Class jvm-type) + (operation/wrap (Class::getName [] (:coerce Class jvm-type))) - (host.instance? ParameterizedType type) - (java-type-to-class (ParameterizedType::getRawType [] (:coerce ParameterizedType type))) + (host.instance? ParameterizedType jvm-type) + (java-type-to-class (ParameterizedType::getRawType [] (:coerce ParameterizedType jvm-type))) ## else - (language.throw cannot-convert-to-a-class (jvm-type-name type)))) + (////.throw cannot-convert-to-a-class jvm-type))) (type: Mappings (Dictionary Text Type)) -(def: fresh-mappings Mappings (dict.new text.Hash<Text>)) +(def: fresh-mappings Mappings (dictionary.new text.Hash<Text>)) (def: (java-type-to-lux-type mappings java-type) - (-> Mappings java/lang/reflect/Type (Meta Type)) + (-> Mappings java/lang/reflect/Type (Operation Type)) (cond (host.instance? TypeVariable java-type) (let [var-name (TypeVariable::getName [] (:coerce TypeVariable java-type))] - (case (dict.get var-name mappings) + (case (dictionary.get var-name mappings) (#.Some var-type) - (macro/wrap var-type) + (operation/wrap var-type) #.None - (language.throw unknown-type-var var-name))) + (////.throw unknown-type-var var-name))) (host.instance? WildcardType java-type) (let [java-type (:coerce WildcardType java-type)] @@ -589,47 +595,47 @@ (java-type-to-lux-type mappings bound) _ - (macro/wrap Any))) + (operation/wrap Any))) (host.instance? Class java-type) (let [java-type (:coerce (Class Object) java-type) class-name (Class::getName [] java-type)] - (macro/wrap (case (array.size (Class::getTypeParameters [] java-type)) - +0 - (#.Primitive class-name (list)) - - arity - (|> (list.n/range +0 (dec arity)) - list.reverse - (list/map (|>> (n/* +2) inc #.Parameter)) - (#.Primitive class-name) - (type.univ-q arity))))) + (operation/wrap (case (array.size (Class::getTypeParameters [] java-type)) + +0 + (#.Primitive class-name (list)) + + arity + (|> (list.n/range +0 (dec arity)) + list.reverse + (list/map (|>> (n/* +2) inc #.Parameter)) + (#.Primitive class-name) + (type.univ-q arity))))) (host.instance? ParameterizedType java-type) (let [java-type (:coerce ParameterizedType java-type) raw (ParameterizedType::getRawType [] java-type)] (if (host.instance? Class raw) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [paramsT (|> java-type (ParameterizedType::getActualTypeArguments []) array.to-list (monad.map @ (java-type-to-lux-type mappings)))] - (macro/wrap (#.Primitive (Class::getName [] (:coerce (Class Object) raw)) - paramsT))) - (language.throw jvm-type-is-not-a-class raw))) + (operation/wrap (#.Primitive (Class::getName [] (:coerce (Class Object) raw)) + paramsT))) + (////.throw jvm-type-is-not-a-class raw))) (host.instance? GenericArrayType java-type) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [innerT (|> (:coerce GenericArrayType java-type) (GenericArrayType::getGenericComponentType []) (java-type-to-lux-type mappings))] (wrap (#.Primitive "#Array" (list innerT)))) ## else - (language.throw cannot-convert-to-a-lux-type (jvm-type-name java-type)))) + (////.throw cannot-convert-to-a-lux-type java-type))) (def: (correspond-type-params class type) - (-> (Class Object) Type (Meta Mappings)) + (-> (Class Object) Type (Operation Mappings)) (case type (#.Primitive name params) (let [class-name (Class::getName [] class) @@ -637,38 +643,38 @@ num-class-params (list.size class-params) num-type-params (list.size params)] (cond (not (text/= class-name name)) - (language.throw cannot-correspond-type-with-a-class - (format "Class = " class-name "\n" - "Type = " (%type type))) + (////.throw cannot-correspond-type-with-a-class + (format "Class = " class-name "\n" + "Type = " (%type type))) (not (n/= num-class-params num-type-params)) - (language.throw type-parameter-mismatch - (format "Expected: " (%i (.int num-class-params)) "\n" - " Actual: " (%i (.int num-type-params)) "\n" - " Class: " class-name "\n" - " Type: " (%type type))) + (////.throw type-parameter-mismatch + (format "Expected: " (%i (.int num-class-params)) "\n" + " Actual: " (%i (.int num-type-params)) "\n" + " Class: " class-name "\n" + " Type: " (%type type))) ## else - (macro/wrap (|> params - (list.zip2 (list/map (TypeVariable::getName []) class-params)) - (dict.from-list text.Hash<Text>))) + (operation/wrap (|> params + (list.zip2 (list/map (TypeVariable::getName []) class-params)) + (dictionary.from-list text.Hash<Text>))) )) _ - (language.throw non-jvm-type type))) + (////.throw non-jvm-type type))) -(def: (object//cast proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: object::cast + Handler + (function (_ extension-name analyse args) (case args (^ (list valueC)) - (do macro.Monad<Meta> - [toT macro.expected-type + (do ////.Monad<Operation> + [toT (///.lift macro.expected-type) to-name (check-jvm toT) [valueT valueA] (typeA.with-inference (analyse valueC)) from-name (check-jvm valueT) - can-cast? (: (Meta Bool) + can-cast? (: (Operation Bool) (case [from-name to-name] (^template [<primitive> <object>] (^or [<primitive> <object>] @@ -687,10 +693,10 @@ _ (do @ - [_ (language.assert primitives-are-not-objects from-name - (not (dict.contains? from-name boxes))) - _ (language.assert primitives-are-not-objects to-name - (not (dict.contains? to-name boxes))) + [_ (////.assert primitives-are-not-objects from-name + (not (dictionary.contains? from-name boxes))) + _ (////.assert primitives-are-not-objects to-name + (not (dictionary.contains? to-name boxes))) to-class (load-class to-name)] (loop [[current-name currentT] [from-name valueT]] (if (text/= to-name current-name) @@ -699,10 +705,10 @@ (wrap true)) (do @ [current-class (load-class current-name) - _ (language.assert cannot-cast (format "From class/primitive: " current-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n") - (Class::isAssignableFrom [current-class] to-class)) + _ (////.assert cannot-cast (format "From class/primitive: " current-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n") + (Class::isAssignableFrom [current-class] to-class)) candiate-parents (monad.map @ (function (_ java-type) (do @ @@ -721,54 +727,54 @@ (recur [next-name nextT])) #.Nil - (language.throw cannot-cast (format "From class/primitive: " from-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n"))) + (////.throw cannot-cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n"))) ))))))] (if can-cast? - (wrap (#analysisL.Extension proc (list (analysisL.text from-name) - (analysisL.text to-name) - valueA))) - (language.throw cannot-cast (format "From class/primitive: " from-name "\n" - " To class/primitive: " to-name "\n" - " For value: " (%code valueC) "\n")))) + (wrap (#analysis.Extension extension-name (list (analysis.text from-name) + (analysis.text to-name) + valueA))) + (////.throw cannot-cast (format "From class/primitive: " from-name "\n" + " To class/primitive: " to-name "\n" + " For value: " (%code valueC) "\n")))) _ - (language.throw /.invalid-syntax [proc args])))) - -(def: object-procs - /.Bundle - (<| (/.prefix "object") - (|> (dict.new text.Hash<Text>) - (/.install "null" object//null) - (/.install "null?" object//null?) - (/.install "synchronized" object//synchronized) - (/.install "throw" object//throw) - (/.install "class" object//class) - (/.install "instance?" object//instance?) - (/.install "cast" object//cast) + (////.throw bundle.invalid-syntax extension-name)))) + +(def: bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "null" object::null) + (bundle.install "null?" object::null?) + (bundle.install "synchronized" object::synchronized) + (bundle.install "throw" object::throw) + (bundle.install "class" object::class) + (bundle.install "instance?" object::instance?) + (bundle.install "cast" object::cast) ))) (def: (find-field class-name field-name) - (-> Text Text (Meta [(Class Object) Field])) - (do macro.Monad<Meta> + (-> Text Text (Operation [(Class Object) Field])) + (do ////.Monad<Operation> [class (load-class class-name)] (case (Class::getDeclaredField [field-name] class) (#e.Success field) (let [owner (Field::getDeclaringClass [] field)] (if (is? owner class) (wrap [class field]) - (language.throw mistaken-field-owner - (format " Field: " field-name "\n" - " Owner Class: " (Class::getName [] owner) "\n" - "Target Class: " class-name "\n")))) + (////.throw mistaken-field-owner + (format " Field: " field-name "\n" + " Owner Class: " (Class::getName [] owner) "\n" + "Target Class: " class-name "\n")))) (#e.Error _) - (language.throw unknown-field (format class-name "#" field-name))))) + (////.throw unknown-field (format class-name "#" field-name))))) (def: (static-field class-name field-name) - (-> Text Text (Meta [Type Bool])) - (do macro.Monad<Meta> + (-> Text Text (Operation [Type Bool])) + (do ////.Monad<Operation> [[class fieldJ] (find-field class-name field-name) #let [modifiers (Field::getModifiers [] fieldJ)]] (if (Modifier::isStatic [modifiers]) @@ -776,11 +782,11 @@ (do @ [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] (wrap [fieldT (Modifier::isFinal [modifiers])]))) - (language.throw not-a-static-field (format class-name "#" field-name))))) + (////.throw not-a-static-field (format class-name "#" field-name))))) (def: (virtual-field class-name field-name objectT) - (-> Text Text Type (Meta [Type Bool])) - (do macro.Monad<Meta> + (-> Text Text Type (Operation [Type Bool])) + (do ////.Monad<Operation> [[class fieldJ] (find-field class-name field-name) #let [modifiers (Field::getModifiers [] fieldJ)]] (if (not (Modifier::isStatic [modifiers])) @@ -790,130 +796,130 @@ (Class::getTypeParameters []) array.to-list (list/map (TypeVariable::getName [])))] - mappings (: (Meta Mappings) + mappings (: (Operation Mappings) (case objectT (#.Primitive _class-name _class-params) (do @ [#let [num-params (list.size _class-params) num-vars (list.size var-names)] - _ (language.assert type-parameter-mismatch - (format "Expected: " (%i (.int num-params)) "\n" - " Actual: " (%i (.int num-vars)) "\n" - " Class: " _class-name "\n" - " Type: " (%type objectT)) - (n/= num-params num-vars))] + _ (////.assert type-parameter-mismatch + (format "Expected: " (%i (.int num-params)) "\n" + " Actual: " (%i (.int num-vars)) "\n" + " Class: " _class-name "\n" + " Type: " (%type objectT)) + (n/= num-params num-vars))] (wrap (|> (list.zip2 var-names _class-params) - (dict.from-list text.Hash<Text>)))) + (dictionary.from-list text.Hash<Text>)))) _ - (language.throw non-object objectT))) + (////.throw non-object objectT))) fieldT (java-type-to-lux-type mappings fieldJT)] (wrap [fieldT (Modifier::isFinal [modifiers])])) - (language.throw not-a-virtual-field (format class-name "#" field-name))))) + (////.throw not-a-virtual-field (format class-name "#" field-name))))) -(def: (static//get proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: static::get + Handler + (function (_ extension-name analyse args) (case args (^ (list classC fieldC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad<Meta> + (do ////.Monad<Operation> [[fieldT final?] (static-field class field)] - (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field))))) + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field))))) _ - (language.throw /.invalid-syntax [proc args])) + (////.throw bundle.invalid-syntax extension-name)) _ - (language.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)])))) -(def: (static//put proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: static::put + Handler + (function (_ extension-name analyse args) (case args (^ (list classC fieldC valueC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad<Meta> + (do ////.Monad<Operation> [_ (typeA.infer Any) [fieldT final?] (static-field class field) - _ (language.assert cannot-set-a-final-field (format class "#" field) - (not final?)) + _ (////.assert cannot-set-a-final-field (format class "#" field) + (not final?)) valueA (typeA.with-type fieldT (analyse valueC))] - (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA)))) + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA)))) _ - (language.throw /.invalid-syntax [proc args])) + (////.throw bundle.invalid-syntax extension-name)) _ - (language.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +3 (list.size args)])))) -(def: (virtual//get proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: virtual::get + Handler + (function (_ extension-name analyse args) (case args (^ (list classC fieldC objectC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad<Meta> + (do ////.Monad<Operation> [[objectT objectA] (typeA.with-inference (analyse objectC)) [fieldT final?] (virtual-field class field objectT)] - (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) objectA)))) + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) objectA)))) _ - (language.throw /.invalid-syntax [proc args])) + (////.throw bundle.invalid-syntax extension-name)) _ - (language.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +3 (list.size args)])))) -(def: (virtual//put proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: virtual::put + Handler + (function (_ extension-name analyse args) (case args (^ (list classC fieldC valueC objectC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] - (do macro.Monad<Meta> + (do ////.Monad<Operation> [[objectT objectA] (typeA.with-inference (analyse objectC)) _ (typeA.infer objectT) [fieldT final?] (virtual-field class field objectT) - _ (language.assert cannot-set-a-final-field (format class "#" field) - (not final?)) + _ (////.assert cannot-set-a-final-field (format class "#" field) + (not final?)) valueA (typeA.with-type fieldT (analyse valueC))] - (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA objectA)))) + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA objectA)))) _ - (language.throw /.invalid-syntax [proc args])) + (////.throw bundle.invalid-syntax extension-name)) _ - (language.throw /.incorrect-extension-arity [proc +4 (list.size args)])))) + (////.throw bundle.incorrect-arity [extension-name +4 (list.size args)])))) (def: (java-type-to-parameter type) - (-> java/lang/reflect/Type (Meta Text)) + (-> java/lang/reflect/Type (Operation Text)) (cond (host.instance? Class type) - (macro/wrap (Class::getName [] (:coerce Class type))) + (operation/wrap (Class::getName [] (:coerce Class type))) (host.instance? ParameterizedType type) (java-type-to-parameter (ParameterizedType::getRawType [] (:coerce ParameterizedType type))) (or (host.instance? TypeVariable type) (host.instance? WildcardType type)) - (macro/wrap "java.lang.Object") + (operation/wrap "java.lang.Object") (host.instance? GenericArrayType type) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:coerce GenericArrayType type)))] (wrap (format componentP "[]"))) ## else - (language.throw cannot-convert-to-a-parameter (jvm-type-name type)))) + (////.throw cannot-convert-to-a-parameter type))) -(type: Method-style +(type: Method-Style #Static #Abstract #Virtual @@ -921,8 +927,8 @@ #Interface) (def: (check-method class method-name method-style arg-classes method) - (-> (Class Object) Text Method-style (List Text) Method (Meta Bool)) - (do macro.Monad<Meta> + (-> (Class Object) Text Method-Style (List Text) Method (Operation Bool)) + (do ////.Monad<Operation> [parameters (|> (Method::getGenericParameterTypes [] method) array.to-list (monad.map @ java-type-to-parameter)) @@ -950,8 +956,8 @@ (list.zip2 arg-classes parameters)))))) (def: (check-constructor class arg-classes constructor) - (-> (Class Object) (List Text) (Constructor Object) (Meta Bool)) - (do macro.Monad<Meta> + (-> (Class Object) (List Text) (Constructor Object) (Operation Bool)) + (do ////.Monad<Operation> [parameters (|> (Constructor::getGenericParameterTypes [] constructor) array.to-list (monad.map @ java-type-to-parameter))] @@ -974,8 +980,8 @@ (|> (list.n/range offset (|> amount dec (n/+ offset))) (list/map idx-to-parameter)))) -(def: (method-to-type method-style method) - (-> Method-style Method (Meta [Type (List Type)])) +(def: (method-signature method-style method) + (-> Method-Style Method (Operation Method-Signature)) (let [owner (Method::getDeclaringClass [] method) owner-name (Class::getName [] owner) owner-tvars (case method-style @@ -1001,8 +1007,8 @@ (|> (list/compose owner-tvarsT method-tvarsT) list.reverse (list.zip2 all-tvars) - (dict.from-list text.Hash<Text>))))] - (do macro.Monad<Meta> + (dictionary.from-list text.Hash<Text>))))] + (do ////.Monad<Operation> [inputsT (|> (Method::getGenericParameterTypes [] method) array.to-list (monad.map @ (java-type-to-lux-type mappings))) @@ -1021,14 +1027,14 @@ outputT)]] (wrap [methodT exceptionsT])))) -(type: (Evaluation a) - (#Pass a) - (#Hint a) +(type: Evaluation + (#Pass Method-Signature) + (#Hint Method-Signature) #Fail) (do-template [<name> <tag>] [(def: <name> - (All [a] (-> (Evaluation a) (Maybe a))) + (-> Evaluation (Maybe Method-Signature)) (|>> (case> (<tag> output) (#.Some output) @@ -1040,40 +1046,36 @@ ) (def: (method-candidate class-name method-name method-style arg-classes) - (-> Text Text Method-style (List Text) (Meta [Type (List Type)])) - (do macro.Monad<Meta> + (-> Text Text Method-Style (List Text) (Operation Method-Signature)) + (do ////.Monad<Operation> [class (load-class class-name) candidates (|> class (Class::getDeclaredMethods []) array.to-list - (monad.map @ (: (-> Method (Meta (Evaluation Method))) + (monad.map @ (: (-> Method (Operation Evaluation)) (function (_ method) (do @ [passes? (check-method class method-name method-style arg-classes method)] - (wrap (cond passes? - (#Pass method) + (cond passes? + (:: @ map (|>> #Pass) (method-signature method-style method)) - (text/= method-name (Method::getName [] method)) - (#Hint method) + (text/= method-name (Method::getName [] method)) + (:: @ map (|>> #Hint) (method-signature method-style method)) - ## else - #Fail)))))))] + ## else + (wrap #Fail)))))))] (case (list.search-all pass! candidates) #.Nil - (language.throw no-candidates [class-name method-name - (|> candidates - (list.search-all hint!) - (list/map (method-to-type method-style)))]) + (////.throw no-candidates [class-name method-name (list.search-all hint! candidates)]) (#.Cons method #.Nil) - (method-to-type method-style method) + (wrap method) candidates - (language.throw too-many-candidates [class-name method-name - (list/map (method-to-type method-style) candidates)])))) + (////.throw too-many-candidates [class-name method-name candidates])))) -(def: (constructor-to-type constructor) - (-> (Constructor Object) (Meta [Type (List Type)])) +(def: (constructor-signature constructor) + (-> (Constructor Object) (Operation Method-Signature)) (let [owner (Constructor::getDeclaringClass [] constructor) owner-name (Class::getName [] owner) owner-tvars (|> (Class::getTypeParameters [] owner) @@ -1093,8 +1095,8 @@ (|> (list/compose owner-tvarsT constructor-tvarsT) list.reverse (list.zip2 all-tvars) - (dict.from-list text.Hash<Text>))))] - (do macro.Monad<Meta> + (dictionary.from-list text.Hash<Text>))))] + (do ////.Monad<Operation> [inputsT (|> (Constructor::getGenericParameterTypes [] constructor) array.to-list (monad.map @ (java-type-to-lux-type mappings))) @@ -1110,8 +1112,8 @@ (def: constructor-method "<init>") (def: (constructor-candidate class-name arg-classes) - (-> Text (List Text) (Meta [Type (List Type)])) - (do macro.Monad<Meta> + (-> Text (List Text) (Operation Method-Signature)) + (do ////.Monad<Operation> [class (load-class class-name) candidates (|> class (Class::getConstructors []) @@ -1119,52 +1121,50 @@ (monad.map @ (function (_ constructor) (do @ [passes? (check-constructor class arg-classes constructor)] - (wrap [passes? constructor])))))] + (:: @ map + (if passes? (|>> #Pass) (|>> #Hint)) + (constructor-signature constructor))))))] (case (list.search-all pass! candidates) #.Nil - (language.throw no-candidates [class-name ..constructor-method - (|> candidates - (list.search-all hint!) - (list/map constructor-to-type))]) + (////.throw no-candidates [class-name ..constructor-method (list.search-all hint! candidates)]) (#.Cons constructor #.Nil) - (constructor-to-type constructor) + (wrap constructor) candidates - (language.throw too-many-candidates [class-name ..constructor-method - (list/map constructor-to-type candidates)])))) + (////.throw too-many-candidates [class-name ..constructor-method candidates])))) (def: (decorate-inputs typesT inputsA) (-> (List Text) (List Analysis) (List Analysis)) (|> inputsA - (list.zip2 (list/map analysisL.text typesT)) + (list.zip2 (list/map analysis.text typesT)) (list/map (function (_ [type value]) - (analysisL.product-analysis (list type value)))))) + (analysis.product-analysis (list type value)))))) -(def: (invoke//static proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: invoke::static + Handler + (function (_ extension-name analyse args) (case (: (e.Error [Text Text (List [Text Code])]) (s.run args ($_ p.seq s.text s.text (p.some (s.tuple (p.seq s.text s.any)))))) (#e.Success [class method argsTC]) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (method-candidate class method #Static argsT) [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) outputJC (check-jvm outputT)] - (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) - (analysisL.text outputJC) (decorate-inputs argsT argsA))))) + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) + (analysis.text outputJC) (decorate-inputs argsT argsA))))) _ - (language.throw /.invalid-syntax [proc args])))) + (////.throw bundle.invalid-syntax extension-name)))) -(def: (invoke//virtual proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: invoke::virtual + Handler + (function (_ extension-name analyse args) (case (: (e.Error [Text Text Code (List [Text Code])]) (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) (#e.Success [class method objectC argsTC]) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (method-candidate class method #Virtual argsT) [outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) @@ -1175,98 +1175,98 @@ _ (undefined))] outputJC (check-jvm outputT)] - (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) - (analysisL.text outputJC) objectA (decorate-inputs argsT argsA))))) + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) + (analysis.text outputJC) objectA (decorate-inputs argsT argsA))))) _ - (language.throw /.invalid-syntax [proc args])))) + (////.throw bundle.invalid-syntax extension-name)))) -(def: (invoke//special proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: invoke::special + Handler + (function (_ extension-name analyse args) (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Any]]) (p.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))) s.end!))) (#e.Success [_ [class method objectC argsTC _]]) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (method-candidate class method #Special argsT) [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) outputJC (check-jvm outputT)] - (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) - (analysisL.text outputJC) (decorate-inputs argsT argsA))))) + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) + (analysis.text outputJC) (decorate-inputs argsT argsA))))) _ - (language.throw /.invalid-syntax [proc args])))) + (////.throw bundle.invalid-syntax extension-name)))) -(def: (invoke//interface proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: invoke::interface + Handler + (function (_ extension-name analyse args) (case (: (e.Error [Text Text Code (List [Text Code])]) (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any)))))) (#e.Success [class-name method objectC argsTC]) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [#let [argsT (list/map product.left argsTC)] class (load-class class-name) - _ (language.assert non-interface class-name - (Modifier::isInterface [(Class::getModifiers [] class)])) + _ (////.assert non-interface class-name + (Modifier::isInterface [(Class::getModifiers [] class)])) [methodT exceptionsT] (method-candidate class-name method #Interface argsT) [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) outputJC (check-jvm outputT)] - (wrap (#analysisL.Extension proc - (list& (analysisL.text class-name) (analysisL.text method) (analysisL.text outputJC) - (decorate-inputs argsT argsA))))) + (wrap (#analysis.Extension extension-name + (list& (analysis.text class-name) (analysis.text method) (analysis.text outputJC) + (decorate-inputs argsT argsA))))) _ - (language.throw /.invalid-syntax [proc args])))) + (////.throw bundle.invalid-syntax extension-name)))) -(def: (invoke//constructor proc) - (-> Text ///.Analysis) - (function (_ analyse eval args) +(def: invoke::constructor + Handler + (function (_ extension-name analyse args) (case (: (e.Error [Text (List [Text Code])]) (s.run args ($_ p.seq s.text (p.some (s.tuple (p.seq s.text s.any)))))) (#e.Success [class argsTC]) - (do macro.Monad<Meta> + (do ////.Monad<Operation> [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (constructor-candidate class argsT) [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] - (wrap (#analysisL.Extension proc (list& (analysisL.text class) (decorate-inputs argsT argsA))))) + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (decorate-inputs argsT argsA))))) _ - (language.throw /.invalid-syntax [proc args])))) - -(def: member-procs - /.Bundle - (<| (/.prefix "member") - (|> (dict.new text.Hash<Text>) - (dict.merge (<| (/.prefix "static") - (|> (dict.new text.Hash<Text>) - (/.install "get" static//get) - (/.install "put" static//put)))) - (dict.merge (<| (/.prefix "virtual") - (|> (dict.new text.Hash<Text>) - (/.install "get" virtual//get) - (/.install "put" virtual//put)))) - (dict.merge (<| (/.prefix "invoke") - (|> (dict.new text.Hash<Text>) - (/.install "static" invoke//static) - (/.install "virtual" invoke//virtual) - (/.install "special" invoke//special) - (/.install "interface" invoke//interface) - (/.install "constructor" invoke//constructor) - ))) + (////.throw bundle.invalid-syntax extension-name)))) + +(def: bundle::member + Bundle + (<| (bundle.prefix "member") + (|> bundle.empty + (dictionary.merge (<| (bundle.prefix "static") + (|> bundle.empty + (bundle.install "get" static::get) + (bundle.install "put" static::put)))) + (dictionary.merge (<| (bundle.prefix "virtual") + (|> bundle.empty + (bundle.install "get" virtual::get) + (bundle.install "put" virtual::put)))) + (dictionary.merge (<| (bundle.prefix "invoke") + (|> bundle.empty + (bundle.install "static" invoke::static) + (bundle.install "virtual" invoke::virtual) + (bundle.install "special" invoke::special) + (bundle.install "interface" invoke::interface) + (bundle.install "constructor" invoke::constructor) + ))) ))) -(def: #export extensions - /.Bundle - (<| (/.prefix "jvm") - (|> (dict.new text.Hash<Text>) - (dict.merge conversion-procs) - (dict.merge int-procs) - (dict.merge long-procs) - (dict.merge float-procs) - (dict.merge double-procs) - (dict.merge char-procs) - (dict.merge array-procs) - (dict.merge object-procs) - (dict.merge member-procs) +(def: #export bundle + Bundle + (<| (bundle.prefix "jvm") + (|> bundle.empty + (dictionary.merge bundle::conversion) + (dictionary.merge bundle::int) + (dictionary.merge bundle::long) + (dictionary.merge bundle::float) + (dictionary.merge bundle::double) + (dictionary.merge bundle::char) + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + (dictionary.merge bundle::member) ))) diff --git a/stdlib/source/lux/language/compiler/extension/bundle.lux b/stdlib/source/lux/language/compiler/extension/bundle.lux index 315d05523..222ad7f5e 100644 --- a/stdlib/source/lux/language/compiler/extension/bundle.lux +++ b/stdlib/source/lux/language/compiler/extension/bundle.lux @@ -20,9 +20,13 @@ (ex.report ["Extension" name])) ## [Utils] +(def: #export empty + //.Bundle + (dict.new text.Hash<Text>)) + (def: #export (install name anonymous) (All [s i o] - (-> Text (-> Text (//.Handler s i o)) + (-> Text (//.Handler s i o) (-> (//.Bundle s i o) (//.Bundle s i o)))) (dict.put name anonymous)) diff --git a/stdlib/source/lux/language/compiler/synthesis.lux b/stdlib/source/lux/language/compiler/synthesis.lux index 2e359d2ea..05be98f3c 100644 --- a/stdlib/source/lux/language/compiler/synthesis.lux +++ b/stdlib/source/lux/language/compiler/synthesis.lux @@ -4,9 +4,11 @@ [data [error (#+ Error)] [collection ["dict" dictionary (#+ Dictionary)]]]] - [///reference (#+ Register Variable Reference)] - [// (#+ Operation Compiler)] - [//analysis (#+ Environment Arity Analysis)]) + ["." // + [analysis (#+ Environment Arity Analysis)] + [extension (#+ Extension)] + [// + [reference (#+ Register Variable Reference)]]]) (type: #export Resolver (Dictionary Variable Variable)) @@ -18,7 +20,7 @@ (def: #export fresh-resolver Resolver - (dict.new ///reference.Hash<Variable>)) + (dict.new reference.Hash<Variable>)) (def: #export init State @@ -34,8 +36,8 @@ (#Text Text)) (type: #export (Structure a) - (#Variant (//analysis.Variant a)) - (#Tuple (//analysis.Tuple a))) + (#Variant (analysis.Variant a)) + (#Tuple (analysis.Tuple a))) (type: #export Side (Either Nat Nat)) @@ -88,7 +90,14 @@ (#Primitive Primitive) (#Structure (Structure Synthesis)) (#Reference Reference) - (#Control (Control Synthesis))) + (#Control (Control Synthesis)) + (#Extension (Extension Synthesis))) + +(type: #export Operation + (extension.Operation ..State Analysis Synthesis)) + +(type: #export Compiler + (extension.Compiler ..State Analysis Synthesis)) (type: #export Path (Path' Synthesis)) @@ -144,13 +153,10 @@ (def: #export unit Text "") -(type: #export Synthesizer - (Compiler ..State Analysis Synthesis)) - (do-template [<name> <value>] [(def: #export <name> - (All [a] (-> (Operation ..State a) (Operation ..State a))) - (//.localized (set@ #direct? <value>)))] + (All [a] (-> (Operation a) (Operation a))) + (extension.temporary (set@ #direct? <value>)))] [indirectly false] [directly true] @@ -158,8 +164,8 @@ (do-template [<name> <type> <tag>] [(def: #export (<name> value) - (-> <type> (All [a] (-> (Operation ..State a) (Operation ..State a)))) - (//.localized (set@ <tag> value)))] + (-> <type> (All [a] (-> (Operation a) (Operation a)))) + (extension.temporary (set@ <tag> value)))] [with-scope-arity Arity #scope-arity] [with-resolver Resolver #resolver] @@ -167,19 +173,17 @@ ) (def: #export (with-abstraction arity resolver) - (All [o] - (-> Arity Resolver - (-> (Operation ..State o) (Operation ..State o)))) - (//.with-state {#scope-arity arity - #resolver resolver - #direct? true - #locals arity})) + (-> Arity Resolver + (All [a] (-> (Operation a) (Operation a)))) + (extension.with-state {#scope-arity arity + #resolver resolver + #direct? true + #locals arity})) (do-template [<name> <tag> <type>] [(def: #export <name> - (Operation ..State <type>) - (function (_ state) - (#error.Success [state (get@ <tag> state)])))] + (Operation <type>) + (extension.read (get@ <tag>)))] [scope-arity #scope-arity Arity] [resolver #resolver Resolver] @@ -188,7 +192,7 @@ ) (def: #export with-new-local - (All [a] (-> (Operation ..State a) (Operation ..State a))) + (All [a] (-> (Operation a) (Operation a))) (<<| (do //.Monad<Operation> [locals ..locals]) (..with-locals (inc locals)))) @@ -219,8 +223,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/language/compiler/synthesis/case.lux b/stdlib/source/lux/language/compiler/synthesis/case.lux index 7dd8b3157..de7a4f9fd 100644 --- a/stdlib/source/lux/language/compiler/synthesis/case.lux +++ b/stdlib/source/lux/language/compiler/synthesis/case.lux @@ -11,42 +11,43 @@ format] [number ("frac/" Equivalence<Frac>)] [collection [list ("list/" Fold<List> Monoid<List>)]]]] - [///reference] - [///compiler (#+ Operation) ("operation/" Monad<Operation>)] - [///analysis (#+ Pattern Match Analysis)] - [// (#+ Path Synthesis)] - [//function]) + [// (#+ Path Synthesis) + [function] + [/// + [reference] + [compiler (#+ Operation) ("operation/" Monad<Operation>)] + [analysis (#+ Pattern Match Analysis)]]]) (def: (path' pattern bodyC) (-> Pattern (Operation //.State Path) (Operation //.State Path)) (case pattern - (#///analysis.Simple simple) + (#analysis.Simple simple) (case simple - #///analysis.Unit + #analysis.Unit bodyC (^template [<from> <to>] (<from> value) (operation/map (|>> (#//.Seq (#//.Test (|> value <to>)))) bodyC)) - ([#///analysis.Bool #//.Bool] - [#///analysis.Nat (<| #//.I64 .i64)] - [#///analysis.Int (<| #//.I64 .i64)] - [#///analysis.Rev (<| #//.I64 .i64)] - [#///analysis.Frac #//.F64] - [#///analysis.Text #//.Text])) + ([#analysis.Bool #//.Bool] + [#analysis.Nat (<| #//.I64 .i64)] + [#analysis.Int (<| #//.I64 .i64)] + [#analysis.Rev (<| #//.I64 .i64)] + [#analysis.Frac #//.F64] + [#analysis.Text #//.Text])) - (#///analysis.Bind register) - (<| (do ///compiler.Monad<Operation> + (#analysis.Bind register) + (<| (do compiler.Monad<Operation> [arity //.scope-arity]) - (:: @ map (|>> (#//.Seq (#//.Bind (if (//function.nested? arity) + (:: @ map (|>> (#//.Seq (#//.Bind (if (function.nested? arity) (n/+ (dec arity) register) register))))) //.with-new-local bodyC) - (#///analysis.Complex _) - (case (///analysis.variant-pattern pattern) + (#analysis.Complex _) + (case (analysis.variant-pattern pattern) (#.Some [lefts right? value-pattern]) (operation/map (|>> (#//.Seq (#//.Access (#//.Side (if right? (#.Right lefts) @@ -54,11 +55,11 @@ (path' value-pattern bodyC)) #.None - (let [tuple (///analysis.tuple-pattern pattern) + (let [tuple (analysis.tuple-pattern pattern) tuple/last (dec (list.size tuple))] (list/fold (function (_ [tuple/idx tuple/member] thenC) (case tuple/member - (#///analysis.Simple #///analysis.Unit) + (#analysis.Simple #analysis.Unit) thenC _ @@ -126,15 +127,15 @@ (def: #export (synthesize synthesize^ inputA [headB tailB+]) (-> //.Synthesizer Analysis Match (Operation //.State Synthesis)) - (do ///compiler.Monad<Operation> + (do compiler.Monad<Operation> [inputS (synthesize^ inputA)] (with-expansions [<unnecesary-let> - (as-is (^multi (^ (#///analysis.Reference (///reference.local outputR))) + (as-is (^multi (^ (#analysis.Reference (reference.local outputR))) (n/= inputR outputR)) (wrap inputS)) <let> - (as-is [[(#///analysis.Bind inputR) headB/bodyA] + (as-is [[(#analysis.Bind inputR) headB/bodyA] #.Nil] (case headB/bodyA <unnecesary-let> @@ -145,16 +146,16 @@ headB/bodyS (//.with-new-local (synthesize^ headB/bodyA))] (wrap (//.branch/let [inputS - (if (//function.nested? arity) + (if (function.nested? arity) (n/+ (dec arity) inputR) inputR) headB/bodyS]))))) <if> - (as-is (^or (^ [[(///analysis.pattern/bool true) thenA] - (list [(///analysis.pattern/bool false) elseA])]) - (^ [[(///analysis.pattern/bool false) elseA] - (list [(///analysis.pattern/bool true) thenA])])) + (as-is (^or (^ [[(analysis.pattern/bool true) thenA] + (list [(analysis.pattern/bool false) elseA])]) + (^ [[(analysis.pattern/bool false) elseA] + (list [(analysis.pattern/bool true) thenA])])) (do @ [thenS (synthesize^ thenA) elseS (synthesize^ elseA)] diff --git a/stdlib/source/lux/language/compiler/synthesis/expression.lux b/stdlib/source/lux/language/compiler/synthesis/expression.lux index ffc22d89a..80480de68 100644 --- a/stdlib/source/lux/language/compiler/synthesis/expression.lux +++ b/stdlib/source/lux/language/compiler/synthesis/expression.lux @@ -8,95 +8,96 @@ [collection [list ("list/" Functor<List>)] ["dict" dictionary (#+ Dictionary)]]]] - [///reference] - [///compiler ("operation/" Monad<Operation>)] - [///analysis (#+ Analysis)] - [///extension (#+ Extension)] - [// (#+ Synthesis)] - [//function] - [//case]) + [// (#+ Synthesis) + [function] + [case] + [/// + [reference] + ["." compiler ("operation/" Monad<Operation>) + [analysis (#+ Analysis)] + [extension (#+ Extension)]]]]) (exception: #export (unknown-synthesis-extension {name Text}) name) (def: (primitive analysis) - (-> ///analysis.Primitive //.Primitive) + (-> analysis.Primitive //.Primitive) (case analysis - #///analysis.Unit + #analysis.Unit (#//.Text //.unit) (^template [<analysis> <synthesis>] (<analysis> value) (<synthesis> value)) - ([#///analysis.Bool #//.Bool] - [#///analysis.Frac #//.F64] - [#///analysis.Text #//.Text]) + ([#analysis.Bool #//.Bool] + [#analysis.Frac #//.F64] + [#analysis.Text #//.Text]) (^template [<analysis> <synthesis>] (<analysis> value) (<synthesis> (.i64 value))) - ([#///analysis.Nat #//.I64] - [#///analysis.Int #//.I64] - [#///analysis.Rev #//.I64]))) + ([#analysis.Nat #//.I64] + [#analysis.Int #//.I64] + [#analysis.Rev #//.I64]))) (def: #export (synthesizer extensions) - (-> (Extension ///extension.Synthesis) //.Synthesizer) + (-> (Extension extension.Synthesis) //.Synthesizer) (function (synthesize analysis) (case analysis - (#///analysis.Primitive analysis') + (#analysis.Primitive analysis') (operation/wrap (#//.Primitive (..primitive analysis'))) - (#///analysis.Structure composite) - (case (///analysis.variant analysis) + (#analysis.Structure composite) + (case (analysis.variant analysis) (#.Some variant) - (do ///compiler.Monad<Operation> - [valueS (synthesize (get@ #///analysis.value variant))] - (wrap (#//.Structure (#//.Variant (set@ #///analysis.value valueS variant))))) + (do compiler.Monad<Operation> + [valueS (synthesize (get@ #analysis.value variant))] + (wrap (#//.Structure (#//.Variant (set@ #analysis.value valueS variant))))) _ - (do ///compiler.Monad<Operation> - [tupleS (monad.map @ synthesize (///analysis.tuple analysis))] + (do compiler.Monad<Operation> + [tupleS (monad.map @ synthesize (analysis.tuple analysis))] (wrap (#//.Structure (#//.Tuple tupleS))))) - (#///analysis.Apply _) - (//function.apply (|>> synthesize //.indirectly) analysis) + (#analysis.Apply _) + (function.apply (|>> synthesize //.indirectly) analysis) - (#///analysis.Function environmentA bodyA) - (//function.function synthesize environmentA bodyA) + (#analysis.Function environmentA bodyA) + (function.function synthesize environmentA bodyA) - (#///analysis.Extension name args) + (#analysis.Extension name args) (case (dict.get name extensions) #.None - (///compiler.throw unknown-synthesis-extension name) + (compiler.throw unknown-synthesis-extension name) (#.Some extension) (extension (|>> synthesize //.indirectly) args)) - (#///analysis.Reference reference) + (#analysis.Reference reference) (case reference - (#///reference.Constant constant) + (#reference.Constant constant) (operation/wrap (#//.Reference reference)) - (#///reference.Variable var) - (do ///compiler.Monad<Operation> + (#reference.Variable var) + (do compiler.Monad<Operation> [resolver //.resolver] (case var - (#///reference.Local register) + (#reference.Local register) (do @ [arity //.scope-arity] - (wrap (if (//function.nested? arity) + (wrap (if (function.nested? arity) (if (n/= +0 register) (|> (dec arity) (list.n/range +1) (list/map (|>> //.variable/local)) [(//.variable/local +0)] //.function/apply) - (#//.Reference (#///reference.Variable (//function.adjust arity false var)))) - (#//.Reference (#///reference.Variable var))))) + (#//.Reference (#reference.Variable (function.adjust arity false var)))) + (#//.Reference (#reference.Variable var))))) - (#///reference.Foreign register) - (wrap (|> resolver (dict.get var) (maybe.default var) #///reference.Variable #//.Reference))))) + (#reference.Foreign register) + (wrap (|> resolver (dict.get var) (maybe.default var) #reference.Variable #//.Reference))))) - (#///analysis.Case inputA branchesAB+) - (//case.synthesize (|>> synthesize //.indirectly) inputA branchesAB+) + (#analysis.Case inputA branchesAB+) + (case.synthesize (|>> synthesize //.indirectly) inputA branchesAB+) ))) diff --git a/stdlib/source/lux/language/compiler/synthesis/function.lux b/stdlib/source/lux/language/compiler/synthesis/function.lux index 2b9cffd19..92e75dc94 100644 --- a/stdlib/source/lux/language/compiler/synthesis/function.lux +++ b/stdlib/source/lux/language/compiler/synthesis/function.lux @@ -11,11 +11,12 @@ [collection [list ("list/" Functor<List> Monoid<List> Fold<List>)] ["dict" dictionary (#+ Dictionary)]]]] - [///reference (#+ Variable)] - [///compiler (#+ Operation)] - [///analysis (#+ Environment Arity Analysis)] - [// (#+ Synthesis Synthesizer)] - [//loop]) + [// (#+ Synthesis Synthesizer) + [loop] + [/// + [reference (#+ Variable)] + [compiler (#+ Operation) + [analysis (#+ Environment Arity Analysis)]]]]) (def: #export nested? (-> Arity Bool) @@ -24,9 +25,9 @@ (def: #export (adjust up-arity after? var) (-> Arity Bool Variable Variable) (case var - (#///reference.Local register) + (#reference.Local register) (if (and after? (n/>= up-arity register)) - (#///reference.Local (n/+ (dec up-arity) register)) + (#reference.Local (n/+ (dec up-arity) register)) var) _ @@ -37,7 +38,7 @@ (loop [apply apply args (list)] (case apply - (#///analysis.Apply arg func) + (#analysis.Apply arg func) (recur func (#.Cons arg args)) _ @@ -54,7 +55,7 @@ (case funcS (^ (//.function/abstraction functionS)) (wrap (|> functionS - (//loop.loop (get@ #//.environment functionS) locals argsS) + (loop.loop (get@ #//.environment functionS) locals argsS) (maybe.default (//.function/apply [funcS argsS])))) (^ (//.function/apply [funcS' argsS'])) @@ -64,11 +65,11 @@ (wrap (//.function/apply [funcS argsS]))))))) (def: (prepare up down) - (-> Arity Arity (//loop.Transform Synthesis)) + (-> Arity Arity (loop.Transform Synthesis)) (.function (_ body) (if (nested? up) (#.Some body) - (//loop.recursion down body)))) + (loop.recursion down body)))) (exception: #export (cannot-prepare-function-body {_ []}) "") @@ -76,14 +77,14 @@ (def: return (All [a] (-> (Maybe a) (Operation //.State a))) (|>> (case> (#.Some output) - (:: ///compiler.Monad<Operation> wrap output) + (:: compiler.Monad<Operation> wrap output) #.None - (///compiler.throw cannot-prepare-function-body [])))) + (compiler.throw cannot-prepare-function-body [])))) (def: #export (function synthesize environment body) (-> Synthesizer Environment Analysis (Operation //.State Synthesis)) - (do ///compiler.Monad<Operation> + (do compiler.Monad<Operation> [direct? //.direct? arity //.scope-arity resolver //.resolver @@ -107,7 +108,7 @@ _ (|> (list.size environment) dec (list.n/range +0) - (list/map (|>> #///reference.Foreign))))) + (list/map (|>> #reference.Foreign))))) resolver' (if (and (nested? function-arity) direct?) (list/fold (.function (_ [from to] resolver') diff --git a/stdlib/source/lux/language/compiler/synthesis/loop.lux b/stdlib/source/lux/language/compiler/synthesis/loop.lux index 05af31a83..564fe5421 100644 --- a/stdlib/source/lux/language/compiler/synthesis/loop.lux +++ b/stdlib/source/lux/language/compiler/synthesis/loop.lux @@ -9,10 +9,11 @@ [macro [code] [syntax]]] - [///] - [///reference (#+ Register Variable)] - [///analysis (#+ Environment)] - [// (#+ Path Abstraction Synthesis)]) + [// (#+ Path Abstraction Synthesis) + [/// + [reference (#+ Register Variable)] + [compiler + [analysis (#+ Environment)]]]]) (type: #export (Transform a) (-> a (Maybe a))) @@ -24,7 +25,7 @@ #.None false)) (template: #export (self) - (#//.Reference (///reference.local +0))) + (#//.Reference (reference.local +0))) (template: (recursive-apply args) (#//.Apply (self) args)) @@ -41,7 +42,7 @@ (#//.Structure structure) (case structure (#//.Variant variantS) - (proper? (get@ #///analysis.value variantS)) + (proper? (get@ #analysis.value variantS)) (#//.Tuple membersS+) (list.every? proper? membersS+)) @@ -84,7 +85,7 @@ (#//.Function functionS) (case functionS (#//.Abstraction environment arity bodyS) - (list.every? ///reference.self? environment) + (list.every? reference.self? environment) (#//.Apply funcS argsS) (and (proper? funcS) @@ -161,7 +162,7 @@ (-> Environment (Transform Variable)) (function (_ variable) (case variable - (#///reference.Foreign register) + (#reference.Foreign register) (list.nth register environment) _ @@ -196,9 +197,9 @@ (case structureS (#//.Variant variantS) (do maybe.Monad<Maybe> - [valueS' (|> variantS (get@ #///analysis.value) recur)] + [valueS' (|> variantS (get@ #analysis.value) recur)] (wrap (|> variantS - (set@ #///analysis.value valueS') + (set@ #analysis.value valueS') #//.Variant #//.Structure))) @@ -209,16 +210,16 @@ (#//.Reference reference) (case reference - (^ (///reference.constant constant)) + (^ (reference.constant constant)) (#.Some exprS) - (^ (///reference.local register)) - (#.Some (#//.Reference (///reference.local (n/+ offset register)))) + (^ (reference.local register)) + (#.Some (#//.Reference (reference.local (n/+ offset register)))) - (^ (///reference.foreign register)) + (^ (reference.foreign register)) (|> scope-environment (list.nth register) - (maybe/map (|>> #///reference.Variable #//.Reference)))) + (maybe/map (|>> #reference.Variable #//.Reference)))) (^ (//.branch/case [inputS pathS])) (do maybe.Monad<Maybe> diff --git a/stdlib/source/lux/language/compiler/translation.lux b/stdlib/source/lux/language/compiler/translation.lux index 01dc584e6..077076d2f 100644 --- a/stdlib/source/lux/language/compiler/translation.lux +++ b/stdlib/source/lux/language/compiler/translation.lux @@ -11,8 +11,10 @@ [collection [row (#+ Row)] ["dict" dictionary (#+ Dictionary)]]] + [function] [world [file (#+ File)]]] - [// (#+ Operation Compiler)] + ["." // + [extension]] [//synthesis (#+ Synthesis)]) (do-template [<name>] @@ -47,8 +49,11 @@ #buffer (Maybe (Buffer code)) #artifacts (Artifacts code)}) -(type: #export (Translator anchor code) - (Compiler (State anchor code) Synthesis code)) +(type: #export (Operation anchor code) + (extension.Operation (State anchor code) Synthesis code)) + +(type: #export (Compiler anchor code) + (extension.Compiler (State anchor code) Synthesis code)) (def: #export (init host) (All [anchor code] (-> (Host code) (..State anchor code))) @@ -61,26 +66,23 @@ (def: #export (with-context expr) (All [anchor code output] - (-> (Operation (..State anchor code) output) - (Operation (..State anchor code) [Text output]))) - (function (_ state) + (-> (Operation anchor code output) + (Operation anchor code [Text output]))) + (function (_ [bundle state]) (let [[old-scope old-inner] (get@ #context state) new-scope (format old-scope "c___" (%i (.int old-inner)))] - (case (expr (set@ #context [new-scope +0] state)) - (#error.Success [state' output]) - (#error.Success [(set@ #context [old-scope (inc old-inner)] state') + (case (expr [bundle (set@ #context [new-scope +0] state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ #context [old-scope (inc old-inner)] state')] [new-scope output]]) (#error.Error error) (#error.Error error))))) (def: #export context - (All [anchor code] (Operation (..State anchor code) Text)) - (function (_ state) - (#error.Success [state - (|> state - (get@ #context) - (get@ #scope-name))]))) + (All [anchor code] (Operation anchor code Text)) + (extension.read (|>> (get@ #context) + (get@ #scope-name)))) (do-template [<tag> <with-declaration> <with-type> <with-value> @@ -88,57 +90,56 @@ [(def: #export <with-declaration> (All [anchor code output] <with-type>) (function (_ body) - (function (_ state) - (case (body (set@ <tag> (#.Some <with-value>) state)) - (#error.Success [state' output]) - (#error.Success [(set@ <tag> (get@ <tag> state) state') + (function (_ [bundle state]) + (case (body [bundle (set@ <tag> (#.Some <with-value>) state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ <tag> (get@ <tag> state) state')] output]) (#error.Error error) (#error.Error error))))) (def: #export <get> - (All [anchor code] (Operation (..State anchor code) <get-type>)) - (function (_ state) + (All [anchor code] (Operation anchor code <get-type>)) + (function (_ (^@ stateE [bundle state])) (case (get@ <tag> state) (#.Some output) - (#error.Success [state output]) + (#error.Success [stateE output]) #.None (ex.throw <exception> []))))] [#anchor (with-anchor anchor) - (-> anchor (Operation (..State anchor code) output) - (Operation (..State anchor code) output)) + (-> anchor (Operation anchor code output) + (Operation anchor code output)) anchor anchor anchor no-anchor] [#buffer with-buffer - (-> (Operation (..State anchor code) output) - (Operation (..State anchor code) output)) + (-> (Operation anchor code output) + (Operation anchor code output)) row.empty buffer (Buffer code) no-active-buffer] ) (def: #export artifacts (All [anchor code] - (Operation (..State anchor code) (Artifacts code))) - (function (_ state) - (#error.Success [state (get@ #artifacts state)]))) + (Operation anchor code (Artifacts code))) + (extension.read (get@ #artifacts))) (do-template [<name>] [(def: #export (<name> code) (All [anchor code] - (-> code (Operation (..State anchor code) Any))) - (function (_ state) + (-> code (Operation anchor code Any))) + (function (_ (^@ stateE [bundle state])) (case (:: (get@ #host state) <name> code) (#error.Error error) (ex.throw cannot-interpret error) (#error.Success output) - (#error.Success [state output]))))] + (#error.Success [stateE output]))))] [execute!] [evaluate!] @@ -146,20 +147,14 @@ (def: #export (save! name code) (All [anchor code] - (-> Ident code (Operation (..State anchor code) Any))) + (-> Ident code (Operation anchor code Any))) (do //.Monad<Operation> [_ (execute! code)] - (function (_ state) - (#error.Success [(update@ #buffer - (maybe/map (row.add [name code])) - state) - []])))) + (extension.update (update@ #buffer (maybe/map (row.add [name code])))))) (def: #export (save-buffer! target) (All [anchor code] - (-> File (Operation (..State anchor code) Any))) + (-> File (Operation anchor code Any))) (do //.Monad<Operation> [buffer ..buffer] - (function (_ state) - (#error.Success [(update@ #artifacts (dict.put target buffer) state) - []])))) + (extension.update (update@ #artifacts (dict.put target buffer))))) diff --git a/stdlib/source/lux/language/compiler/translation/scheme/case.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/case.jvm.lux index 4460a3102..3ef368c18 100644 --- a/stdlib/source/lux/language/compiler/translation/scheme/case.jvm.lux +++ b/stdlib/source/lux/language/compiler/translation/scheme/case.jvm.lux @@ -15,11 +15,11 @@ [host ["_" scheme (#+ Expression Computation Var)]] [compiler ("operation/" Monad<Operation>) [synthesis (#+ Synthesis Path)]]] - [//runtime (#+ Operation Translator)] + [//runtime (#+ Operation Compiler)] [//reference]) (def: #export (let translate [valueS register bodyS]) - (-> Translator [Synthesis Register Synthesis] + (-> Compiler [Synthesis Register Synthesis] (Operation Computation)) (do compiler.Monad<Operation> [valueO (translate valueS) @@ -28,7 +28,7 @@ bodyO)))) (def: #export (record-get translate valueS pathP) - (-> Translator Synthesis (List [Nat Bool]) + (-> Compiler Synthesis (List [Nat Bool]) (Operation Expression)) (do compiler.Monad<Operation> [valueO (translate valueS)] @@ -41,7 +41,7 @@ pathP)))) (def: #export (if translate [testS thenS elseS]) - (-> Translator [Synthesis Synthesis Synthesis] + (-> Compiler [Synthesis Synthesis Synthesis] (Operation Computation)) (do compiler.Monad<Operation> [testO (translate testS) @@ -102,7 +102,7 @@ (_.raise/1 $alt_error)))) (def: (pattern-matching' translate pathP) - (-> Translator Path (Operation Expression)) + (-> Compiler Path (Operation Expression)) (.case pathP (^ (synthesis.path/then bodyS)) (translate bodyS) @@ -157,7 +157,7 @@ (compiler.throw unrecognized-path []))) (def: (pattern-matching translate pathP) - (-> Translator Path (Operation Computation)) + (-> Compiler Path (Operation Computation)) (do compiler.Monad<Operation> [pattern-matching! (pattern-matching' translate pathP)] (wrap (_.with-exception-handler @@ -166,7 +166,7 @@ pattern-matching!))))) (def: #export (case translate [valueS pathP]) - (-> Translator [Synthesis Path] (Operation Computation)) + (-> Compiler [Synthesis Path] (Operation Computation)) (do compiler.Monad<Operation> [valueO (translate valueS)] (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] diff --git a/stdlib/source/lux/language/compiler/translation/scheme/expression.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/expression.jvm.lux index 464f2c27d..d7ef01e61 100644 --- a/stdlib/source/lux/language/compiler/translation/scheme/expression.jvm.lux +++ b/stdlib/source/lux/language/compiler/translation/scheme/expression.jvm.lux @@ -1,55 +1,58 @@ (.module: [lux #* [control [monad (#+ do)]]] - [///// - ["." compiler + [// + [runtime (#+ Compiler)] + [primitive] + [structure] + [reference] + [function] + [case] + [loop] + ["." /// [synthesis] - [extension]]] - [//runtime (#+ Translator)] - [//primitive] - [//structure] - [//reference] - [//function] - [//case] - [//loop]) + [extension]]]) (def: #export (translate synthesis) - Translator + Compiler (case synthesis (^template [<tag> <generator>] (^ (<tag> value)) (<generator> value)) - ([synthesis.bool //primitive.bool] - [synthesis.i64 //primitive.i64] - [synthesis.f64 //primitive.f64] - [synthesis.text //primitive.text]) + ([synthesis.bool primitive.bool] + [synthesis.i64 primitive.i64] + [synthesis.f64 primitive.f64] + [synthesis.text primitive.text]) (^ (synthesis.variant variantS)) - (//structure.variant translate variantS) + (structure.variant translate variantS) (^ (synthesis.tuple members)) - (//structure.tuple translate members) + (structure.tuple translate members) (#synthesis.Reference reference) - (//reference.reference reference) + (reference.reference reference) (^ (synthesis.branch/case case)) - (//case.case translate case) + (case.case translate case) (^ (synthesis.branch/let let)) - (//case.let translate let) + (case.let translate let) (^ (synthesis.branch/if if)) - (//case.if translate if) + (case.if translate if) (^ (synthesis.loop/scope scope)) - (//loop.scope translate scope) + (loop.scope translate scope) (^ (synthesis.loop/recur updates)) - (//loop.recur translate updates) + (loop.recur translate updates) (^ (synthesis.function/abstraction abstraction)) - (//function.function translate abstraction) + (function.function translate abstraction) (^ (synthesis.function/apply application)) - (//function.apply translate application))) + (function.apply translate application) + + (#synthesis.Extension extension) + (extension.apply translate extension))) diff --git a/stdlib/source/lux/language/compiler/translation/scheme/extension.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/extension.jvm.lux index a54d67425..c7d161f14 100644 --- a/stdlib/source/lux/language/compiler/translation/scheme/extension.jvm.lux +++ b/stdlib/source/lux/language/compiler/translation/scheme/extension.jvm.lux @@ -13,7 +13,7 @@ [host ["_" scheme (#+ Computation)]] [compiler ("operation/" Monad<Operation>) [synthesis (#+ Synthesis)]]] - [//runtime (#+ Operation Translator)] + [//runtime (#+ Operation Compiler)] [/common] ## [/host] ) @@ -28,7 +28,7 @@ )) (def: #export (extension translate name args) - (-> Translator Text (List Synthesis) + (-> Compiler Text (List Synthesis) (Operation Computation)) (<| (maybe.default (compiler.throw unknown-extension (%t name))) (do maybe.Monad<Maybe> diff --git a/stdlib/source/lux/language/compiler/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/extension/common.jvm.lux index 377fed8f5..40f817aea 100644 --- a/stdlib/source/lux/language/compiler/translation/scheme/extension/common.jvm.lux +++ b/stdlib/source/lux/language/compiler/translation/scheme/extension/common.jvm.lux @@ -20,11 +20,11 @@ [host ["_" scheme (#+ Expression Computation)]] ["." compiler [synthesis (#+ Synthesis)]]] - [///runtime (#+ Operation Translator)]) + [///runtime (#+ Operation Compiler)]) ## [Types] (type: #export Extension - (-> Translator (List Synthesis) (Operation Computation))) + (-> Compiler (List Synthesis) (Operation Computation))) (type: #export Bundle (Dictionary Text Extension)) diff --git a/stdlib/source/lux/language/compiler/translation/scheme/function.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/function.jvm.lux index 6afb04799..d5dc4541f 100644 --- a/stdlib/source/lux/language/compiler/translation/scheme/function.jvm.lux +++ b/stdlib/source/lux/language/compiler/translation/scheme/function.jvm.lux @@ -16,12 +16,12 @@ [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] [synthesis (#+ Synthesis)]]] [///] - [//runtime (#+ Operation Translator)] + [//runtime (#+ Operation Compiler)] [//primitive] [//reference]) (def: #export (apply translate [functionS argsS+]) - (-> Translator (Application Synthesis) (Operation Computation)) + (-> Compiler (Application Synthesis) (Operation Computation)) (do compiler.Monad<Operation> [functionO (translate functionS) argsO+ (monad.map @ translate argsS+)] @@ -50,7 +50,7 @@ (|>> inc //reference.local')) (def: #export (function translate [environment arity bodyS]) - (-> Translator (Abstraction Synthesis) (Operation Computation)) + (-> Compiler (Abstraction Synthesis) (Operation Computation)) (do compiler.Monad<Operation> [[function-name bodyO] (///.with-context (do @ diff --git a/stdlib/source/lux/language/compiler/translation/scheme/loop.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/loop.jvm.lux index 227a2eda9..4e8d90341 100644 --- a/stdlib/source/lux/language/compiler/translation/scheme/loop.jvm.lux +++ b/stdlib/source/lux/language/compiler/translation/scheme/loop.jvm.lux @@ -14,13 +14,13 @@ ["." compiler [synthesis (#+ Scope Synthesis)]]] [///] - [//runtime (#+ Operation Translator)] + [//runtime (#+ Operation Compiler)] [//reference]) (def: @scope (_.var "scope")) (def: #export (scope translate [start initsS+ bodyS]) - (-> Translator (Scope Synthesis) (Operation Computation)) + (-> Compiler (Scope Synthesis) (Operation Computation)) (do compiler.Monad<Operation> [initsO+ (monad.map @ translate initsS+) bodyO (///.with-anchor @scope @@ -33,7 +33,7 @@ (_.apply/* @scope initsO+))))) (def: #export (recur translate argsS+) - (-> Translator (List Synthesis) (Operation Computation)) + (-> Compiler (List Synthesis) (Operation Computation)) (do compiler.Monad<Operation> [@scope ///.anchor argsO+ (monad.map @ translate argsS+)] diff --git a/stdlib/source/lux/language/compiler/translation/scheme/reference.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/reference.jvm.lux index 51dd2f515..f9eba9bd7 100644 --- a/stdlib/source/lux/language/compiler/translation/scheme/reference.jvm.lux +++ b/stdlib/source/lux/language/compiler/translation/scheme/reference.jvm.lux @@ -12,7 +12,7 @@ [compiler ("operation/" Monad<Operation>) [analysis (#+ Variant Tuple)] [synthesis (#+ Synthesis)]]] - [//runtime (#+ Operation Translator)] + [//runtime (#+ Operation)] [//primitive]) (do-template [<name> <prefix>] diff --git a/stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux index d2a72d140..a1ce941d2 100644 --- a/stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux +++ b/stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux @@ -12,19 +12,19 @@ [macro [code] ["s" syntax (#+ syntax:)]]] - [/// (#+ State)] - [///// - [name] - [host ["_" scheme (#+ Expression Computation Var)]] - ["." compiler + ["." /// + ["//." // [analysis (#+ Variant)] - [synthesis]]]) + [synthesis] + [// + [name] + [host ["_" scheme (#+ Expression Computation Var)]]]]]) (type: #export Operation - (compiler.Operation (State Var Expression))) + (///.Operation Var Expression)) -(type: #export Translator - (///.Translator Var Expression)) +(type: #export Compiler + (///.Compiler Var Expression)) (def: prefix Text "LuxRuntime") @@ -362,6 +362,6 @@ (def: #export translate (Operation Any) (///.with-buffer - (do compiler.Monad<Operation> + (do ////.Monad<Operation> [_ (///.save! ["" ..prefix] ..runtime)] (///.save-buffer! "")))) diff --git a/stdlib/source/lux/language/compiler/translation/scheme/structure.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/structure.jvm.lux index ea5440d67..4637d1a25 100644 --- a/stdlib/source/lux/language/compiler/translation/scheme/structure.jvm.lux +++ b/stdlib/source/lux/language/compiler/translation/scheme/structure.jvm.lux @@ -7,11 +7,11 @@ ["." compiler [analysis (#+ Variant Tuple)] [synthesis (#+ Synthesis)]]] - [//runtime (#+ Operation Translator)] + [//runtime (#+ Operation Compiler)] [//primitive]) (def: #export (tuple translate elemsS+) - (-> Translator (Tuple Synthesis) (Operation Expression)) + (-> Compiler (Tuple Synthesis) (Operation Expression)) (case elemsS+ #.Nil (//primitive.text synthesis.unit) @@ -25,7 +25,7 @@ (wrap (_.vector/* elemsT+))))) (def: #export (variant translate [lefts right? valueS]) - (-> Translator (Variant Synthesis) (Operation Expression)) + (-> Compiler (Variant Synthesis) (Operation Expression)) (do compiler.Monad<Operation> [valueT (translate valueS)] (wrap (//runtime.variant [lefts right? valueT])))) diff --git a/stdlib/source/lux/language/module.lux b/stdlib/source/lux/language/module.lux deleted file mode 100644 index 75a1ab302..000000000 --- a/stdlib/source/lux/language/module.lux +++ /dev/null @@ -1,243 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)] - pipe] - [data - [text ("text/" Equivalence<Text>) - format] - ["e" error] - [collection - [list ("list/" Fold<List> Functor<List>)] - [dictionary [plist]]]] - [macro]] - ["." //compiler - [analysis]]) - -(type: #export Tag Text) - -(exception: #export (unknown-module {module Text}) - module) - -(exception: #export (cannot-declare-tag-twice {module Text} {tag Text}) - (ex.report ["Module" module] - ["Tag" tag])) - -(do-template [<name>] - [(exception: #export (<name> {tags (List Text)} {owner Type}) - (ex.report ["Tags" (text.join-with " " tags)] - ["Type" (%type owner)]))] - - [cannot-declare-tags-for-unnamed-type] - [cannot-declare-tags-for-foreign-type] - ) - -(exception: #export (cannot-define-more-than-once {name Ident}) - (%ident name)) - -(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State}) - (ex.report ["Module" module] - ["Desired state" (case state - #.Active "Active" - #.Compiled "Compiled" - #.Cached "Cached")])) - -(exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code}) - (ex.report ["Module" module] - ["Old annotations" (%code old)] - ["New annotations" (%code new)])) - -(def: (new hash) - (-> Nat Module) - {#.module-hash hash - #.module-aliases (list) - #.definitions (list) - #.imports (list) - #.tags (list) - #.types (list) - #.module-annotations #.None - #.module-state #.Active}) - -(def: #export (set-annotations annotations) - (-> Code (Meta Any)) - (do macro.Monad<Meta> - [self-name macro.current-module-name - self macro.current-module] - (case (get@ #.module-annotations self) - #.None - (function (_ compiler) - (#e.Success [(update@ #.modules - (plist.put self-name (set@ #.module-annotations (#.Some annotations) self)) - compiler) - []])) - - (#.Some old) - (//compiler.throw cannot-set-module-annotations-more-than-once [self-name old annotations])))) - -(def: #export (import module) - (-> Text (Meta Any)) - (do macro.Monad<Meta> - [self-name macro.current-module-name] - (function (_ compiler) - (#e.Success [(update@ #.modules - (plist.update self-name (update@ #.imports (|>> (#.Cons module)))) - compiler) - []])))) - -(def: #export (alias alias module) - (-> Text Text (Meta Any)) - (do macro.Monad<Meta> - [self-name macro.current-module-name] - (function (_ compiler) - (#e.Success [(update@ #.modules - (plist.update self-name (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text])) - (|>> (#.Cons [alias module]))))) - compiler) - []])))) - -(def: #export (exists? module) - (-> Text (Meta Bool)) - (function (_ compiler) - (|> compiler - (get@ #.modules) - (plist.get module) - (case> (#.Some _) true #.None false) - [compiler] #e.Success))) - -(def: #export (define name definition) - (-> Text Definition (Meta [])) - (do macro.Monad<Meta> - [self-name macro.current-module-name - self macro.current-module] - (function (_ compiler) - (case (plist.get name (get@ #.definitions self)) - #.None - (#e.Success [(update@ #.modules - (plist.put self-name - (update@ #.definitions - (: (-> (List [Text Definition]) (List [Text Definition])) - (|>> (#.Cons [name definition]))) - self)) - compiler) - []]) - - (#.Some already-existing) - ((//compiler.throw cannot-define-more-than-once [self-name name]) compiler))))) - -(def: #export (create hash name) - (-> Nat Text (Meta [])) - (function (_ compiler) - (let [module (new hash)] - (#e.Success [(update@ #.modules - (plist.put name module) - compiler) - []])))) - -(def: #export (with-module hash name action) - (All [a] (-> Nat Text (Meta a) (Meta [Module a]))) - (do macro.Monad<Meta> - [_ (create hash name) - output (analysis.with-current-module name - action) - module (macro.find-module name)] - (wrap [module output]))) - -(do-template [<setter> <asker> <tag>] - [(def: #export (<setter> module-name) - (-> Text (Meta Any)) - (function (_ compiler) - (case (|> compiler (get@ #.modules) (plist.get module-name)) - (#.Some module) - (let [active? (case (get@ #.module-state module) - #.Active true - _ false)] - (if active? - (#e.Success [(update@ #.modules - (plist.put module-name (set@ #.module-state <tag> module)) - compiler) - []]) - ((//compiler.throw can-only-change-state-of-active-module [module-name <tag>]) - compiler))) - - #.None - ((//compiler.throw unknown-module module-name) compiler)))) - - (def: #export (<asker> module-name) - (-> Text (Meta Bool)) - (function (_ compiler) - (case (|> compiler (get@ #.modules) (plist.get module-name)) - (#.Some module) - (#e.Success [compiler - (case (get@ #.module-state module) - <tag> true - _ false)]) - - #.None - ((//compiler.throw unknown-module module-name) compiler))))] - - [set-active active? #.Active] - [set-compiled compiled? #.Compiled] - [set-cached cached? #.Cached] - ) - -(do-template [<name> <tag> <type>] - [(def: (<name> module-name) - (-> Text (Meta <type>)) - (function (_ compiler) - (case (|> compiler (get@ #.modules) (plist.get module-name)) - (#.Some module) - (#e.Success [compiler (get@ <tag> module)]) - - #.None - ((//compiler.throw unknown-module module-name) compiler))))] - - [tags #.tags (List [Text [Nat (List Ident) Bool Type]])] - [types #.types (List [Text [(List Ident) Bool Type]])] - [hash #.module-hash Nat] - ) - -(def: (ensure-undeclared-tags module-name tags) - (-> Text (List Tag) (Meta Any)) - (do macro.Monad<Meta> - [bindings (..tags module-name) - _ (monad.map @ - (function (_ tag) - (case (plist.get tag bindings) - #.None - (wrap []) - - (#.Some _) - (//compiler.throw cannot-declare-tag-twice [module-name tag]))) - tags)] - (wrap []))) - -(def: #export (declare-tags tags exported? type) - (-> (List Tag) Bool Type (Meta Any)) - (do macro.Monad<Meta> - [self-name macro.current-module-name - [type-module type-name] (case type - (#.Named type-ident _) - (wrap type-ident) - - _ - (//compiler.throw cannot-declare-tags-for-unnamed-type [tags type])) - _ (ensure-undeclared-tags self-name tags) - _ (//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) - (let [namespaced-tags (list/map (|>> [self-name]) tags)] - (#e.Success [(update@ #.modules - (plist.update self-name - (|>> (update@ #.tags (function (_ tag-bindings) - (list/fold (function (_ [idx tag] table) - (plist.put tag [idx namespaced-tags exported? type] table)) - tag-bindings - (list.enumerate tags)))) - (update@ #.types (plist.put type-name [namespaced-tags exported? type])))) - compiler) - []])) - #.None - ((//compiler.throw unknown-module self-name) compiler))))) diff --git a/stdlib/source/lux/language/scope.lux b/stdlib/source/lux/language/scope.lux deleted file mode 100644 index 1f0cbffc4..000000000 --- a/stdlib/source/lux/language/scope.lux +++ /dev/null @@ -1,191 +0,0 @@ -(.module: - [lux #* - [control - monad] - [data - [text ("text/" Equivalence<Text>) - format] - [maybe ("maybe/" Monad<Maybe>)] - [product] - ["e" error] - [collection - [list ("list/" Functor<List> Fold<List> Monoid<List>)] - [dictionary [plist]]]] - [macro]] - [//reference (#+ Register Variable)]) - -(type: Locals (Bindings Text [Type Register])) -(type: Foreign (Bindings Text [Type Variable])) - -(def: (is-local? name scope) - (-> Text Scope Bool) - (|> scope - (get@ [#.locals #.mappings]) - (plist.contains? name))) - -(def: (get-local name scope) - (-> Text Scope (Maybe [Type Variable])) - (|> scope - (get@ [#.locals #.mappings]) - (plist.get name) - (maybe/map (function (_ [type value]) - [type (#//reference.Local value)])))) - -(def: (is-captured? name scope) - (-> Text Scope Bool) - (|> scope - (get@ [#.captured #.mappings]) - (plist.contains? name))) - -(def: (get-captured name scope) - (-> Text Scope (Maybe [Type Variable])) - (loop [idx +0 - mappings (get@ [#.captured #.mappings] scope)] - (case mappings - #.Nil - #.None - - (#.Cons [_name [_source-type _source-ref]] mappings') - (if (text/= name _name) - (#.Some [_source-type (#//reference.Foreign idx)]) - (recur (inc idx) mappings'))))) - -(def: (is-ref? name scope) - (-> Text Scope Bool) - (or (is-local? name scope) - (is-captured? name scope))) - -(def: (get-ref name scope) - (-> Text Scope (Maybe [Type Variable])) - (case (get-local name scope) - (#.Some type) - (#.Some type) - - _ - (get-captured name scope))) - -(def: #export (find name) - (-> Text (Meta (Maybe [Type Variable]))) - (function (_ compiler) - (let [[inner outer] (|> compiler - (get@ #.scopes) - (list.split-with (|>> (is-ref? name) not)))] - (case outer - #.Nil - (#.Right [compiler #.None]) - - (#.Cons top-outer _) - (let [[ref-type init-ref] (maybe.default (undefined) - (get-ref name top-outer)) - [ref inner'] (list/fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)]) - (function (_ scope ref+inner) - [(#//reference.Foreign (get@ [#.captured #.counter] scope)) - (#.Cons (update@ #.captured - (: (-> Foreign Foreign) - (|>> (update@ #.counter inc) - (update@ #.mappings (plist.put name [ref-type (product.left ref+inner)])))) - scope) - (product.right ref+inner))])) - [init-ref #.Nil] - (list.reverse inner)) - scopes (list/compose inner' outer)] - (#.Right [(set@ #.scopes scopes compiler) - (#.Some [ref-type ref])])) - )))) - -(def: #export (with-local [name type] action) - (All [a] (-> [Text Type] (Meta a) (Meta a))) - (function (_ compiler) - (case (get@ #.scopes compiler) - (#.Cons head tail) - (let [old-mappings (get@ [#.locals #.mappings] head) - new-var-id (get@ [#.locals #.counter] head) - new-head (update@ #.locals - (: (-> Locals Locals) - (|>> (update@ #.counter inc) - (update@ #.mappings (plist.put name [type new-var-id])))) - head)] - (case (macro.run' (set@ #.scopes (#.Cons new-head tail) compiler) - action) - (#e.Success [compiler' output]) - (case (get@ #.scopes compiler') - (#.Cons head' tail') - (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head') - tail')] - (#e.Success [(set@ #.scopes scopes' compiler') - output])) - - _ - (error! "Invalid scope alteration/")) - - (#e.Error error) - (#e.Error error))) - - _ - (#e.Error "Cannot create local binding without a scope.")) - )) - -(do-template [<name> <val-type>] - [(def: <name> - (Bindings Text [Type <val-type>]) - {#.counter +0 - #.mappings (list)})] - - [init-locals Nat] - [init-captured Variable] - ) - -(def: (scope parent-name child-name) - (-> (List Text) Text Scope) - {#.name (list& child-name parent-name) - #.inner +0 - #.locals init-locals - #.captured init-captured}) - -(def: #export (with-scope name action) - (All [a] (-> Text (Meta a) (Meta a))) - (function (_ compiler) - (let [parent-name (case (get@ #.scopes compiler) - #.Nil - (list) - - (#.Cons top _) - (get@ #.name top))] - (case (action (update@ #.scopes - (|>> (#.Cons (scope parent-name name))) - compiler)) - (#e.Error error) - (#e.Error error) - - (#e.Success [compiler' output]) - (#e.Success [(update@ #.scopes - (|>> list.tail (maybe.default (list))) - compiler') - output]) - )) - )) - -(def: #export next-local - (Meta Register) - (function (_ compiler) - (case (get@ #.scopes compiler) - #.Nil - (#e.Error "Cannot get next reference when there is no scope.") - - (#.Cons top _) - (#e.Success [compiler (get@ [#.locals #.counter] top)])))) - -(def: (ref-to-variable ref) - (-> Ref Variable) - (case ref - (#.Local register) - (#//reference.Local register) - - (#.Captured register) - (#//reference.Foreign register))) - -(def: #export (environment scope) - (-> Scope (List Variable)) - (|> scope - (get@ [#.captured #.mappings]) - (list/map (function (_ [_ [_ ref]]) (ref-to-variable ref))))) |