diff options
Diffstat (limited to 'stdlib')
15 files changed, 289 insertions, 257 deletions
diff --git a/stdlib/source/lux/abstract/functor.lux b/stdlib/source/lux/abstract/functor.lux index 1ade0a45b..a259673d4 100644 --- a/stdlib/source/lux/abstract/functor.lux +++ b/stdlib/source/lux/abstract/functor.lux @@ -18,12 +18,12 @@ (type: #export (Then f g) (All [a] (f (g a)))) -(def: #export (compose f-functor g-functor) +(def: #export (compose (^open "f@.") (^open "g@.")) {#.doc "Functor composition."} (All [F G] (-> (Functor F) (Functor G) (Functor (..Then F G)))) (structure (def: (map f fga) - (:: f-functor map (:: g-functor map f) fga)))) + (f@map (g@map f) fga)))) (signature: #export (Contravariant f) (: (All [a b] diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index 4472b047c..c893d2af6 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -8,9 +8,9 @@ ["//" error (#+ Error)] ["." maybe] ["." product] - ["." text ("#;." monoid)] + ["." text ("#@." monoid)] [collection - ["." list ("#;." functor fold)]]] + ["." list ("#@." functor fold)]]] ["." macro ["." code] ["s" syntax (#+ syntax: Syntax)] @@ -19,13 +19,11 @@ ["csr" reader] ["csw" writer]]]]]) -## [Types] (type: #export (Exception a) {#.doc "An exception provides a way to decorate error messages."} {#label Text #constructor (-> a Text)}) -## [Values] (def: #export (match? exception error) (All [e] (-> (Exception e) Text Bit)) (text.starts-with? (get@ #label exception) error)) @@ -98,44 +96,51 @@ (macro.with-gensyms [g!descriptor] (do @ [current-module macro.current-module-name - #let [descriptor ($_ text;compose "{" current-module "." name "}" text.new-line) + #let [descriptor ($_ text@compose "{" current-module "." name "}" text.new-line) g!self (code.local-identifier name)]] (wrap (list (` (def: (~+ (csw.export export)) (~ g!self) (All [(~+ (csw.type-variables t-vars))] - (..Exception [(~+ (list;map (get@ #cs.input-type) inputs))])) + (..Exception [(~+ (list@map (get@ #cs.input-type) inputs))])) (let [(~ g!descriptor) (~ (code.text descriptor))] {#..label (~ g!descriptor) - #..constructor (function ((~ g!self) [(~+ (list;map (get@ #cs.input-binding) inputs))]) - ((~! text;compose) (~ g!descriptor) + #..constructor (function ((~ g!self) [(~+ (list@map (get@ #cs.input-binding) inputs))]) + ((~! text@compose) (~ g!descriptor) (~ (maybe.default (' "") body))))}))))) ))) (def: #export (report' entries) (-> (List [Text Text]) Text) (let [largest-header-size (|> entries - (list;map (|>> product.left text.size)) - (list;fold n/max 0))] + (list@map (|>> product.left text.size)) + (list@fold n/max 0))] (|> entries - (list;map (function (_ [header message]) + (list@map (function (_ [header message]) (let [padding (|> " " (list.repeat (n/- (text.size header) largest-header-size)) (text.join-with ""))] - ($_ text;compose padding header ": " message text.new-line)))) + ($_ text@compose padding header ": " message text.new-line)))) (text.join-with "")))) (syntax: #export (report {entries (p.many (s.tuple (p.and s.any s.any)))}) (wrap (list (` (report' (list (~+ (|> entries - (list;map (function (_ [header message]) + (list@map (function (_ [header message]) (` [(~ header) (~ message)]))))))))))) (def: separator ($_ "lux text concat" text.new-line text.new-line - "-----------------------------------------" + "----------------------------------------------------------------" text.new-line text.new-line)) +(def: #export (decorate prelude error) + (-> Text Text Text) + ($_ "lux text concat" + prelude + ..separator + error)) + (def: #export (with-stack exception message computation) (All [e a] (-> (Exception e) e (Error a) (Error a))) (case computation @@ -145,10 +150,7 @@ (..construct exception message) _ - ($_ "lux text concat" - (..construct exception message) - ..separator - error))) + (..decorate (..construct exception message) error))) success success)) diff --git a/stdlib/source/lux/tool/compiler/analysis.lux b/stdlib/source/lux/tool/compiler/analysis.lux index 3abbc2ecc..2c4cdbc53 100644 --- a/stdlib/source/lux/tool/compiler/analysis.lux +++ b/stdlib/source/lux/tool/compiler/analysis.lux @@ -3,18 +3,19 @@ [abstract [monad (#+ do)]] [control - ["." function]] + ["." function] + ["." exception (#+ Exception)]] [data ["." product] ["." error] ["." maybe] - ["." text ("#;." equivalence) + ["." text ("#@." equivalence) format] [collection - ["." list ("#;." functor fold)]]]] + ["." list ("#@." functor fold)]]]] [// ["." reference (#+ Register Variable Reference)] - [phase + ["." phase ["." extension (#+ Extension)]]]) (type: #export #rec Primitive @@ -106,7 +107,7 @@ (def: #export (apply [abstraction inputs]) (-> (Application Analysis) Analysis) - (list;fold (function (_ input abstraction') + (list@fold (function (_ input abstraction') (#Apply input abstraction')) abstraction inputs)) @@ -195,7 +196,7 @@ (#Tuple members) (|> members - (list;map %analysis) + (list@map %analysis) (text.join-with " ") (text.enclose ["[" "]"]))) @@ -214,7 +215,7 @@ (|> (%analysis body) (format " ") (format (|> environment - (list;map reference.%variable) + (list@map reference.%variable) (text.join-with " ") (text.enclose ["[" "]"]))) (text.enclose ["(" ")"])) @@ -223,13 +224,13 @@ (|> analysis ..application #.Cons - (list;map %analysis) + (list@map %analysis) (text.join-with " ") (text.enclose ["(" ")"])) (#Extension name parameters) (|> parameters - (list;map %analysis) + (list@map %analysis) (text.join-with " ") (format (%t name) " ") (text.enclose ["(" ")"])))) @@ -293,7 +294,7 @@ (def: #export (with-cursor cursor action) (All [a] (-> Cursor (Operation a) (Operation a))) - (if (text;= "" (product.left cursor)) + (if (text@= "" (product.left cursor)) action (function (_ [bundle state]) (let [old-cursor (get@ #.cursor state)] @@ -303,8 +304,43 @@ output]) (#error.Failure error) - (#error.Failure (format "@ " (%cursor cursor) text.new-line - error))))))) + (#error.Failure error)))))) + +(def: (locate-error cursor error) + (-> Cursor Text Text) + (format "@ " (%cursor cursor) text.new-line + error)) + +(def: #export (fail error) + (-> Text Operation) + (function (_ [bundle state]) + (#error.Failure (locate-error (get@ #.cursor state) error)))) + +(def: #export (throw exception parameters) + (All [e] (-> (Exception e) e Operation)) + (..fail (exception.construct exception parameters))) + +(def: #export (fail' error) + (-> Text (phase.Operation Lux)) + (function (_ state) + (#error.Failure (locate-error (get@ #.cursor state) error)))) + +(def: #export (throw' exception parameters) + (All [e] (-> (Exception e) e (phase.Operation Lux))) + (..fail' (exception.construct exception parameters))) + +(def: #export (with-stack exception message action) + (All [e o] (-> (Exception e) e (Operation o) (Operation o))) + (function (_ bundle,state) + (case (action bundle,state) + (#error.Success output) + (#error.Success output) + + (#error.Failure error) + (let [[bundle state] bundle,state] + (#error.Failure (<| (locate-error (get@ #.cursor state)) + (exception.decorate (exception.construct exception message)) + error)))))) (template [<name> <type> <field> <value>] [(def: #export (<name> value) diff --git a/stdlib/source/lux/tool/compiler/phase.lux b/stdlib/source/lux/tool/compiler/phase.lux index dbe13e40c..2590b7048 100644 --- a/stdlib/source/lux/tool/compiler/phase.lux +++ b/stdlib/source/lux/tool/compiler/phase.lux @@ -66,8 +66,7 @@ (def: #export (throw exception parameters) (All [e] (-> (Exception e) e Operation)) - (state.lift error.monad - (ex.throw exception parameters))) + (..fail (ex.construct exception parameters))) (def: #export (lift error) (All [s a] (-> (Error a) (Operation s a))) @@ -79,11 +78,6 @@ (:: ..monad (~' wrap) []) (..throw (~ exception) (~ message))))))) -(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) - action)) - (def: #export identity (All [s a] (Phase s a a)) (function (_ input state) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/case.lux b/stdlib/source/lux/tool/compiler/phase/analysis/case.lux index 2aa4a57ca..9d7c9ea7f 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/case.lux @@ -11,7 +11,7 @@ [text format] [collection - ["." list ("#;." fold monoid functor)]]] + ["." list ("#@." fold monoid functor)]]] ["." type ["." check]] ["." macro @@ -80,7 +80,7 @@ (recur envs caseT') _ - (///.throw cannot-simplify-for-pattern-matching caseT))) + (/.throw cannot-simplify-for-pattern-matching caseT))) (#.Named name unnamedT) (recur envs unnamedT) @@ -115,12 +115,12 @@ (recur envs outputT) #.None - (///.throw cannot-simplify-for-pattern-matching caseT))) + (/.throw cannot-simplify-for-pattern-matching caseT))) (#.Product _) (|> caseT type.flatten-tuple - (list;map (re-quantify envs)) + (list@map (re-quantify envs)) type.tuple (:: ///.monad wrap)) @@ -189,16 +189,16 @@ num-sub-patterns (list.size sub-patterns) matches (cond (n/< num-subs num-sub-patterns) (let [[prefix suffix] (list.split (dec num-sub-patterns) subs)] - (list.zip2 (list;compose prefix (list (type.tuple suffix))) sub-patterns)) + (list.zip2 (list@compose prefix (list (type.tuple suffix))) sub-patterns)) (n/> num-subs num-sub-patterns) (let [[prefix suffix] (list.split (dec num-subs) sub-patterns)] - (list.zip2 subs (list;compose prefix (list (code.tuple suffix))))) + (list.zip2 subs (list@compose prefix (list (code.tuple suffix))))) ## (n/= num-subs num-sub-patterns) (list.zip2 subs sub-patterns))] (do @ - [[memberP+ thenA] (list;fold (: (All [a] + [[memberP+ thenA] (list@fold (: (All [a] (-> [Type Code] (Operation [(List Pattern) a]) (Operation [(List Pattern) a]))) (function (_ [memberT memberC] then) @@ -215,7 +215,7 @@ thenA]))) _ - (///.throw cannot-match-with-pattern [inputT pattern]) + (/.throw cannot-match-with-pattern [inputT pattern]) ))) [cursor (#.Record record)] @@ -258,10 +258,10 @@ nextA])) _ - (///.throw sum-has-no-case [idx inputT]))) + (/.throw sum-has-no-case [idx inputT]))) _ - (///.throw cannot-match-with-pattern [inputT pattern])))) + (/.throw cannot-match-with-pattern [inputT pattern])))) (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) (/.with-cursor cursor @@ -273,7 +273,7 @@ (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next))) _ - (///.throw not-a-pattern pattern) + (/.throw not-a-pattern pattern) )) (def: #export (case analyse inputC branches) @@ -296,8 +296,8 @@ (/coverage.exhaustive? coverage)) (#error.Failure error) - (///.fail error))] + (/.fail error))] (wrap (#/.Case inputA [outputH outputT]))) #.Nil - (///.throw cannot-have-empty-branches ""))) + (/.throw cannot-have-empty-branches ""))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux b/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux index e2d355881..3444a5355 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux @@ -6,17 +6,17 @@ [control ["ex" exception (#+ exception:)]] [data - ["." bit ("#;." equivalence)] - ["." error (#+ Error) ("#;." monad)] + ["." bit ("#@." equivalence)] + ["." error (#+ Error) ("#@." monad)] ["." maybe] [number ["." nat]] ["." text format] [collection - ["." list ("#;." functor fold)] + ["." list ("#@." functor fold)] ["." dictionary (#+ Dictionary)]]]] - ["." //// ("#;." monad) + ["." //// ("#@." monad) [// ["/" analysis (#+ Pattern Variant Operation)]]]) @@ -74,7 +74,7 @@ (#Variant ?max-cases cases) (|> cases dictionary.entries - (list;map (function (_ [idx coverage]) + (list@map (function (_ [idx coverage]) (format (%n idx) " " (%coverage coverage)))) (text.join-with " ") (text.enclose ["{" "}"]) @@ -95,13 +95,13 @@ (case pattern (^or (#/.Simple #/.Unit) (#/.Bind _)) - (////;wrap #Exhaustive) + (////@wrap #Exhaustive) ## Primitive patterns always have partial coverage because there ## are too many possibilities as far as values go. (^template [<tag>] (#/.Simple (<tag> _)) - (////;wrap #Partial)) + (////@wrap #Partial)) ([#/.Nat] [#/.Int] [#/.Rev] @@ -112,14 +112,14 @@ ## "#0", which means it is possible for bit ## pattern-matching to become exhaustive if complementary parts meet. (#/.Simple (#/.Bit value)) - (////;wrap (#Bit value)) + (////@wrap (#Bit value)) ## Tuple patterns can be exhaustive if there is exhaustiveness for all of ## their sub-patterns. (#/.Complex (#/.Tuple membersP+)) (case (list.reverse membersP+) (^or #.Nil (#.Cons _ #.Nil)) - (////.throw invalid-tuple-pattern []) + (/.throw invalid-tuple-pattern []) (#.Cons lastP prevsP+) (do ////.monad @@ -181,7 +181,7 @@ #1 [(#Bit sideR) (#Bit sideS)] - (bit;= sideR sideS) + (bit@= sideR sideS) [(#Variant allR casesR) (#Variant allS casesS)] (and (n/= (cases allR) @@ -217,12 +217,12 @@ (-> Coverage Coverage (Error Coverage)) (case [addition so-far] [#Partial #Partial] - (error;wrap #Partial) + (error@wrap #Partial) ## 2 bit coverages are exhaustive if they complement one another. (^multi [(#Bit sideA) (#Bit sideSF)] (xor sideA sideSF)) - (error;wrap #Exhaustive) + (error@wrap #Exhaustive) [(#Variant allA casesA) (#Variant allSF casesSF)] (let [addition-cases (cases allSF) @@ -283,7 +283,7 @@ ## The 2 sequences cannot possibly be merged. [#0 #0] - (error;wrap (#Alt so-far addition)) + (error@wrap (#Alt so-far addition)) ## There is nothing the addition adds to the coverage. [#1 #1] @@ -295,7 +295,7 @@ ## The addition completes the coverage. [#Exhaustive _] - (error;wrap #Exhaustive) + (error@wrap #Exhaustive) ## The left part will always match, so the addition is redundant. (^multi [(#Seq left right) single] @@ -305,7 +305,7 @@ ## The right part is not necessary, since it can always match the left. (^multi [single (#Seq left right)] (coverage/= left single)) - (error;wrap single) + (error@wrap single) ## When merging a new coverage against one based on Alt, it may be ## that one of the many coverages in the Alt is complementary to @@ -354,7 +354,7 @@ #.None (case (list.reverse possibilitiesSF) (#.Cons last prevs) - (wrap (list;fold (function (_ left right) (#Alt left right)) + (wrap (list@fold (function (_ left right) (#Alt left right)) last prevs)) @@ -366,4 +366,4 @@ ## The addition cannot possibly improve the coverage. (ex.throw redundant-pattern [so-far addition]) ## There are now 2 alternative paths. - (error;wrap (#Alt so-far addition))))) + (error@wrap (#Alt so-far addition))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/function.lux b/stdlib/source/lux/tool/compiler/phase/analysis/function.lux index 15842dcee..e63a3b8ee 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/function.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/function.lux @@ -9,7 +9,7 @@ ["." text format] [collection - ["." list ("#;." fold monoid monad)]]] + ["." list ("#@." fold monoid monad)]]] ["." type ["." check]] ["." macro]] @@ -32,7 +32,7 @@ (ex.report ["Function" (%type function)] ["Arguments" (|> arguments list.enumerate - (list;map (.function (_ [idx argC]) + (list@map (.function (_ [idx argC]) (format text.new-line " " (%n idx) " " (%code argC)))) (text.join-with ""))])) @@ -41,7 +41,7 @@ (do ///.monad [functionT (///extension.lift macro.expected-type)] (loop [expectedT functionT] - (///.with-stack cannot-analyse [expectedT function-name arg-name body] + (/.with-stack cannot-analyse [expectedT function-name arg-name body] (case expectedT (#.Named name unnamedT) (recur unnamedT) @@ -52,7 +52,7 @@ (recur value) #.None - (///.fail (ex.construct cannot-analyse [expectedT function-name arg-name body]))) + (/.fail (ex.construct cannot-analyse [expectedT function-name arg-name body]))) (^template [<tag> <instancer>] (<tag> _) @@ -94,12 +94,12 @@ (analyse body)) _ - (///.fail "") + (/.fail "") ))))) (def: #export (apply analyse functionT functionA argsC+) (-> Phase Type Analysis (List Code) (Operation Analysis)) - (<| (///.with-stack cannot-apply [functionT argsC+]) + (<| (/.with-stack cannot-apply [functionT argsC+]) (do ///.monad [[applyT argsA+] (//inference.general analyse functionT argsC+)]) (wrap (/.apply [functionA argsA+])))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/inference.lux b/stdlib/source/lux/tool/compiler/phase/analysis/inference.lux index 6f9cc4039..96ec554ad 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/inference.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/inference.lux @@ -9,13 +9,13 @@ ["." text format] [collection - ["." list ("#;." functor)]]] + ["." list ("#@." functor)]]] ["." type ["." check]] ["." macro]] ["." // #_ ["#." type] - ["#/" // ("#;." monad) + ["#/" // ("#@." monad) ["#." extension] [// ["/" analysis (#+ Tag Analysis Operation Phase)]]]]) @@ -29,7 +29,7 @@ (ex.report ["Type" (%type type)] ["Arguments" (|> args list.enumerate - (list;map (function (_ [idx argC]) + (list@map (function (_ [idx argC]) (format text.new-line " " (%n idx) " " (%code argC)))) (text.join-with ""))])) @@ -54,7 +54,7 @@ (-> Nat Type Type Type) (case type (#.Primitive name params) - (#.Primitive name (list;map (replace parameter-idx replacement) params)) + (#.Primitive name (list@map (replace parameter-idx replacement) params)) (^template [<tag>] (<tag> left right) @@ -72,7 +72,7 @@ (^template [<tag>] (<tag> env quantified) - (<tag> (list;map (replace parameter-idx replacement) env) + (<tag> (list@map (replace parameter-idx replacement) env) (replace (n/+ 2 parameter-idx) replacement quantified))) ([#.UnivQ] [#.ExQ]) @@ -139,7 +139,7 @@ (general analyse outputT args) #.None - (///.throw invalid-type-application inferT)) + (/.throw invalid-type-application inferT)) ## Arguments are inferred back-to-front because, by convention, ## Lux functions take the most important arguments *last*, which @@ -151,7 +151,7 @@ (#.Function inputT outputT) (do ///.monad [[outputT' args'A] (general analyse outputT args') - argA (<| (///.with-stack cannot-infer-argument [inputT argC]) + argA (<| (/.with-stack cannot-infer-argument [inputT argC]) (//type.with-type inputT) (analyse argC))] (wrap [outputT' (list& argA args'A)])) @@ -164,10 +164,10 @@ (general analyse inferT' args) _ - (///.throw cannot-infer [inferT args]))) + (/.throw cannot-infer [inferT args]))) _ - (///.throw cannot-infer [inferT args])) + (/.throw cannot-infer [inferT args])) )) ## Turns a record type into the kind of function type suitable for inference. @@ -191,13 +191,13 @@ (record outputT) #.None - (///.throw invalid-type-application inferT)) + (/.throw invalid-type-application inferT)) (#.Product _) - (///;wrap (type.function (type.flatten-tuple inferT) inferT)) + (///@wrap (type.function (type.flatten-tuple inferT) inferT)) _ - (///.throw not-a-record-type inferT))) + (/.throw not-a-record-type inferT))) ## Turns a variant type into the kind of function type suitable for inference. (def: #export (variant tag expected-size inferT) @@ -227,28 +227,28 @@ (n/< boundary tag))) (case (list.nth tag cases) (#.Some caseT) - (///;wrap (if (n/= 0 depth) + (///@wrap (if (n/= 0 depth) (type.function (list caseT) currentT) (let [replace' (replace (|> depth dec (n/* 2)) inferT)] (type.function (list (replace' caseT)) (replace' currentT))))) #.None - (///.throw variant-tag-out-of-bounds [expected-size tag inferT])) + (/.throw variant-tag-out-of-bounds [expected-size tag inferT])) (n/< expected-size actual-size) - (///.throw smaller-variant-than-expected [expected-size actual-size]) + (/.throw smaller-variant-than-expected [expected-size actual-size]) (n/= boundary tag) (let [caseT (type.variant (list.drop boundary cases))] - (///;wrap (if (n/= 0 depth) + (///@wrap (if (n/= 0 depth) (type.function (list caseT) currentT) (let [replace' (replace (|> depth dec (n/* 2)) inferT)] (type.function (list (replace' caseT)) (replace' currentT)))))) ## else - (///.throw variant-tag-out-of-bounds [expected-size tag inferT]))) + (/.throw variant-tag-out-of-bounds [expected-size tag inferT]))) (#.Apply inputT funcT) (case (type.apply (list inputT) funcT) @@ -256,7 +256,7 @@ (variant tag expected-size outputT) #.None - (///.throw invalid-type-application inferT)) + (/.throw invalid-type-application inferT)) _ - (///.throw not-a-variant-type inferT)))) + (/.throw not-a-variant-type inferT)))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/module.lux b/stdlib/source/lux/tool/compiler/phase/analysis/module.lux index c93d096c8..4894ce931 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/module.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/module.lux @@ -78,7 +78,7 @@ []])) (#.Some old) - (///.throw cannot-set-module-annotations-more-than-once [self-name old annotations]))))) + (/.throw' cannot-set-module-annotations-more-than-once [self-name old annotations]))))) (def: #export (import module) (-> Text (Operation Any)) @@ -136,7 +136,7 @@ []]) (#.Some already-existing) - ((///.throw cannot-define-more-than-once [self-name name]) state)))))) + ((/.throw' cannot-define-more-than-once [self-name name]) state)))))) (def: #export (create hash name) (-> Nat Text (Operation Any)) @@ -172,11 +172,11 @@ (plist.put module-name (set@ #.module-state <tag> module)) state) []]) - ((///.throw can-only-change-state-of-active-module [module-name <tag>]) + ((/.throw' can-only-change-state-of-active-module [module-name <tag>]) state))) #.None - ((///.throw unknown-module module-name) state))))) + ((/.throw' unknown-module module-name) state))))) (def: #export (<asker> module-name) (-> Text (Operation Bit)) @@ -190,7 +190,7 @@ _ #0)]) #.None - ((///.throw unknown-module module-name) state)))))] + ((/.throw' unknown-module module-name) state)))))] [set-active active? #.Active] [set-compiled compiled? #.Compiled] @@ -207,7 +207,7 @@ (#error.Success [state (get@ <tag> module)]) #.None - ((///.throw unknown-module module-name) state)))))] + ((/.throw' unknown-module module-name) state)))))] [tags #.tags (List [Text [Nat (List Name) Bit Type]])] [types #.types (List [Text [(List Name) Bit Type]])] @@ -225,7 +225,7 @@ (wrap []) (#.Some _) - (///.throw cannot-declare-tag-twice [module-name tag]))) + (/.throw cannot-declare-tag-twice [module-name tag]))) tags)] (wrap []))) @@ -238,7 +238,7 @@ (wrap type-name) _ - (///.throw cannot-declare-tags-for-unnamed-type [tags type])) + (/.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))] @@ -258,4 +258,4 @@ state) []])) #.None - ((///.throw unknown-module self-name) state)))))) + ((/.throw' unknown-module self-name) state)))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux b/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux index da142fed8..4ffa673fc 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux @@ -47,8 +47,8 @@ [imported! (///extension.lift (macro.imported-by? ::module current))] (if imported! <return> - (///.throw foreign-module-has-not-been-imported [current ::module]))) - (///.throw definition-has-not-been-exported def-name)))))))) + (/.throw foreign-module-has-not-been-imported [current ::module]))) + (/.throw definition-has-not-been-exported def-name)))))))) (def: (variable var-name) (-> Text (Operation (Maybe Analysis))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux b/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux index 3ee1def4d..a69346071 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux @@ -15,7 +15,7 @@ [text format] [collection - ["." list ("#;." functor)] + ["." list ("#@." functor)] ["." dictionary (#+ Dictionary)]]] ["." type ["." check]] @@ -64,7 +64,7 @@ (template [<name>] [(exception: #export (<name> {key Name} {record (List [Name Code])}) (ex.report ["Tag" (%code (code.tag key))] - ["Record" (%code (code.record (list;map (function (_ [keyI valC]) + ["Record" (%code (code.record (list@map (function (_ [keyI valC]) [(code.tag keyI) valC]) record)))]))] @@ -80,7 +80,7 @@ ["Actual" (|> actual .int %i)] ["Type" (%type type)] ["Expression" (%code (|> record - (list;map (function (_ [keyI valueC]) + (list@map (function (_ [keyI valueC]) [(code.tag keyI) valueC])) code.record))])) @@ -88,7 +88,7 @@ (-> Phase Nat Code (Operation Analysis)) (do ///.monad [expectedT (///extension.lift macro.expected-type)] - (///.with-stack cannot-analyse-variant [expectedT tag valueC] + (/.with-stack cannot-analyse-variant [expectedT tag valueC] (case expectedT (#.Sum _) (let [flat (type.flatten-variant expectedT) @@ -106,7 +106,7 @@ (wrap (/.variant [lefts right? 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 @@ -125,7 +125,7 @@ ## Cannot do inference when the tag is numeric. ## This is because there is no way of knowing how many ## cases the inferred sum type would have. - (///.throw cannot-infer-numeric-tag [expectedT tag valueC]) + (/.throw cannot-infer-numeric-tag [expectedT tag valueC]) )) (^template [<tag> <instancer>] @@ -148,7 +148,7 @@ (sum analyse tag valueC)) _ - (///.throw invalid-variant-type [expectedT tag valueC]))) + (/.throw invalid-variant-type [expectedT tag valueC]))) _ (case (type.apply (list inputT) funT) @@ -157,10 +157,10 @@ (sum analyse tag valueC)) #.None - (///.throw not-a-quantified-type funT))) + (/.throw not-a-quantified-type funT))) _ - (///.throw invalid-variant-type [expectedT tag valueC]))))) + (/.throw invalid-variant-type [expectedT tag valueC]))))) (def: (typed-product analyse members) (-> Phase (List Code) (Operation Analysis)) @@ -186,14 +186,14 @@ (wrap (#.Cons memberA memberA+))) _ - (///.throw cannot-analyse-tuple [expectedT members]))))] + (/.throw cannot-analyse-tuple [expectedT members]))))] (wrap (/.tuple membersA+)))) (def: #export (product analyse membersC) (-> Phase (List Code) (Operation Analysis)) (do ///.monad [expectedT (///extension.lift macro.expected-type)] - (///.with-stack cannot-analyse-tuple [expectedT membersC] + (/.with-stack cannot-analyse-tuple [expectedT membersC] (case expectedT (#.Product _) (..typed-product analyse membersC) @@ -218,8 +218,8 @@ membersC) _ (//type.with-env (check.check expectedT - (type.tuple (list;map product.left membersTA))))] - (wrap (/.tuple (list;map product.right membersTA)))))) + (type.tuple (list@map product.left membersTA))))] + (wrap (/.tuple (list@map product.right membersTA)))))) (^template [<tag> <instancer>] (<tag> _) @@ -241,7 +241,7 @@ (product analyse membersC)) _ - (///.throw invalid-tuple-type [expectedT membersC]))) + (/.throw invalid-tuple-type [expectedT membersC]))) _ (case (type.apply (list inputT) funT) @@ -250,10 +250,10 @@ (product analyse membersC)) #.None - (///.throw not-a-quantified-type funT))) + (/.throw not-a-quantified-type funT))) _ - (///.throw invalid-tuple-type [expectedT membersC]) + (/.throw invalid-tuple-type [expectedT membersC]) )))) (def: #export (tagged-sum analyse tag valueC) @@ -292,7 +292,7 @@ (wrap [key val])) _ - (///.throw record-keys-must-be-tags [key record]))) + (/.throw record-keys-must-be-tags [key record]))) record)) ## Lux already possesses the means to analyse tuples, so @@ -313,7 +313,7 @@ size-ts (list.size tag-set)] _ (if (n/= size-ts size-record) (wrap []) - (///.throw record-size-mismatch [size-ts size-record recordT record])) + (/.throw record-size-mismatch [size-ts size-record recordT record])) #let [tuple-range (list.indices size-ts) tag->idx (dictionary.from-list name.hash (list.zip2 tag-set tuple-range))] idx->val (monad.fold @ @@ -323,15 +323,15 @@ (case (dictionary.get key tag->idx) (#.Some idx) (if (dictionary.contains? idx idx->val) - (///.throw cannot-repeat-tag [key record]) + (/.throw cannot-repeat-tag [key record]) (wrap (dictionary.put idx val idx->val))) #.None - (///.throw tag-does-not-belong-to-record [key recordT])))) + (/.throw tag-does-not-belong-to-record [key recordT])))) (: (Dictionary Nat Code) (dictionary.new nat.hash)) record) - #let [ordered-tuple (list;map (function (_ idx) (maybe.assume (dictionary.get idx idx->val))) + #let [ordered-tuple (list@map (function (_ idx) (maybe.assume (dictionary.get idx idx->val))) tuple-range)]] (wrap [ordered-tuple recordT])) )) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/type.lux b/stdlib/source/lux/tool/compiler/phase/analysis/type.lux index 522e3f450..d7ebbe2a3 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/type.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/type.lux @@ -28,7 +28,7 @@ output]) (#error.Failure error) - ((///.fail error) stateE)))) + ((/.fail error) stateE)))) (def: #export with-fresh-env (All [a] (-> (Operation a) (Operation a))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension.lux b/stdlib/source/lux/tool/compiler/phase/extension.lux index bce8a66d9..43df97b9e 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension.lux @@ -7,10 +7,10 @@ ["ex" exception (#+ exception:)]] [data ["." error (#+ Error)] - ["." text ("#;." order) + ["." text ("#@." order) format] [collection - ["." list ("#;." functor)] + ["." list ("#@." functor)] ["." dictionary (#+ Dictionary)]]]] ["." //]) @@ -50,8 +50,8 @@ (ex.report ["Extension" (%t name)] ["Available" (|> bundle dictionary.keys - (list.sort text;<) - (list;map (|>> %t (format text.new-line text.tab))) + (list.sort text@<) + (list@map (|>> %t (format text.new-line text.tab))) (text.join-with ""))])) (exception: #export (incorrect-arity {name Name} {arity Nat} {args Nat}) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux index a62fee79f..f62b1031b 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux @@ -8,7 +8,7 @@ ["." text format] [collection - ["." list ("#;." functor)] + ["." list] ["." dictionary (#+ Dictionary)]]] [type ["." check]] @@ -39,7 +39,7 @@ (analyse argC))) (list.zip2 inputsT+ args))] (wrap (#/////analysis.Extension extension-name argsA))) - (////.throw ///.incorrect-arity [extension-name num-expected num-actual])))))) + (/////analysis.throw ///.incorrect-arity [extension-name num-expected num-actual])))))) (def: #export (nullary valueT) (-> Type Handler) @@ -81,7 +81,7 @@ (wrap (#/////analysis.Extension extension-name (list opA)))) _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: lux::in-module Handler @@ -92,7 +92,7 @@ (analyse exprC)) _ - (////.throw ///.invalid-syntax [extension-name])))) + (/////analysis.throw ///.invalid-syntax [extension-name])))) (template [<name> <type>] [(def: (<name> eval) @@ -109,7 +109,7 @@ (analyse valueC))) _ - (////.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))] + (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))] [lux::check actualT] [lux::coerce Any] @@ -127,7 +127,7 @@ (wrap valueA)) _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: (bundle::lux eval) (-> Eval Bundle) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux index 82df857b9..f3b6552c0 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux @@ -10,10 +10,10 @@ ["." error (#+ Error)] ["." maybe] ["." product] - ["." text ("#;." equivalence) + ["." text ("#@." equivalence) format] [collection - ["." list ("#;." fold functor monoid)] + ["." list ("#@." fold functor monoid)] ["." array (#+ Array)] ["." dictionary (#+ Dictionary)]]] ["." type @@ -25,7 +25,7 @@ ["#." common] ["#/" // ["#." bundle] - ["#/" // ("#;." monad) + ["#/" // ("#@." monad) [analysis [".A" type] [".A" inference]] @@ -97,7 +97,7 @@ (ex.report ["Class" class] ["Method" method] ["Hints" (|> hints - (list;map (|>> product.left %type (format text.new-line text.tab))) + (list@map (|>> product.left %type (format text.new-line text.tab))) (text.join-with ""))]))] [no-candidates] @@ -233,7 +233,7 @@ (wrap (#/////analysis.Extension extension-name (list arrayA)))) _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: array::new Handler @@ -254,7 +254,7 @@ (recur outputT level) #.None - (////.throw non-array expectedT)) + (/////analysis.throw non-array expectedT)) (^ (#.Primitive "#Array" (list elemT))) (recur elemT (inc level)) @@ -263,28 +263,28 @@ (wrap [level class]) _ - (////.throw non-array expectedT)))) + (/////analysis.throw non-array expectedT)))) _ (if (n/> 0 level) (wrap []) - (////.throw non-array expectedT))] + (/////analysis.throw non-array expectedT))] (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (dec level)) (/////analysis.text elem-class) lengthA)))) _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: (check-jvm objectT) (-> Type (Operation Text)) (case objectT (#.Primitive name _) - (////;wrap name) + (////@wrap name) (#.Named name unnamed) (check-jvm unnamed) (#.Var id) - (////;wrap "java.lang.Object") + (////@wrap "java.lang.Object") (^template [<tag>] (<tag> env unquantified) @@ -298,18 +298,18 @@ (check-jvm outputT) #.None - (////.throw non-object objectT)) + (/////analysis.throw non-object objectT)) _ - (////.throw non-object objectT))) + (/////analysis.throw non-object objectT))) (def: (check-object objectT) (-> Type (Operation Text)) (do ////.monad [name (check-jvm objectT)] (if (dictionary.contains? name boxes) - (////.throw primitives-are-not-objects name) - (////;wrap name)))) + (/////analysis.throw primitives-are-not-objects name) + (////@wrap name)))) (def: (box-array-element-type elemT) (-> Type (Operation [Type Text])) @@ -317,16 +317,16 @@ (#.Primitive name #.Nil) (let [boxed-name (|> (dictionary.get name boxes) (maybe.default name))] - (////;wrap [(#.Primitive boxed-name #.Nil) + (////@wrap [(#.Primitive boxed-name #.Nil) boxed-name])) (#.Primitive name _) (if (dictionary.contains? name boxes) - (////.throw primitives-cannot-have-type-parameters name) - (////;wrap [elemT name])) + (/////analysis.throw primitives-cannot-have-type-parameters name) + (////@wrap [elemT name])) _ - (////.throw invalid-type-for-array-element (%type elemT)))) + (/////analysis.throw invalid-type-for-array-element (%type elemT)))) (def: array::read Handler @@ -346,7 +346,7 @@ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text elem-class) idxA arrayA)))) _ - (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) (def: array::write Handler @@ -368,7 +368,7 @@ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text elem-class) idxA valueA arrayA)))) _ - (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) (def: bundle::array Bundle @@ -391,7 +391,7 @@ (wrap (#/////analysis.Extension extension-name (list)))) _ - (////.throw ///.incorrect-arity [extension-name 0 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 0 (list.size args)])))) (def: object::null? Handler @@ -406,7 +406,7 @@ (wrap (#/////analysis.Extension extension-name (list objectA)))) _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: object::synchronized Handler @@ -421,7 +421,7 @@ (wrap (#/////analysis.Extension extension-name (list monitorA exprA)))) _ - (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) (import: java/lang/Object (equals [Object] boolean)) @@ -491,7 +491,7 @@ (wrap class) (#error.Failure error) - (////.throw unknown-class name)))) + (/////analysis.throw unknown-class name)))) (def: (sub-class? super sub) (-> Text Text (Operation Bit)) @@ -514,11 +514,11 @@ _ (: (Operation Any) (if ? (wrap []) - (////.throw non-throwable exception-class)))] + (/////analysis.throw non-throwable exception-class)))] (wrap (#/////analysis.Extension extension-name (list exceptionA)))) _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: object::class Handler @@ -533,10 +533,10 @@ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class))))) _ - (////.throw ///.invalid-syntax extension-name)) + (/////analysis.throw ///.invalid-syntax extension-name)) _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: object::instance? Handler @@ -553,19 +553,19 @@ ? (sub-class? class object-class)] (if ? (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class)))) - (////.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) + (/////analysis.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) _ - (////.throw ///.invalid-syntax extension-name)) + (/////analysis.throw ///.invalid-syntax extension-name)) _ - (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) (def: (java-type-to-class jvm-type) (-> java/lang/reflect/Type (Operation Text)) (<| (case (host.check Class jvm-type) (#.Some jvm-type) - (////;wrap (Class::getName jvm-type)) + (////@wrap (Class::getName jvm-type)) _) (case (host.check ParameterizedType jvm-type) @@ -574,7 +574,7 @@ _) ## else - (////.throw cannot-convert-to-a-class jvm-type))) + (/////analysis.throw cannot-convert-to-a-class jvm-type))) (type: Mappings (Dictionary Text Type)) @@ -588,10 +588,10 @@ (let [var-name (TypeVariable::getName java-type)] (case (dictionary.get var-name mappings) (#.Some var-type) - (////;wrap var-type) + (////@wrap var-type) #.None - (////.throw unknown-type-var var-name))) + (/////analysis.throw unknown-type-var var-name))) _) (case (host.check WildcardType java-type) @@ -602,21 +602,21 @@ (java-type-to-lux-type mappings bound) _ - (////;wrap Any)) + (////@wrap Any)) _) (case (host.check Class java-type) (#.Some java-type) (let [java-type (:coerce (Class Object) java-type) class-name (Class::getName java-type)] - (////;wrap (case (array.size (Class::getTypeParameters java-type)) + (////@wrap (case (array.size (Class::getTypeParameters java-type)) 0 (#.Primitive class-name (list)) arity (|> (list.indices arity) list.reverse - (list;map (|>> (n/* 2) inc #.Parameter)) + (list@map (|>> (n/* 2) inc #.Parameter)) (#.Primitive class-name) (type.univ-q arity))))) @@ -631,11 +631,11 @@ ParameterizedType::getActualTypeArguments array.to-list (monad.map @ (java-type-to-lux-type mappings)))] - (////;wrap (#.Primitive (Class::getName (:coerce (Class Object) raw)) + (////@wrap (#.Primitive (Class::getName (:coerce (Class Object) raw)) paramsT))) _ - (////.throw jvm-type-is-not-a-class raw))) + (/////analysis.throw jvm-type-is-not-a-class raw))) _) (case (host.check GenericArrayType java-type) @@ -648,7 +648,7 @@ _) ## else - (////.throw cannot-convert-to-a-lux-type java-type))) + (/////analysis.throw cannot-convert-to-a-lux-type java-type))) (def: (correspond-type-params class type) (-> (Class Object) Type (Operation Mappings)) @@ -658,26 +658,26 @@ class-params (array.to-list (Class::getTypeParameters class)) num-class-params (list.size class-params) num-type-params (list.size params)] - (cond (not (text;= class-name name)) - (////.throw cannot-correspond-type-with-a-class - (format "Class = " class-name text.new-line - "Type = " (%type type))) + (cond (not (text@= class-name name)) + (/////analysis.throw cannot-correspond-type-with-a-class + (format "Class = " class-name text.new-line + "Type = " (%type type))) (not (n/= num-class-params num-type-params)) - (////.throw type-parameter-mismatch - (format "Expected: " (%i (.int num-class-params)) text.new-line - " Actual: " (%i (.int num-type-params)) text.new-line - " Class: " class-name text.new-line - " Type: " (%type type))) + (/////analysis.throw type-parameter-mismatch + (format "Expected: " (%i (.int num-class-params)) text.new-line + " Actual: " (%i (.int num-type-params)) text.new-line + " Class: " class-name text.new-line + " Type: " (%type type))) ## else - (////;wrap (|> params - (list.zip2 (list;map (|>> TypeVariable::getName) class-params)) + (////@wrap (|> params + (list.zip2 (list@map (|>> TypeVariable::getName) class-params)) (dictionary.from-list text.hash))) )) _ - (////.throw non-jvm-type type))) + (/////analysis.throw non-jvm-type type))) (def: object::cast Handler @@ -715,7 +715,7 @@ (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) + (if (text@= to-name current-name) (do @ [_ (typeA.infer toT)] (wrap #1)) @@ -735,7 +735,7 @@ (array.to-list (Class::getGenericInterfaces current-class))))] (case (|> candiate-parents (list.filter product.right) - (list;map product.left)) + (list@map product.left)) (#.Cons [next-name nextJT] _) (do @ [mapping (correspond-type-params current-class currentT) @@ -743,20 +743,20 @@ (recur [next-name nextT])) #.Nil - (////.throw cannot-cast (format "From class/primitive: " from-name text.new-line - " To class/primitive: " to-name text.new-line - " For value: " (%code valueC) text.new-line))) + (/////analysis.throw cannot-cast (format "From class/primitive: " from-name text.new-line + " To class/primitive: " to-name text.new-line + " For value: " (%code valueC) text.new-line))) ))))))] (if can-cast? (wrap (#/////analysis.Extension extension-name (list (/////analysis.text from-name) (/////analysis.text to-name) valueA))) - (////.throw cannot-cast (format "From class/primitive: " from-name text.new-line - " To class/primitive: " to-name text.new-line - " For value: " (%code valueC) text.new-line)))) + (/////analysis.throw cannot-cast (format "From class/primitive: " from-name text.new-line + " To class/primitive: " to-name text.new-line + " For value: " (%code valueC) text.new-line)))) _ - (////.throw ///.invalid-syntax extension-name)))) + (/////analysis.throw ///.invalid-syntax extension-name)))) (def: bundle::object Bundle @@ -780,13 +780,13 @@ (let [owner (Field::getDeclaringClass field)] (if (is? owner class) (wrap [class field]) - (////.throw mistaken-field-owner - (format " Field: " field-name text.new-line - " Owner Class: " (Class::getName owner) text.new-line - "Target Class: " class-name text.new-line)))) + (/////analysis.throw mistaken-field-owner + (format " Field: " field-name text.new-line + " Owner Class: " (Class::getName owner) text.new-line + "Target Class: " class-name text.new-line)))) (#error.Failure _) - (////.throw unknown-field (format class-name "#" field-name))))) + (/////analysis.throw unknown-field (format class-name "#" field-name))))) (def: (static-field class-name field-name) (-> Text Text (Operation [Type Bit])) @@ -798,7 +798,7 @@ (do @ [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] (wrap [fieldT (Modifier::isFinal modifiers)]))) - (////.throw not-a-static-field (format class-name "#" field-name))))) + (/////analysis.throw not-a-static-field (format class-name "#" field-name))))) (def: (virtual-field class-name field-name objectT) (-> Text Text Type (Operation [Type Bit])) @@ -811,7 +811,7 @@ var-names (|> class Class::getTypeParameters array.to-list - (list;map (|>> TypeVariable::getName)))] + (list@map (|>> TypeVariable::getName)))] mappings (: (Operation Mappings) (case objectT (#.Primitive _class-name _class-params) @@ -828,10 +828,10 @@ (dictionary.from-list text.hash)))) _ - (////.throw non-object objectT))) + (/////analysis.throw non-object objectT))) fieldT (java-type-to-lux-type mappings fieldJT)] (wrap [fieldT (Modifier::isFinal modifiers)])) - (////.throw not-a-virtual-field (format class-name "#" field-name))))) + (/////analysis.throw not-a-virtual-field (format class-name "#" field-name))))) (def: static::get Handler @@ -845,10 +845,10 @@ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field))))) _ - (////.throw ///.invalid-syntax extension-name)) + (/////analysis.throw ///.invalid-syntax extension-name)) _ - (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) (def: static::put Handler @@ -867,10 +867,10 @@ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA)))) _ - (////.throw ///.invalid-syntax extension-name)) + (/////analysis.throw ///.invalid-syntax extension-name)) _ - (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) (def: virtual::get Handler @@ -886,10 +886,10 @@ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) objectA)))) _ - (////.throw ///.invalid-syntax extension-name)) + (/////analysis.throw ///.invalid-syntax extension-name)) _ - (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) (def: virtual::put Handler @@ -910,16 +910,16 @@ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA objectA)))) _ - (////.throw ///.invalid-syntax extension-name)) + (/////analysis.throw ///.invalid-syntax extension-name)) _ - (////.throw ///.incorrect-arity [extension-name 4 (list.size args)])))) + (/////analysis.throw ///.incorrect-arity [extension-name 4 (list.size args)])))) (def: (java-type-to-parameter type) (-> java/lang/reflect/Type (Operation Text)) (<| (case (host.check Class type) (#.Some type) - (////;wrap (Class::getName type)) + (////@wrap (Class::getName type)) _) (case (host.check ParameterizedType type) @@ -929,12 +929,12 @@ _) (case (host.check TypeVariable type) (#.Some type) - (////;wrap "java.lang.Object") + (////@wrap "java.lang.Object") _) (case (host.check WildcardType type) (#.Some type) - (////;wrap "java.lang.Object") + (////@wrap "java.lang.Object") _) (case (host.check GenericArrayType type) @@ -946,7 +946,7 @@ _) ## else - (////.throw cannot-convert-to-a-parameter type))) + (/////analysis.throw cannot-convert-to-a-parameter type))) (type: Method-Style #Static @@ -963,7 +963,7 @@ (monad.map @ java-type-to-parameter)) #let [modifiers (Method::getModifiers method)]] (wrap (and (Object::equals class (Method::getDeclaringClass method)) - (text;= method-name (Method::getName method)) + (text@= method-name (Method::getName method)) (case #Static #Special (Modifier::isStatic modifiers) @@ -978,9 +978,9 @@ _ #1) (n/= (list.size arg-classes) (list.size parameters)) - (list;fold (function (_ [expectedJC actualJC] prev) + (list@fold (function (_ [expectedJC actualJC] prev) (and prev - (text;= expectedJC actualJC))) + (text@= expectedJC actualJC))) #1 (list.zip2 arg-classes parameters)))))) @@ -992,9 +992,9 @@ (monad.map @ java-type-to-parameter))] (wrap (and (Object::equals class (Constructor::getDeclaringClass constructor)) (n/= (list.size arg-classes) (list.size parameters)) - (list;fold (function (_ [expectedJC actualJC] prev) + (list@fold (function (_ [expectedJC actualJC] prev) (and prev - (text;= expectedJC actualJC))) + (text@= expectedJC actualJC))) #1 (list.zip2 arg-classes parameters)))))) @@ -1007,7 +1007,7 @@ (if (n/= 0 amount) (list) (|> (list.indices amount) - (list;map (|>> (n/+ offset) idx-to-parameter))))) + (list@map (|>> (n/+ offset) idx-to-parameter))))) (def: (method-signature method-style method) (-> Method-Style Method (Operation Method-Signature)) @@ -1020,20 +1020,20 @@ _ (|> (Class::getTypeParameters owner) array.to-list - (list;map (|>> TypeVariable::getName)))) + (list@map (|>> TypeVariable::getName)))) method-tvars (|> (Method::getTypeParameters method) array.to-list - (list;map (|>> TypeVariable::getName))) + (list@map (|>> TypeVariable::getName))) num-owner-tvars (list.size owner-tvars) num-method-tvars (list.size method-tvars) - all-tvars (list;compose owner-tvars method-tvars) + all-tvars (list@compose owner-tvars method-tvars) num-all-tvars (list.size all-tvars) owner-tvarsT (type-vars num-owner-tvars 0) method-tvarsT (type-vars num-method-tvars num-owner-tvars) mappings (: Mappings (if (list.empty? all-tvars) fresh-mappings - (|> (list;compose owner-tvarsT method-tvarsT) + (|> (list@compose owner-tvarsT method-tvarsT) list.reverse (list.zip2 all-tvars) (dictionary.from-list text.hash))))] @@ -1088,7 +1088,7 @@ (cond passes? (:: @ map (|>> #Pass) (method-signature method-style method)) - (text;= method-name (Method::getName method)) + (text@= method-name (Method::getName method)) (:: @ map (|>> #Hint) (method-signature method-style method)) ## else @@ -1098,10 +1098,10 @@ (wrap method) #.Nil - (////.throw no-candidates [class-name method-name (list.search-all hint! candidates)]) + (/////analysis.throw no-candidates [class-name method-name (list.search-all hint! candidates)]) candidates - (////.throw too-many-candidates [class-name method-name candidates])))) + (/////analysis.throw too-many-candidates [class-name method-name candidates])))) (def: (constructor-signature constructor) (-> (Constructor Object) (Operation Method-Signature)) @@ -1109,19 +1109,19 @@ owner-name (Class::getName owner) owner-tvars (|> (Class::getTypeParameters owner) array.to-list - (list;map (|>> TypeVariable::getName))) + (list@map (|>> TypeVariable::getName))) constructor-tvars (|> (Constructor::getTypeParameters constructor) array.to-list - (list;map (|>> TypeVariable::getName))) + (list@map (|>> TypeVariable::getName))) num-owner-tvars (list.size owner-tvars) - all-tvars (list;compose owner-tvars constructor-tvars) + all-tvars (list@compose owner-tvars constructor-tvars) num-all-tvars (list.size all-tvars) owner-tvarsT (type-vars num-owner-tvars 0) constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) mappings (: Mappings (if (list.empty? all-tvars) fresh-mappings - (|> (list;compose owner-tvarsT constructor-tvarsT) + (|> (list@compose owner-tvarsT constructor-tvarsT) list.reverse (list.zip2 all-tvars) (dictionary.from-list text.hash))))] @@ -1158,16 +1158,16 @@ (wrap constructor) #.Nil - (////.throw no-candidates [class-name ..constructor-method (list.search-all hint! candidates)]) + (/////analysis.throw no-candidates [class-name ..constructor-method (list.search-all hint! candidates)]) candidates - (////.throw too-many-candidates [class-name ..constructor-method candidates])))) + (/////analysis.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 /////analysis.text typesT)) - (list;map (function (_ [type value]) + (list.zip2 (list@map /////analysis.text typesT)) + (list@map (function (_ [type value]) (/////analysis.tuple (list type value)))))) (def: invoke::static @@ -1177,15 +1177,15 @@ (s.run args ($_ p.and s.text s.text (p.some (s.tuple (p.and s.text s.any)))))) (#error.Success [class method argsTC]) (do ////.monad - [#let [argsT (list;map product.left argsTC)] + [#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)) + [outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC)) outputJC (check-jvm outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) (/////analysis.text outputJC) (decorate-inputs argsT argsA))))) _ - (////.throw ///.invalid-syntax extension-name)))) + (/////analysis.throw ///.invalid-syntax extension-name)))) (def: invoke::virtual Handler @@ -1194,9 +1194,9 @@ (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) (#error.Success [class method objectC argsTC]) (do ////.monad - [#let [argsT (list;map product.left argsTC)] + [#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))) + [outputT allA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) #let [[objectA argsA] (case allA (#.Cons objectA argsA) [objectA argsA] @@ -1208,7 +1208,7 @@ (/////analysis.text outputJC) objectA (decorate-inputs argsT argsA))))) _ - (////.throw ///.invalid-syntax extension-name)))) + (/////analysis.throw ///.invalid-syntax extension-name)))) (def: invoke::special Handler @@ -1217,15 +1217,15 @@ (p.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any))) s.end!))) (#error.Success [_ [class method objectC argsTC _]]) (do ////.monad - [#let [argsT (list;map product.left argsTC)] + [#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))) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) outputJC (check-jvm outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) (/////analysis.text outputJC) (decorate-inputs argsT argsA))))) _ - (////.throw ///.invalid-syntax extension-name)))) + (/////analysis.throw ///.invalid-syntax extension-name)))) (def: invoke::interface Handler @@ -1234,19 +1234,19 @@ (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) (#error.Success [class-name method objectC argsTC]) (do ////.monad - [#let [argsT (list;map product.left argsTC)] + [#let [argsT (list@map product.left argsTC)] class (load-class class-name) _ (////.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))) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) outputJC (check-jvm outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class-name) (/////analysis.text method) (/////analysis.text outputJC) (decorate-inputs argsT argsA))))) _ - (////.throw ///.invalid-syntax extension-name)))) + (/////analysis.throw ///.invalid-syntax extension-name)))) (def: invoke::constructor Handler @@ -1255,13 +1255,13 @@ (s.run args ($_ p.and s.text (p.some (s.tuple (p.and s.text s.any)))))) (#error.Success [class argsTC]) (do ////.monad - [#let [argsT (list;map product.left argsTC)] + [#let [argsT (list@map product.left argsTC)] [methodT exceptionsT] (constructor-candidate class argsT) - [outputT argsA] (inferenceA.general analyse methodT (list;map product.right argsTC))] + [outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (decorate-inputs argsT argsA))))) _ - (////.throw ///.invalid-syntax extension-name)))) + (/////analysis.throw ///.invalid-syntax extension-name)))) (def: bundle::member Bundle |