diff options
Diffstat (limited to 'stdlib/source')
20 files changed, 599 insertions, 604 deletions
diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux index fd20a208b..6883811a6 100644 --- a/stdlib/source/lux/cli.lux +++ b/stdlib/source/lux/cli.lux @@ -5,7 +5,7 @@ monad) (data (coll (list #as list #open ("List/" Monoid<List> Monad<List>))) (text #as text #open ("Text/" Monoid<Text>)) - error + ["R" result] (sum #as sum)) [io] [macro #+ with-gensyms Functor<Lux> Monad<Lux>] @@ -15,38 +15,38 @@ ## [Types] (type: #export (CLI a) {#;doc "A command-line interface parser."} - (-> (List Text) (Error [(List Text) a]))) + (-> (List Text) (R;Result [(List Text) a]))) ## [Utils] (def: (run' opt inputs) - (All [a] (-> (CLI a) (List Text) (Error [(List Text) a]))) + (All [a] (-> (CLI a) (List Text) (R;Result [(List Text) a]))) (opt inputs)) ## [Structures] (struct: #export _ (Functor CLI) (def: (map f ma inputs) (case (ma inputs) - (#;Left msg) (#;Left msg) - (#;Right [inputs' datum]) (#;Right [inputs' (f datum)])))) + (#R;Error msg) (#R;Error msg) + (#R;Success [inputs' datum]) (#R;Success [inputs' (f datum)])))) (struct: #export _ (Applicative CLI) (def: functor Functor<CLI>) (def: (wrap a inputs) - (#;Right [inputs a])) + (#R;Success [inputs a])) (def: (apply ff fa inputs) (case (ff inputs) - (#;Right [inputs' f]) + (#R;Success [inputs' f]) (case (fa inputs') - (#;Right [inputs'' a]) - (#;Right [inputs'' (f a)]) + (#R;Success [inputs'' a]) + (#R;Success [inputs'' (f a)]) - (#;Left msg) - (#;Left msg)) + (#R;Error msg) + (#R;Error msg)) - (#;Left msg) - (#;Left msg)) + (#R;Error msg) + (#R;Error msg)) )) (struct: #export _ (Monad CLI) @@ -54,8 +54,8 @@ (def: (join mma inputs) (case (mma inputs) - (#;Left msg) (#;Left msg) - (#;Right [inputs' ma]) (ma inputs')))) + (#R;Error msg) (#R;Error msg) + (#R;Success [inputs' ma]) (ma inputs')))) ## [Combinators] (def: #export any @@ -64,26 +64,26 @@ (function [inputs] (case inputs (#;Cons arg inputs') - (#;Right [inputs' arg]) + (#R;Success [inputs' arg]) _ - (#;Left "Cannot parse empty arguments.")))) + (#R;Error "Cannot parse empty arguments.")))) (def: #export (parse parser) {#;doc "Parses the next input with a parsing function."} - (All [a] (-> (-> Text (Error a)) (CLI a))) + (All [a] (-> (-> Text (R;Result a)) (CLI a))) (function [inputs] (case inputs (#;Cons arg inputs') (case (parser arg) - (#;Right value) - (#;Right [inputs' value]) + (#R;Success value) + (#R;Success [inputs' value]) - (#;Left parser-error) - (#;Left parser-error)) + (#R;Error parser-error) + (#R;Error parser-error)) _ - (#;Left "Cannot parse empty arguments.")))) + (#R;Error "Cannot parse empty arguments.")))) (def: #export (option names) {#;doc "Checks that a given option (with multiple possible names) has a value."} @@ -92,13 +92,13 @@ (let [[pre post] (list;split-with (. ;not (list;member? text;Eq<Text> names)) inputs)] (case post #;Nil - (#;Left ($_ Text/append "Missing option (" (text;join-with " " names) ")")) + (#R;Error ($_ Text/append "Missing option (" (text;join-with " " names) ")")) (^ (list& _ value post')) - (#;Right [(List/append pre post') value]) + (#R;Success [(List/append pre post') value]) _ - (#;Left ($_ Text/append "Option lacks value (" (text;join-with " " names) ")")) + (#R;Error ($_ Text/append "Option lacks value (" (text;join-with " " names) ")")) )))) (def: #export (flag names) @@ -108,18 +108,18 @@ (let [[pre post] (list;split-with (. ;not (list;member? text;Eq<Text> names)) inputs)] (case post #;Nil - (#;Right [pre false]) + (#R;Success [pre false]) (#;Cons _ post') - (#;Right [(List/append pre post') true]))))) + (#R;Success [(List/append pre post') true]))))) (def: #export end {#;doc "Ensures there are no more inputs."} (CLI Unit) (function [inputs] (case inputs - #;Nil (#;Right [inputs []]) - _ (#;Left (Text/append "Unknown parameters: " (text;join-with " " inputs)))))) + #;Nil (#R;Success [inputs []]) + _ (#R;Error (Text/append "Unknown parameters: " (text;join-with " " inputs)))))) (def: #export (after param subject) (All [p s] (-> (CLI p) (CLI s) (CLI s))) @@ -139,8 +139,8 @@ (-> Text Bool (CLI Unit)) (function [inputs] (if test - (#;Right [inputs []]) - (#;Left message)))) + (#R;Success [inputs []]) + (#R;Error message)))) (def: #export (opt opt) {#;doc "Optionality combinator."} @@ -148,8 +148,8 @@ (-> (CLI a) (CLI (Maybe a)))) (function [inputs] (case (opt inputs) - (#;Left _) (#;Right [inputs #;None]) - (#;Right [inputs' x]) (#;Right [inputs' (#;Some x)])))) + (#R;Error _) (#R;Success [inputs #;None]) + (#R;Success [inputs' x]) (#R;Success [inputs' (#;Some x)])))) (def: #export (seq optL optR) {#;doc "Sequencing combinator."} @@ -164,27 +164,27 @@ (All [a b] (-> (CLI a) (CLI b) (CLI (| a b)))) (function [inputs] (case (optL inputs) - (#;Left msg) + (#R;Error msg) (case (optR inputs) - (#;Left _) - (#;Left msg) + (#R;Error _) + (#R;Error msg) - (#;Right [inputs' r]) - (#;Right [inputs' (sum;right r)])) + (#R;Success [inputs' r]) + (#R;Success [inputs' (sum;right r)])) - (#;Right [inputs' l]) - (#;Right [inputs' (sum;left l)])))) + (#R;Success [inputs' l]) + (#R;Success [inputs' (sum;left l)])))) (def: #export (not opt) {#;doc "The opposite of the given CLI."} (All [a] (-> (CLI a) (CLI Unit))) (function [inputs] (case (opt inputs) - (#;Left msg) - (#;Right [inputs []]) + (#R;Error msg) + (#R;Success [inputs []]) _ - (#;Left "Expected to fail; yet succeeded.")))) + (#R;Error "Expected to fail; yet succeeded.")))) (def: #export (some opt) {#;doc "0-or-more combinator."} @@ -192,11 +192,11 @@ (-> (CLI a) (CLI (List a)))) (function [inputs] (case (opt inputs) - (#;Left _) (#;Right [inputs (list)]) - (#;Right [inputs' x]) (run' (do Monad<CLI> - [xs (some opt)] - (wrap (list& x xs))) - inputs')))) + (#R;Error _) (#R;Success [inputs (list)]) + (#R;Success [inputs' x]) (run' (do Monad<CLI> + [xs (some opt)] + (wrap (list& x xs))) + inputs')))) (def: #export (many opt) {#;doc "1-or-more combinator."} @@ -213,17 +213,17 @@ (-> (CLI a) (CLI a) (CLI a))) (function [inputs] (case (pl inputs) - (#;Left _) (pr inputs) + (#R;Error _) (pr inputs) output output))) (def: #export (run opt inputs) - (All [a] (-> (CLI a) (List Text) (Error a))) + (All [a] (-> (CLI a) (List Text) (R;Result a))) (case (opt inputs) - (#;Left msg) - (#;Left msg) + (#R;Error msg) + (#R;Error msg) - (#;Right [_ value]) - (#;Right value))) + (#R;Success [_ value]) + (#R;Success value))) ## [Syntax] (type: Program-Args @@ -271,10 +271,10 @@ (~ g!_) ;;end] ((~' wrap) (~ body)))) (~ g!args)) - (#;Right [(~ g!_) (~ g!output)]) + (#R;Success [(~ g!_) (~ g!output)]) (~ g!output) - (#;Left (~ g!message)) + (#R;Error (~ g!message)) (error! (~ g!message)) ))) ))) diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index 42b8908f9..de1c9d745 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -3,7 +3,7 @@ (lux (control monad) [io #- run] function - (data [error #- fail] + (data ["R" result] text/format (coll [list "List/" Monoid<List> Monad<List>]) [product] @@ -26,7 +26,7 @@ (type: #export (Behavior s m) {#;doc "An actor's behavior when messages are received."} - {#step (-> (Actor s m) (-> m s (P;Promise (Error s)))) + {#step (-> (Actor s m) (-> m s (P;Promise (R;Result s)))) #end (-> (Maybe Text) s (P;Promise Unit))}) ## [Values] @@ -225,7 +225,7 @@ protocol-pm (List/map (: (-> Method [Code Code]) (function [(^slots [#name #vars #args #return #body])] (let [arg-names (|> (list;size args) (list;n.range +1) (List/map (|>. Nat/encode [""] code;symbol))) - body-func (` (: (-> (~ g!state-name) (~@ (List/map product;right args)) (P;Promise (Error [(~ g!state-name) (~ return)]))) + body-func (` (: (-> (~ g!state-name) (~@ (List/map product;right args)) (P;Promise (R;Result [(~ g!state-name) (~ return)]))) (function (~ (code;symbol ["" _name])) [(~ g!state) (~@ (List/map (|>. product;left [""] code;symbol) args))] (do P;Monad<Promise> [] diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux index edca7d05a..a6c814c5a 100644 --- a/stdlib/source/lux/concurrency/promise.lux +++ b/stdlib/source/lux/concurrency/promise.lux @@ -2,8 +2,7 @@ lux (lux (data (coll [list #* "" Functor<List>]) number - text/format - error) + text/format) [io #- run] function (control functor diff --git a/stdlib/source/lux/control/codec.lux b/stdlib/source/lux/control/codec.lux index 18937ede1..63ef0526b 100644 --- a/stdlib/source/lux/control/codec.lux +++ b/stdlib/source/lux/control/codec.lux @@ -1,14 +1,14 @@ (;module: lux (lux control/monad - data/error)) + data/result)) ## [Signatures] (sig: #export (Codec m a) {#;doc "A way to move back-and-forth between a type and an alternative representation for it."} (: (-> a m) encode) - (: (-> m (Error a)) + (: (-> m (Result a)) decode)) ## [Values] @@ -18,7 +18,7 @@ (def: encode (|>. (:: Codec<b,a> encode) (:: Codec<c,b> encode))) (def: (decode cy) - (do Monad<Error> + (do Monad<Result> [by (:: Codec<c,b> decode cy)] (:: Codec<b,a> decode by))) ) diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux index 0c867f4be..447012689 100644 --- a/stdlib/source/lux/control/effect.lux +++ b/stdlib/source/lux/control/effect.lux @@ -7,7 +7,6 @@ (data (coll [list "List/" Monad<List> Monoid<List>]) [number "Nat/" Codec<Text,Nat>] text/format - error [ident "Ident/" Eq<Ident>] [text]) [macro] diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index 66214f90c..fc5cf9c64 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -1,7 +1,7 @@ -(;module: {#;doc "Exception-handling functionality built on top of the Error type."} +(;module: {#;doc "Exception-handling functionality built on top of the Result type."} lux (lux (control monad) - (data [error #- fail] + (data [result #- fail] [text]) [macro] (macro [code] @@ -23,8 +23,8 @@ If no exception was detected, or a different one from the one being checked, then pass along the original value."} (All [a] - (-> Exception (-> Text a) (Error a) - (Error a))) + (-> Exception (-> Text a) (Result a) + (Result a))) (case try (#;Right output) (#;Right output) @@ -37,7 +37,7 @@ (def: #export (otherwise to-do try) {#;doc "If no handler could be found to catch the exception, then run a function as a last-resort measure."} (All [a] - (-> (-> Text a) (Error a) a)) + (-> (-> Text a) (Result a) a)) (case try (#;Right output) output @@ -46,13 +46,13 @@ (to-do error))) (def: #export (return value) - {#;doc "A way to lift normal values into the error-handling context."} - (All [a] (-> a (Error a))) + {#;doc "A way to lift normal values into the result-handling context."} + (All [a] (-> a (Result a))) (#;Right value)) (def: #export (throw exception message) - {#;doc "Decorate an error message with an Exception and lift it into the error-handling context."} - (All [a] (-> Exception Text (Error a))) + {#;doc "Decorate an error message with an Exception and lift it into the result-handling context."} + (All [a] (-> Exception Text (Result a))) (#;Left (exception message))) (syntax: #export (exception: [_ex-lev common;export-level] [name s;local-symbol]) diff --git a/stdlib/source/lux/data/coll/array.lux b/stdlib/source/lux/data/coll/array.lux index 8631f154d..a8f8d9f00 100644 --- a/stdlib/source/lux/data/coll/array.lux +++ b/stdlib/source/lux/data/coll/array.lux @@ -6,8 +6,7 @@ monad eq fold) - (data error - (coll [list "List/" Fold<List>]) + (data (coll [list "List/" Fold<List>]) [product]) )) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index b75b9dbf7..0919f305f 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -14,7 +14,7 @@ [number #* "Real/" Codec<Text,Real>] maybe [char "Char/" Eq<Char> Codec<Text,Char>] - [error #- fail] + ["R" result #- fail] [sum] [product] (coll [list "" Fold<List> "List/" Monad<List>] @@ -54,7 +54,7 @@ (type: #export (Parser a) {#;doc "JSON parsers."} - (-> JSON (Error a))) + (-> JSON (Result a))) (type: #export (Gen a) {#;doc "JSON generators."} @@ -150,52 +150,52 @@ (def: #export (fields json) {#;doc "Get all the fields in a JSON object."} - (-> JSON (Error (List String))) + (-> JSON (Result (List String))) (case json (#Object obj) - (#;Right (dict;keys obj)) + (#R;Success (dict;keys obj)) _ - (#;Left (format "Cannot get the fields of a non-object.")))) + (#R;Error (format "Cannot get the fields of a non-object.")))) (def: #export (get key json) {#;doc "A JSON object field getter."} - (-> String JSON (Error JSON)) + (-> String JSON (Result JSON)) (case json (#Object obj) (case (dict;get key obj) (#;Some value) - (#;Right value) + (#R;Success value) #;None - (#;Left (format "Missing field " (show-string key) " on object."))) + (#R;Error (format "Missing field " (show-string key) " on object."))) _ - (#;Left (format "Cannot get field " (show-string key) " of a non-object.")))) + (#R;Error (format "Cannot get field " (show-string key) " of a non-object.")))) (def: #export (set key value json) {#;doc "A JSON object field setter."} - (-> String JSON JSON (Error JSON)) + (-> String JSON JSON (Result JSON)) (case json (#Object obj) - (#;Right (#Object (dict;put key value obj))) + (#R;Success (#Object (dict;put key value obj))) _ - (#;Left (format "Cannot set field " (show-string key) " of a non-object.")))) + (#R;Error (format "Cannot set field " (show-string key) " of a non-object.")))) (do-template [<name> <tag> <type> <desc>] [(def: #export (<name> key json) {#;doc (#;TextA (format "A JSON object field getter for " <desc> "."))} - (-> Text JSON (Error <type>)) + (-> Text JSON (Result <type>)) (case (get key json) - (#;Right (<tag> value)) - (#;Right value) + (#R;Success (<tag> value)) + (#R;Success value) - (#;Right _) - (#;Left (format "Wrong value type at key " (show-string key))) + (#R;Success _) + (#R;Error (format "Wrong value type at key " (show-string key))) - (#;Left error) - (#;Left error)))] + (#R;Error error) + (#R;Error error)))] [get-boolean #Boolean Boolean "booleans"] [get-number #Number Number "numbers"] @@ -275,12 +275,12 @@ sign (lexer;default "" (lexer;text "-")) offset (lexer;many' lexer;digit)] (wrap (format mark sign offset)))))] - (case (: (Error Real) + (case (: (Result Real) (Real/decode (format ?sign digits "." decimals exp))) - (#;Left message) + (#R;Error message) (lexer;fail message) - (#;Right value) + (#R;Success value) (wrap value)))) (def: (un-escape escaped) @@ -351,31 +351,31 @@ (def: (map f ma) (function [json] (case (ma json) - (#;Left msg) - (#;Left msg) + (#R;Error msg) + (#R;Error msg) - (#;Right a) - (#;Right (f a)))))) + (#R;Success a) + (#R;Success (f a)))))) (struct: #export _ (Applicative Parser) (def: functor Functor<Parser>) (def: (wrap x json) - (#;Right x)) + (#R;Success x)) (def: (apply ff fa) (function [json] (case (ff json) - (#;Right f) + (#R;Success f) (case (fa json) - (#;Right a) - (#;Right (f a)) + (#R;Success a) + (#R;Success (f a)) - (#;Left msg) - (#;Left msg)) + (#R;Error msg) + (#R;Error msg)) - (#;Left msg) - (#;Left msg))))) + (#R;Error msg) + (#R;Error msg))))) (struct: #export _ (Monad Parser) (def: applicative Applicative<Parser>) @@ -383,10 +383,10 @@ (def: (join mma) (function [json] (case (mma json) - (#;Left msg) - (#;Left msg) + (#R;Error msg) + (#R;Error msg) - (#;Right ma) + (#R;Success ma) (ma json))))) ## [Values] @@ -397,10 +397,10 @@ (Parser <type>) (case json (<tag> value) - (#;Right (<pre> value)) + (#R;Success (<pre> value)) _ - (#;Left (format "JSON value is not " <desc> ": " (show-json json)))))] + (#R;Error (format "JSON value is not " <desc> ": " (show-json json)))))] [unit Unit #Null "unit" id] [bool Bool #Boolean "bool" id] @@ -415,10 +415,10 @@ (-> <type> (Parser Bool)) (case json (<tag> value) - (#;Right (:: <eq> = test (<pre> value))) + (#R;Success (:: <eq> = test (<pre> value))) _ - (#;Left (format "JSON value is not a " <desc> ": " (show-json json))))) + (#R;Error (format "JSON value is not a " <desc> ": " (show-json json))))) (def: #export (<check> test json) {#;doc (#;TextA (format "Ensures a JSON value is a " <desc> "."))} @@ -427,12 +427,12 @@ (<tag> value) (let [value (<pre> value)] (if (:: <eq> = test value) - (#;Right []) - (#;Left (format "Value mismatch: " - (:: <codec> encode test) "=/=" (:: <codec> encode value))))) + (#R;Success []) + (#R;Error (format "Value mismatch: " + (:: <codec> encode test) "=/=" (:: <codec> encode value))))) _ - (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))] + (#R;Error (format "JSON value is not a " <desc> ": " (show-json json)))))] [bool? bool! Bool bool;Eq<Bool> bool;Codec<Text,Bool> #Boolean "boolean" id] [int? int! Int number;Eq<Int> number;Codec<Text,Int> #Number "number" real-to-int] @@ -446,14 +446,14 @@ (case json (#String input) (case (Char/decode (format "#\"" input "\"")) - (#;Right value) - (#;Right value) + (#R;Success value) + (#R;Success value) - (#;Left _) - (#;Left (format "Invalid format for char: " input))) + (#R;Error _) + (#R;Error (format "Invalid format for char: " input))) _ - (#;Left (format "JSON value is not a " "string" ": " (show-json json))))) + (#R;Error (format "JSON value is not a " "string" ": " (show-json json))))) (def: #export (char? test json) {#;doc "Asks whether a JSON value is a single-character string with the specified character."} @@ -461,17 +461,17 @@ (case json (#String input) (case (Char/decode (format "#\"" input "\"")) - (#;Right value) + (#R;Success value) (if (:: char;Eq<Char> = test value) - (#;Right true) - (#;Left (format "Value mismatch: " - (:: char;Codec<Text,Char> encode test) "=/=" (:: char;Codec<Text,Char> encode value)))) + (#R;Success true) + (#R;Error (format "Value mismatch: " + (:: char;Codec<Text,Char> encode test) "=/=" (:: char;Codec<Text,Char> encode value)))) - (#;Left _) - (#;Left (format "Invalid format for char: " input))) + (#R;Error _) + (#R;Error (format "Invalid format for char: " input))) _ - (#;Left (format "JSON value is not a " "string" ": " (show-json json))))) + (#R;Error (format "JSON value is not a " "string" ": " (show-json json))))) (def: #export (char! test json) {#;doc "Ensures a JSON value is a single-character string with the specified character."} @@ -479,17 +479,17 @@ (case json (#String input) (case (Char/decode (format "#\"" input "\"")) - (#;Right value) + (#R;Success value) (if (:: char;Eq<Char> = test value) - (#;Right []) - (#;Left (format "Value mismatch: " - (:: char;Codec<Text,Char> encode test) "=/=" (:: char;Codec<Text,Char> encode value)))) + (#R;Success []) + (#R;Error (format "Value mismatch: " + (:: char;Codec<Text,Char> encode test) "=/=" (:: char;Codec<Text,Char> encode value)))) - (#;Left _) - (#;Left (format "Invalid format for char: " input))) + (#R;Error _) + (#R;Error (format "Invalid format for char: " input))) _ - (#;Left (format "JSON value is not a " "string" ": " (show-json json))))) + (#R;Error (format "JSON value is not a " "string" ": " (show-json json))))) (def: #export (nullable parser) {#;doc "A parser that can handle the presence of null values."} @@ -497,15 +497,15 @@ (function [json] (case json #Null - (#;Right #;None) + (#R;Success #;None) _ (case (parser json) - (#;Left error) - (#;Left error) + (#R;Error error) + (#R;Error error) - (#;Right value) - (#;Right (#;Some value))) + (#R;Success value) + (#R;Success (#;Some value))) ))) (def: #export (array parser) @@ -514,12 +514,12 @@ (function [json] (case json (#Array values) - (do Monad<Error> + (do Monad<Result> [elems (mapM @ parser (vector;to-list values))] (wrap elems)) _ - (#;Left (format "JSON value is not an array: " (show-json json)))))) + (#R;Error (format "JSON value is not an array: " (show-json json)))))) (def: #export (object parser) {#;doc "Parses a JSON object, assuming that every field's value can be parsed the same way."} @@ -527,7 +527,7 @@ (function [json] (case json (#Object fields) - (do Monad<Error> + (do Monad<Result> [kvs (mapM @ (function [[key val']] (do @ @@ -537,7 +537,7 @@ (wrap (dict;from-list text;Hash<Text> kvs))) _ - (#;Left (format "JSON value is not an object: " (show-json json)))))) + (#R;Error (format "JSON value is not an object: " (show-json json)))))) (def: #export (nth idx parser) {#;doc "Parses an element inside a JSON array."} @@ -548,17 +548,17 @@ (case (vector;nth idx values) (#;Some value) (case (parser value) - (#;Right output) - (#;Right output) + (#R;Success output) + (#R;Success output) - (#;Left error) - (#;Left (format "JSON array index [" (%n idx) "]: (" error ") @ " (show-json json)))) + (#R;Error error) + (#R;Error (format "JSON array index [" (%n idx) "]: (" error ") @ " (show-json json)))) #;None - (#;Left (format "JSON array does not have index " (%n idx) " @ " (show-json json)))) + (#R;Error (format "JSON array does not have index " (%n idx) " @ " (show-json json)))) _ - (#;Left (format "JSON value is not an array: " (show-json json)))))) + (#R;Error (format "JSON value is not an array: " (show-json json)))))) (def: #export (field field-name parser) {#;doc "Parses a field inside a JSON object."} @@ -567,20 +567,20 @@ (case (get field-name json) (#;Some value) (case (parser value) - (#;Right output) - (#;Right output) + (#R;Success output) + (#R;Success output) - (#;Left error) - (#;Left (format "Failed to get JSON object field " (show-string field-name) ": (" error ") @ " (show-json json)))) + (#R;Error error) + (#R;Error (format "Failed to get JSON object field " (show-string field-name) ": (" error ") @ " (show-json json)))) - (#;Left _) - (#;Left (format "JSON object does not have field " (show-string field-name) " @ " (show-json json)))))) + (#R;Error _) + (#R;Error (format "JSON object does not have field " (show-string field-name) " @ " (show-json json)))))) (def: #export any {#;doc "Just returns the JSON input without applying any logic."} (Parser JSON) (function [json] - (#;Right json))) + (#R;Success json))) (def: #export (seq pa pb) {#;doc "Sequencing combinator."} @@ -594,23 +594,23 @@ {#;doc "Heterogeneous alternative combinator."} (All [a b] (-> (Parser a) (Parser b) (Parser (| a b)))) (case (pa json) - (#;Right a) + (#R;Success a) (sum;right (sum;left a)) - (#;Left message0) + (#R;Error message0) (case (pb json) - (#;Right b) + (#R;Success b) (sum;right (sum;right b)) - (#;Left message1) - (#;Left message0)))) + (#R;Error message1) + (#R;Error message0)))) (def: #export (either pl pr json) {#;doc "Homogeneous alternative combinator."} (All [a] (-> (Parser a) (Parser a) (Parser a))) (case (pl json) - (#;Right x) - (#;Right x) + (#R;Success x) + (#R;Success x) _ (pr json))) @@ -620,22 +620,22 @@ (All [a] (-> (Parser a) (Parser (Maybe a)))) (case (p json) - (#;Left _) (#;Right #;None) - (#;Right x) (#;Right (#;Some x)))) + (#R;Error _) (#R;Success #;None) + (#R;Success x) (#R;Success (#;Some x)))) (def: #export (run json parser) - (All [a] (-> JSON (Parser a) (Error a))) + (All [a] (-> JSON (Parser a) (Result a))) (parser json)) (def: #export (ensure test parser json) {#;doc "Only parses a JSON if it passes a test (which is also a parser)."} (All [a] (-> (Parser Unit) (Parser a) (Parser a))) (case (test json) - (#;Right _) + (#R;Success _) (parser json) - (#;Left error) - (#;Left error))) + (#R;Error error) + (#R;Error error))) (def: #export (array-size! size json) {#;doc "Ensures a JSON array has the specified size."} @@ -643,11 +643,11 @@ (case json (#Array parts) (if (n.= size (vector;size parts)) - (#;Right []) - (#;Left (format "JSON array does no have size " (%n size) " " (show-json json)))) + (#R;Success []) + (#R;Error (format "JSON array does no have size " (%n size) " " (show-json json)))) _ - (#;Left (format "JSON value is not an array: " (show-json json))))) + (#R;Error (format "JSON value is not an array: " (show-json json))))) (def: #export (object-fields! wanted-fields json) {#;doc "Ensures that every field in the list of wanted-fields is present in a JSON object."} @@ -658,11 +658,11 @@ (if (and (n.= (list;size wanted-fields) (list;size actual-fields)) (list;every? (list;member? text;Eq<Text> wanted-fields) actual-fields)) - (#;Right []) - (#;Left (format "JSON object has wrong field-set. Expected: [" (text;join-with ", " wanted-fields) "]. Actual: [" (text;join-with ", " actual-fields) "]")))) + (#R;Success []) + (#R;Error (format "JSON object has wrong field-set. Expected: [" (text;join-with ", " wanted-fields) "]. Actual: [" (text;join-with ", " actual-fields) "]")))) _ - (#;Left (format "JSON value is not an object: " (show-json json))))) + (#R;Error (format "JSON value is not an object: " (show-json json))))) ## [Structures] (struct: #export _ (Eq JSON) @@ -924,7 +924,7 @@ (poly: #hidden (Codec<JSON,?>//decode *env* :x:) (let [->Codec//decode (: (-> Code Code) - (function [.type.] (` (-> JSON (Error (~ .type.))))))] + (function [.type.] (` (-> JSON (Result (~ .type.))))))] (with-expansions [<basic> (do-template [<type> <matcher> <decoder>] [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//decode (` <type>))) <decoder>))))] @@ -971,11 +971,11 @@ (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]] (wrap (` (: (~ :x:+) (function [(~@ g!vars) (~ g!input)] - (do Monad<Error> + (do Monad<Result> [(~ g!key) (;;fields (~ g!input))] (mapM (~ (' %)) (function [(~ g!key)] - (do Monad<Error> + (do Monad<Result> [(~ g!val) (;;get (~ g!key) (~ g!input)) (~ g!val) (;;run (~ g!val) (~ .val.))] ((~ (' wrap)) [(~ g!key) (~ g!val)]))) @@ -1043,7 +1043,7 @@ (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]] (wrap (` (: (~ :x:+) (function [(~@ g!vars) (~ g!input)] - (do Monad<Error> + (do Monad<Result> [(~@ (List/join extraction))] ((~ (' wrap)) (~ (code;record (List/map (function [[name :slot:]] [(code;tag name) (code;symbol ["" (product;right name)])]) diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux index 2494fa1b8..db68fbf29 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -7,7 +7,7 @@ text/format (text ["l" lexer "lex/" Monad<Lexer>]) [number] - error + ["R" result] [char "c/" Eq<Char>] [product] [maybe "m/" Monad<Maybe>] @@ -180,16 +180,16 @@ (l;after (l;opt xml-header^)))) (def: #export (read-xml input) - (-> Text (Error XML)) + (-> Text (R;Result XML)) (case (l;run' input xml^) - (#;Right ["" output]) - (#;Right output) + (#R;Success ["" output]) + (#R;Success output) (#;Some [input-left output]) - (#;Left (format "Unconsumed input: " (%t input-left))) + (#R;Error (format "Unconsumed input: " (%t input-left))) - (#;Left error) - (#;Left error))) + (#R;Error error) + (#R;Error error))) ## [Generation] (def: (sanitize-value input) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index cb98f5624..ad37a01ca 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -8,7 +8,7 @@ enum interval codec) - (data ["E" error]))) + (data ["R" result]))) (def: (clean-separators input) (-> Text Text) @@ -159,10 +159,10 @@ (def: (decode input) (case (_lux_proc <decoder> [input]) (#;Some value) - (#;Right value) + (#R;Success value) #;None - (#;Left <error>))))] + (#R;Error <error>))))] [Real ["real" "encode"] ["real" "decode"] "Could not decode Real"] ) @@ -214,16 +214,16 @@ (_lux_proc ["char" "to-text"] [digit]) +0]) #;None - (#;Left (_lux_proc ["text" "append"] [<error> repr])) + (#R;Error (_lux_proc ["text" "append"] [<error> repr])) (#;Some index) (recur (n.inc idx) (|> output (n.* <base>) (n.+ index))))) - (#;Right output)))) + (#R;Success output)))) _ - (#;Left (_lux_proc ["text" "append"] [<error> repr]))) - (#;Left (_lux_proc ["text" "append"] [<error> repr]))))))] + (#R;Error (_lux_proc ["text" "append"] [<error> repr]))) + (#R;Error (_lux_proc ["text" "append"] [<error> repr]))))))] [Binary@Codec<Text,Nat> +2 "01" "Invalid binary syntax for Nat: "] [Octal@Codec<Text,Nat> +8 "01234567" "Invalid octal syntax for Nat: "] @@ -271,13 +271,13 @@ (_lux_proc ["char" "to-text"] [digit]) +0]) #;None - (#;Left <error>) + (#R;Error <error>) (#;Some index) (recur (n.inc idx) (|> output (i.* <base>) (i.+ (:! Int index)))))) - (#;Right (i.* sign output))))) - (#;Left <error>)))))] + (#R;Success (i.* sign output))))) + (#R;Error <error>)))))] [Binary@Codec<Text,Int> 2 "01" "Invalid binary syntax for Int: "] [Octal@Codec<Text,Int> 8 "01234567" "Invalid octal syntax for Int: "] @@ -311,11 +311,11 @@ (^=> (#;Some #".") [(:: <nat> decode (_lux_proc ["text" "append"] ["+" (de-prefix repr)])) (#;Some output)]) - (#;Right (:! Deg output)) + (#R;Success (:! Deg output)) _ - (#;Left (_lux_proc ["text" "append"] [<error> repr]))) - (#;Left (_lux_proc ["text" "append"] [<error> repr]))))))] + (#R;Error (_lux_proc ["text" "append"] [<error> repr]))) + (#R;Error (_lux_proc ["text" "append"] [<error> repr]))))))] [Binary@Codec<Text,Deg> Binary@Codec<Text,Nat> +1 "Invalid binary syntax: "] [Octal@Codec<Text,Deg> Octal@Codec<Text,Nat> +3 "Invalid octal syntax: "] @@ -362,19 +362,19 @@ (r.* <base> output)))) adjusted-decimal (|> decimal int-to-real (r./ div-power)) dec-deg (case (:: Hex@Codec<Text,Deg> decode (_lux_proc ["text" "append"] ["." decimal-part])) - (#;Right dec-deg) + (#R;Success dec-deg) dec-deg - (#;Left error) + (#R;Error error) (error! error))] - (#;Right (r.+ (int-to-real whole) - (r.* sign adjusted-decimal)))) + (#R;Success (r.+ (int-to-real whole) + (r.* sign adjusted-decimal)))) _ - (#;Left (_lux_proc ["text" "append"] [<error> repr])))) + (#R;Error (_lux_proc ["text" "append"] [<error> repr])))) _ - (#;Left (_lux_proc ["text" "append"] [<error> repr])))))] + (#R;Error (_lux_proc ["text" "append"] [<error> repr])))))] [Binary@Codec<Text,Real> Binary@Codec<Text,Int> 2.0 "01" "Invalid binary syntax: "] ) @@ -552,14 +552,14 @@ [(if (r.= -1.0 sign) "-" "")] (_lux_proc ["text" "append"]))] (case (:: Binary@Codec<Text,Real> decode as-binary) - (#;Left _) - (#;Left (_lux_proc ["text" "append"] [<error> repr])) + (#R;Error _) + (#R;Error (_lux_proc ["text" "append"] [<error> repr])) output output)) _ - (#;Left (_lux_proc ["text" "append"] [<error> repr]))))))] + (#R;Error (_lux_proc ["text" "append"] [<error> repr]))))))] [Octal@Codec<Text,Real> "Invalid octaladecimal syntax: " binary-to-octal octal-to-binary] [Hex@Codec<Text,Real> "Invalid hexadecimal syntax: " binary-to-hex hex-to-binary] @@ -571,26 +571,26 @@ (case tokens (#;Cons [meta (#;Text repr)] #;Nil) (case (:: <nat> decode repr) - (#;Right value) - (#;Right [state (list [meta (#;Nat value)])]) + (#R;Success value) + (#R;Success [state (list [meta (#;Nat value)])]) - (^=> (#;Left _) - [(:: <int> decode repr) (#;Right value)]) - (#;Right [state (list [meta (#;Int value)])]) + (^=> (#R;Error _) + [(:: <int> decode repr) (#R;Success value)]) + (#R;Success [state (list [meta (#;Int value)])]) - (^=> (#;Left _) - [(:: <deg> decode repr) (#;Right value)]) - (#;Right [state (list [meta (#;Deg value)])]) + (^=> (#R;Error _) + [(:: <deg> decode repr) (#R;Success value)]) + (#R;Success [state (list [meta (#;Deg value)])]) - (^=> (#;Left _) - [(:: <real> decode repr) (#;Right value)]) - (#;Right [state (list [meta (#;Real value)])]) + (^=> (#R;Error _) + [(:: <real> decode repr) (#R;Success value)]) + (#R;Success [state (list [meta (#;Real value)])]) _ - (#;Left <error>)) + (#R;Error <error>)) _ - (#;Left <error>)))] + (#R;Error <error>)))] [bin Binary@Codec<Text,Nat> Binary@Codec<Text,Int> Binary@Codec<Text,Deg> Binary@Codec<Text,Real> "Invalid binary syntax." @@ -811,9 +811,9 @@ (recur (digits-sub! power digits) (n.inc idx) (bit-set (n.- idx (n.dec deg-bits)) output)))) - (#E;Success (:! Deg output)))) + (#R;Success (:! Deg output)))) #;None - (#E;Error (_lux_proc ["text" "append"] ["Wrong syntax for Deg: " input]))) - (#E;Error (_lux_proc ["text" "append"] ["Wrong syntax for Deg: " input])))) + (#R;Error (_lux_proc ["text" "append"] ["Wrong syntax for Deg: " input]))) + (#R;Error (_lux_proc ["text" "append"] ["Wrong syntax for Deg: " input])))) )) diff --git a/stdlib/source/lux/data/number/complex.lux b/stdlib/source/lux/data/number/complex.lux index 5f002e9df..94276e5f8 100644 --- a/stdlib/source/lux/data/number/complex.lux +++ b/stdlib/source/lux/data/number/complex.lux @@ -8,7 +8,7 @@ (data [number "r/" Number<Real> Codec<Text,Real>] [text "Text/" Monoid<Text>] text/format - error + ["R" result] maybe (coll [list "List/" Monad<List>])) [macro] @@ -322,7 +322,7 @@ (#;Left (Text/append "Wrong syntax for complex numbers: " input)) (#;Some [r' i']) - (do Monad<Error> + (do R;Monad<Result> [r (r/decode (text;trim r')) i (r/decode (text;trim i'))] (wrap {#real r diff --git a/stdlib/source/lux/data/number/ratio.lux b/stdlib/source/lux/data/number/ratio.lux index b5cc0e4b2..8497b3c5d 100644 --- a/stdlib/source/lux/data/number/ratio.lux +++ b/stdlib/source/lux/data/number/ratio.lux @@ -9,7 +9,7 @@ (data [number "n/" Number<Nat> Codec<Text,Nat>] [text "Text/" Monoid<Text>] text/format - error + ["R" result] [product]) [macro] (macro [code] @@ -129,7 +129,7 @@ (|>. n/encode (text;split +1) (default (undefined)) product;right)) (def: part-decode - (-> Text (Error Nat)) + (-> Text (R;Result Nat)) (|>. (format "+") n/decode)) (struct: #export _ (Codec Text Ratio) @@ -139,7 +139,7 @@ (def: (decode input) (case (text;split-with separator input) (#;Some [num denom]) - (do Monad<Error> + (do R;Monad<Result> [numerator (part-decode num) denominator (part-decode denom)] (wrap (normalize {#numerator numerator diff --git a/stdlib/source/lux/data/error.lux b/stdlib/source/lux/data/result.lux index f614305e0..3a713a174 100644 --- a/stdlib/source/lux/data/error.lux +++ b/stdlib/source/lux/data/result.lux @@ -5,19 +5,19 @@ ["M" monad #*]))) ## [Types] -(type: #export (Error a) +(type: #export (Result a) (#Error Text) (#Success a)) ## [Structures] -(struct: #export _ (Functor Error) +(struct: #export _ (Functor Result) (def: (map f ma) (case ma - (#Error msg) (#Error msg) + (#Error msg) (#Error msg) (#Success datum) (#Success (f datum))))) -(struct: #export _ (Applicative Error) - (def: functor Functor<Error>) +(struct: #export _ (Applicative Result) + (def: functor Functor<Result>) (def: (wrap a) (#Success a)) @@ -36,17 +36,17 @@ (#Error msg)) )) -(struct: #export _ (Monad Error) - (def: applicative Applicative<Error>) +(struct: #export _ (Monad Result) + (def: applicative Applicative<Result>) (def: (join mma) (case mma (#Error msg) (#Error msg) (#Success ma) ma))) -(struct: #export (ErrorT Monad<M>) - (All [M] (-> (Monad M) (Monad (All [a] (M (Error a)))))) - (def: applicative (compA (get@ #M;applicative Monad<M>) Applicative<Error>)) +(struct: #export (ResultT Monad<M>) + (All [M] (-> (Monad M) (Monad (All [a] (M (Result a)))))) + (def: applicative (compA (get@ #M;applicative Monad<M>) Applicative<Result>)) (def: (join MeMea) (do Monad<M> [eMea MeMea] @@ -57,14 +57,14 @@ (#Success Mea) Mea)))) -(def: #export (lift-error Monad<M>) - (All [M a] (-> (Monad M) (-> (M a) (M (Error a))))) - (liftM Monad<M> (:: Monad<Error> wrap))) +(def: #export (lift-result Monad<M>) + (All [M a] (-> (Monad M) (-> (M a) (M (Result a))))) + (liftM Monad<M> (:: Monad<Result> wrap))) (def: #export (succeed value) - (All [a] (-> a (Error a))) + (All [a] (-> a (Result a))) (#Success value)) (def: #export (fail message) - (All [a] (-> Text (Error a))) + (All [a] (-> Text (Result a))) (#Error message)) diff --git a/stdlib/source/lux/data/text/lexer.lux b/stdlib/source/lux/data/text/lexer.lux index 34614c545..58e636b53 100644 --- a/stdlib/source/lux/data/text/lexer.lux +++ b/stdlib/source/lux/data/text/lexer.lux @@ -9,41 +9,41 @@ [product] [char "Char/" Order<Char>] maybe - ["E" error #- fail] + ["R" result] (coll [list "" Functor<List>])))) ## [Types] (type: #export (Lexer a) - (-> Text (Error [Text a]))) + (-> Text (R;Result [Text a]))) ## [Structures] (struct: #export _ (Functor Lexer) (def: (map f fa) (function [input] (case (fa input) - (#E;Error msg) (#E;Error msg) - (#E;Success [input' output]) (#E;Success [input' (f output)]))))) + (#R;Error msg) (#R;Error msg) + (#R;Success [input' output]) (#R;Success [input' (f output)]))))) (struct: #export _ (Applicative Lexer) (def: functor Functor<Lexer>) (def: (wrap a) (function [input] - (#E;Success [input a]))) + (#R;Success [input a]))) (def: (apply ff fa) (function [input] (case (ff input) - (#E;Success [input' f]) + (#R;Success [input' f]) (case (fa input') - (#E;Success [input'' a]) - (#E;Success [input'' (f a)]) + (#R;Success [input'' a]) + (#R;Success [input'' (f a)]) - (#E;Error msg) - (#E;Error msg)) + (#R;Error msg) + (#R;Error msg)) - (#E;Error msg) - (#E;Error msg))))) + (#R;Error msg) + (#R;Error msg))))) (struct: #export _ (Monad Lexer) (def: applicative Applicative<Lexer>) @@ -51,31 +51,31 @@ (def: (join mma) (function [input] (case (mma input) - (#E;Error msg) (#E;Error msg) - (#E;Success [input' ma]) (ma input')))) + (#R;Error msg) (#R;Error msg) + (#R;Success [input' ma]) (ma input')))) ) ## [Values] ## Runner (def: #export (run' input lexer) - (All [a] (-> Text (Lexer a) (Error [Text a]))) + (All [a] (-> Text (Lexer a) (R;Result [Text a]))) (lexer input)) (def: #export (run input lexer) - (All [a] (-> Text (Lexer a) (Error a))) + (All [a] (-> Text (Lexer a) (R;Result a))) (case (lexer input) - (#E;Error msg) - (#E;Error msg) + (#R;Error msg) + (#R;Error msg) - (#E;Success [input' output]) - (#E;Success output) + (#R;Success [input' output]) + (#R;Success output) )) ## Combinators (def: #export (fail message) (All [a] (-> Text (Lexer a))) (function [input] - (#E;Error message))) + (#R;Error message))) (def: #export any {#;doc "Just returns the next character without applying any logic."} @@ -83,10 +83,10 @@ (function [input] (case [(text;nth +0 input) (text;split +1 input)] [(#;Some output) (#;Some [_ input'])] - (#E;Success [input' output]) + (#R;Success [input' output]) _ - (#E;Error "Cannot parse character from empty text.")) + (#R;Error "Cannot parse character from empty text.")) )) (def: #export (seq left right) @@ -102,45 +102,45 @@ (All [a b] (-> (Lexer a) (Lexer b) (Lexer (| a b)))) (function [input] (case (left input) - (#E;Error msg) + (#R;Error msg) (case (right input) - (#E;Error msg) - (#E;Error msg) + (#R;Error msg) + (#R;Error msg) - (#E;Success [input' output]) - (#E;Success [input' (+1 output)])) + (#R;Success [input' output]) + (#R;Success [input' (+1 output)])) - (#E;Success [input' output]) - (#E;Success [input' (+0 output)])))) + (#R;Success [input' output]) + (#R;Success [input' (+0 output)])))) (def: #export (not! p) {#;doc "Ensure a lexer fails."} (All [a] (-> (Lexer a) (Lexer Unit))) (function [input] (case (p input) - (#E;Error msg) - (#E;Success [input []]) + (#R;Error msg) + (#R;Success [input []]) _ - (#E;Error "Expected to fail; yet succeeded.")))) + (#R;Error "Expected to fail; yet succeeded.")))) (def: #export (not p) {#;doc "Produce a character if the lexer fails."} (All [a] (-> (Lexer a) (Lexer Char))) (function [input] (case (p input) - (#E;Error msg) + (#R;Error msg) (any input) _ - (#E;Error "Expected to fail; yet succeeded.")))) + (#R;Error "Expected to fail; yet succeeded.")))) (def: #export (either left right) {#;doc "Homogeneous alternative combinator."} (All [a] (-> (Lexer a) (Lexer a) (Lexer a))) (function [input] (case (left input) - (#E;Error msg) + (#R;Error msg) (right input) output @@ -151,18 +151,18 @@ (-> Text Bool (Lexer Unit)) (function [input] (if test - (#E;Success [input []]) - (#E;Error message)))) + (#R;Success [input []]) + (#R;Error message)))) (def: #export (some p) {#;doc "0-or-more combinator."} (All [a] (-> (Lexer a) (Lexer (List a)))) (function [input] (case (p input) - (#E;Error msg) - (#E;Success [input (list)]) + (#R;Error msg) + (#R;Success [input (list)]) - (#E;Success [input' x]) + (#R;Success [input' x]) (run' input' (do Monad<Lexer> [xs (some p)] @@ -193,10 +193,10 @@ (if (n.> +0 n) (function [input] (case (p input) - (#E;Error msg) - (#E;Success [input (list)]) + (#R;Error msg) + (#R;Success [input (list)]) - (#E;Success [input' x]) + (#R;Success [input' x]) (run' input' (do Monad<Lexer> [xs (at-most (n.dec n) p)] @@ -225,11 +225,11 @@ (All [a] (-> (Lexer a) (Lexer (Maybe a)))) (function [input] (case (p input) - (#E;Error msg) - (#E;Success [input #;None]) + (#R;Error msg) + (#R;Success [input #;None]) - (#E;Success [input value]) - (#E;Success [input (#;Some value)]) + (#R;Success [input value]) + (#R;Success [input (#;Some value)]) ))) (def: #export (text test) @@ -238,10 +238,10 @@ (function [input] (if (text;starts-with? test input) (case (text;split (text;size test) input) - #;None (#E;Error "") - (#;Some [_ input']) (#E;Success [input' test])) + #;None (#R;Error "") + (#;Some [_ input']) (#R;Success [input' test])) (let [(^open "T/") text;Codec<Text,Text>] - (#E;Error ($_ Text/append "Invalid match: " (T/encode test) " @ " (T/encode input))))) + (#R;Error ($_ Text/append "Invalid match: " (T/encode test) " @ " (T/encode input))))) )) (def: #export (sep-by sep lexer) @@ -264,8 +264,8 @@ (Lexer Unit) (function [input] (case input - "" (#E;Success [input []]) - _ (#E;Error ($_ Text/append "The text input has not been fully consumed @ " (:: text;Codec<Text,Text> encode input))) + "" (#R;Success [input []]) + _ (#R;Error ($_ Text/append "The text input has not been fully consumed @ " (:: text;Codec<Text,Text> encode input))) ))) (def: #export peek @@ -274,10 +274,10 @@ (function [input] (case (text;nth +0 input) (#;Some output) - (#E;Success [input output]) + (#R;Success [input output]) _ - (#E;Error "Cannot peek character from empty text.")) + (#R;Error "Cannot peek character from empty text.")) )) (def: #export (char test) @@ -287,18 +287,18 @@ (case [(text;nth +0 input) (text;split +1 input)] [(#;Some char') (#;Some [_ input'])] (if (Char/= test char') - (#E;Success [input' test]) - (#E;Error ($_ Text/append "Expected " (:: char;Codec<Text,Char> encode test) " @ " (:: text;Codec<Text,Text> encode input)))) + (#R;Success [input' test]) + (#R;Error ($_ Text/append "Expected " (:: char;Codec<Text,Char> encode test) " @ " (:: text;Codec<Text,Text> encode input)))) _ - (#E;Error "Cannot parse character from empty text.")) + (#R;Error "Cannot parse character from empty text.")) )) (def: #export get-input {#;doc "Get all of the remaining input (without consuming it)."} (Lexer Text) (function [input] - (#E;Success [input input]))) + (#R;Success [input input]))) (def: #export (char-range bottom top) {#;doc "Only lex characters within a range."} @@ -350,14 +350,14 @@ (if (text;contains? init options) (case (text;nth +0 init) (#;Some output) - (#E;Success [input' output]) + (#R;Success [input' output]) _ - (#E;Error "")) - (#E;Error ($_ Text/append "Character (" init ") is not one of: " options " @ " (:: text;Codec<Text,Text> encode input)))) + (#R;Error "")) + (#R;Error ($_ Text/append "Character (" init ") is not one of: " options " @ " (:: text;Codec<Text,Text> encode input)))) _ - (#E;Error "Cannot parse character from empty text.")))) + (#R;Error "Cannot parse character from empty text.")))) (def: #export (none-of options) {#;doc "Only lex characters that are not part of a piece of text."} @@ -368,14 +368,14 @@ (if (;not (text;contains? init options)) (case (text;nth +0 init) (#;Some output) - (#E;Success [input' output]) + (#R;Success [input' output]) _ - (#E;Error "")) - (#E;Error ($_ Text/append "Character (" init ") is one of: " options " @ " (:: text;Codec<Text,Text> encode input)))) + (#R;Error "")) + (#R;Error ($_ Text/append "Character (" init ") is one of: " options " @ " (:: text;Codec<Text,Text> encode input)))) _ - (#E;Error "Cannot parse character from empty text.")))) + (#R;Error "Cannot parse character from empty text.")))) (def: #export (satisfies p) {#;doc "Only lex characters that satisfy a predicate."} @@ -388,11 +388,11 @@ (wrap [input' output]))) (#;Some [input' output]) (if (p output) - (#E;Success [input' output]) - (#E;Error ($_ Text/append "Character does not satisfy predicate: " (:: text;Codec<Text,Text> encode input)))) + (#R;Success [input' output]) + (#R;Error ($_ Text/append "Character does not satisfy predicate: " (:: text;Codec<Text,Text> encode input)))) _ - (#E;Error "Cannot parse character from empty text.")))) + (#R;Error "Cannot parse character from empty text.")))) (def: #export space {#;doc "Only lex white-space."} @@ -445,7 +445,7 @@ {#;doc "Ask if the lexer's input is empty."} (Lexer Bool) (function [input] - (#E;Success [input (text;empty? input)]))) + (#R;Success [input (text;empty? input)]))) (def: #export (after param subject) (All [p s] (-> (Lexer p) (Lexer s) (Lexer s))) @@ -465,27 +465,27 @@ (All [a] (-> a (Lexer a) (Lexer a))) (function [input] (case (lexer input) - (#E;Error error) - (#E;Success [input value]) + (#R;Error error) + (#R;Success [input value]) - (#E;Success input'+value) - (#E;Success input'+value)))) + (#R;Success input'+value) + (#R;Success input'+value)))) (def: #export (codec codec lexer) {#;doc "Lex a token by means of a codec."} (All [a] (-> (Codec Text a) (Lexer Text) (Lexer a))) (function [input] (case (lexer input) - (#E;Error error) - (#E;Error error) + (#R;Error error) + (#R;Error error) - (#E;Success [input' to-decode]) + (#R;Success [input' to-decode]) (case (:: codec decode to-decode) - (#E;Error error) - (#E;Error error) + (#R;Error error) + (#R;Error error) - (#E;Success value) - (#E;Success [input' value]))))) + (#R;Success value) + (#R;Success [input' value]))))) (def: #export (enclosed [start end] lexer) (All [a] (-> [Text Text] (Lexer a) (Lexer a))) @@ -504,13 +504,13 @@ (All [a] (-> Text (Lexer a) (Lexer a))) (function [real-input] (case (run' local-input lexer) - (#E;Error error) - (#E;Error error) + (#R;Error error) + (#R;Error error) - (#E;Success [unconsumed value]) + (#R;Success [unconsumed value]) (if (Text/= "" unconsumed) - (#E;Success [real-input value]) - (#E;Error ($_ Text/append "Unconsumed input: " unconsumed)))))) + (#R;Success [real-input value]) + (#R;Error ($_ Text/append "Unconsumed input: " unconsumed)))))) (def: #export (seq' left right) (-> (Lexer Text) (Lexer Text) (Lexer Text)) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index 5ff8b5073..75ba9d587 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -10,41 +10,41 @@ [product] [ident "Ident/" Codec<Text,Ident>] maybe - ["E" error #- fail]))) + ["R" result]))) ## (type: (Lux a) -## (-> Compiler (Error [Compiler a]))) +## (-> Compiler (R;Result [Compiler a]))) (struct: #export _ (Functor Lux) (def: (map f fa) (function [state] (case (fa state) - (#;Left msg) - (#;Left msg) + (#R;Error msg) + (#R;Error msg) - (#;Right [state' a]) - (#;Right [state' (f a)]))))) + (#R;Success [state' a]) + (#R;Success [state' (f a)]))))) (struct: #export _ (Applicative Lux) (def: functor Functor<Lux>) (def: (wrap x) (function [state] - (#;Right [state x]))) + (#R;Success [state x]))) (def: (apply ff fa) (function [state] (case (ff state) - (#;Right [state' f]) + (#R;Success [state' f]) (case (fa state') - (#;Right [state'' a]) - (#;Right [state'' (f a)]) + (#R;Success [state'' a]) + (#R;Success [state'' (f a)]) - (#;Left msg) - (#;Left msg)) + (#R;Error msg) + (#R;Error msg)) - (#;Left msg) - (#;Left msg))))) + (#R;Error msg) + (#R;Error msg))))) (struct: #export _ (Monad Lux) (def: applicative Applicative<Lux>) @@ -52,10 +52,10 @@ (def: (join mma) (function [state] (case (mma state) - (#;Left msg) - (#;Left msg) + (#R;Error msg) + (#R;Error msg) - (#;Right [state' ma]) + (#R;Success [state' ma]) (ma state'))))) (def: (get k plist) @@ -71,53 +71,53 @@ (get k plist')))) (def: #export (run' compiler action) - (All [a] (-> Compiler (Lux a) (Error [Compiler a]))) + (All [a] (-> Compiler (Lux a) (R;Result [Compiler a]))) (action compiler)) (def: #export (run compiler action) - (All [a] (-> Compiler (Lux a) (Error a))) + (All [a] (-> Compiler (Lux a) (R;Result a))) (case (action compiler) - (#;Left error) - (#;Left error) + (#R;Error error) + (#R;Error error) - (#;Right [_ output]) - (#;Right output))) + (#R;Success [_ output]) + (#R;Success output))) (def: #export (either left right) {#;doc "Pick whichever computation succeeds."} (All [a] (-> (Lux a) (Lux a) (Lux a))) (function [compiler] (case (left compiler) - (#;Left error) + (#R;Error error) (right compiler) - (#;Right [compiler' output]) - (#;Right [compiler' output])))) + (#R;Success [compiler' output]) + (#R;Success [compiler' output])))) (def: #export (assert message test) {#;doc "Fails with the given message if the test is false."} (-> Text Bool (Lux Unit)) (function [compiler] (if test - (#;Right [compiler []]) - (#;Left message)))) + (#R;Success [compiler []]) + (#R;Error message)))) (def: #export (fail msg) {#;doc "Fails with the given message."} (All [a] (-> Text (Lux a))) (function [_] - (#;Left msg))) + (#R;Error msg))) (def: #export (find-module name) (-> Text (Lux Module)) (function [state] (case (get name (get@ #;modules state)) (#;Some module) - (#;Right [state module]) + (#R;Success [state module]) _ - (#;Left ($_ Text/append "Unknown module: " name))))) + (#R;Error ($_ Text/append "Unknown module: " name))))) (def: #export current-module-name (Lux Text) @@ -126,13 +126,13 @@ (#;Some scope) (case (get@ #;name scope) (#;Cons m-name #;Nil) - (#;Right [state m-name]) + (#R;Success [state m-name]) _ - (#;Left "Improper name for scope.")) + (#R;Error "Improper name for scope.")) _ - (#;Left "Empty environment!") + (#R;Error "Empty environment!") ))) (def: #export current-module @@ -256,7 +256,7 @@ (let [[module name] ident] (: (Lux (Maybe Macro)) (function [state] - (#;Right [state (find-macro' (get@ #;modules state) this-module module name)])))))) + (#R;Success [state (find-macro' (get@ #;modules state) this-module module name)])))))) (def: #export (normalize ident) {#;doc "If given an identifier without a module prefix, gives it the current module's name as prefix. @@ -355,8 +355,8 @@ A prefix can be given (or just be empty text \"\") to better identify the code for debugging purposes."} (-> Text (Lux Code)) (function [state] - (#;Right [(update@ #;seed n.inc state) - (code;symbol ["" ($_ Text/append "__gensym__" prefix (:: number;Codec<Text,Nat> encode (get@ #;seed state)))])]))) + (#R;Success [(update@ #;seed n.inc state) + (code;symbol ["" ($_ Text/append "__gensym__" prefix (:: number;Codec<Text,Nat> encode (get@ #;seed state)))])]))) (def: (get-local-symbol ast) (-> Code (Lux Text)) @@ -406,12 +406,12 @@ (def: #export (module-exists? module) (-> Text (Lux Bool)) (function [state] - (#;Right [state (case (get module (get@ #;modules state)) - (#;Some _) - true - - #;None - false)]))) + (#R;Success [state (case (get module (get@ #;modules state)) + (#;Some _) + true + + #;None + false)]))) (def: (try-both f x1 x2) (All [a b] @@ -440,10 +440,10 @@ (get@ [#;captured #;mappings] scope)))] (wrap type)) (#;Some var-type) - (#;Right [state var-type]) + (#R;Success [state var-type]) #;None - (#;Left ($_ Text/append "Unknown variable: " name)))))) + (#R;Error ($_ Text/append "Unknown variable: " name)))))) (def: #export (find-def name) {#;doc "Looks-up a definition's whole data in the available modules (including the current one)."} @@ -455,10 +455,10 @@ (^slots [#;defs]) (get v-prefix (get@ #;modules state))] (get v-name defs))) (#;Some _anns) - (#;Right [state _anns]) + (#R;Success [state _anns]) _ - (#;Left ($_ Text/append "Unknown definition: " (Ident/encode name)))))) + (#R;Error ($_ Text/append "Unknown definition: " (Ident/encode name)))))) (def: #export (find-def-type name) {#;doc "Looks-up a definition's type in the available modules (including the current one)."} @@ -489,8 +489,8 @@ (-> Text (Lux (List [Text Def]))) (function [state] (case (get module-name (get@ #;modules state)) - #;None (#;Left ($_ Text/append "Unknown module: " module-name)) - (#;Some module) (#;Right [state (get@ #;defs module)]) + #;None (#R;Error ($_ Text/append "Unknown module: " module-name)) + (#;Some module) (#R;Success [state (get@ #;defs module)]) ))) (def: #export (exports module-name) @@ -510,7 +510,7 @@ (|> state (get@ #;modules) [state] - #;Right))) + #R;Success))) (def: #export (tags-of type-name) {#;doc "All the tags associated with a type definition."} @@ -529,7 +529,7 @@ {#;doc "The cursor of the current expression being analyzed."} (Lux Cursor) (function [state] - (#;Right [state (get@ #;cursor state)]))) + (#R;Success [state (get@ #;cursor state)]))) (def: #export expected-type {#;doc "The expected type of the current expression being analyzed."} @@ -537,10 +537,10 @@ (function [state] (case (get@ #;expected state) (#;Some type) - (#;Right [state type]) + (#R;Success [state type]) #;None - (#;Left "Not expecting any type.")))) + (#R;Error "Not expecting any type.")))) (def: #export (imported-modules module-name) {#;doc "All the modules imported by a specified module."} @@ -585,14 +585,14 @@ (function [state] (case (list;inits (get@ #;scopes state)) #;None - (#;Left "No local environment") + (#R;Error "No local environment") (#;Some scopes) - (#;Right [state - (List/map (|>. (get@ [#;locals #;mappings]) - (List/map (function [[name [type _]]] - [name type]))) - scopes)])))) + (#R;Success [state + (List/map (|>. (get@ [#;locals #;mappings]) + (List/map (function [[name [type _]]] + [name type]))) + scopes)])))) (def: #export (un-alias def-name) {#;doc "Given an aliased definition's name, returns the original definition being referenced."} @@ -611,12 +611,12 @@ {#;doc "Obtains the current state of the compiler."} (Lux Compiler) (function [compiler] - (#;Right [compiler compiler]))) + (#R;Success [compiler compiler]))) (def: #export type-context (Lux Type-Context) (function [compiler] - (#;Right [compiler (get@ #;type-context compiler)]))) + (#R;Success [compiler (get@ #;type-context compiler)]))) (do-template [<macro> <func> <desc>] [(macro: #export (<macro> tokens) diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux index 06ebe60e4..136080fa7 100644 --- a/stdlib/source/lux/macro/poly/functor.lux +++ b/stdlib/source/lux/macro/poly/functor.lux @@ -11,8 +11,7 @@ [bool] [char] [maybe] - [ident "Ident/" Codec<Text,Ident>] - error) + [ident "Ident/" Codec<Text,Ident>]) [macro #+ Monad<Lux> with-gensyms] (macro [code] [syntax #+ syntax: Syntax] diff --git a/stdlib/source/lux/macro/poly/text-encoder.lux b/stdlib/source/lux/macro/poly/text-encoder.lux index 2dde16640..e1250c9e7 100644 --- a/stdlib/source/lux/macro/poly/text-encoder.lux +++ b/stdlib/source/lux/macro/poly/text-encoder.lux @@ -11,8 +11,7 @@ [bool] [char] [maybe] - [ident "Ident/" Codec<Text,Ident>] - error) + [ident "Ident/" Codec<Text,Ident>]) [macro #+ Monad<Lux> with-gensyms] (macro [code] [syntax #+ syntax: Syntax] diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux index c0fda8a62..53ec26009 100644 --- a/stdlib/source/lux/macro/syntax.lux +++ b/stdlib/source/lux/macro/syntax.lux @@ -12,7 +12,7 @@ [ident] (coll [list #* "" Functor<List> Fold<List> "List/" Monoid<List>]) [product] - [error #- fail])) + ["R" result])) (.. [code "Code/" Eq<Code>])) ## [Utils] @@ -25,38 +25,38 @@ ## [Types] (type: #export (Syntax a) {#;doc "A Lux syntax parser."} - (-> (List Code) (Error [(List Code) a]))) + (-> (List Code) (R;Result [(List Code) a]))) ## [Structures] (struct: #export _ (Functor Syntax) (def: (map f ma) (function [tokens] (case (ma tokens) - (#;Left msg) - (#;Left msg) + (#R;Error msg) + (#R;Error msg) - (#;Right [tokens' a]) - (#;Right [tokens' (f a)]))))) + (#R;Success [tokens' a]) + (#R;Success [tokens' (f a)]))))) (struct: #export _ (Applicative Syntax) (def: functor Functor<Syntax>) (def: (wrap x tokens) - (#;Right [tokens x])) + (#R;Success [tokens x])) (def: (apply ff fa) (function [tokens] (case (ff tokens) - (#;Right [tokens' f]) + (#R;Success [tokens' f]) (case (fa tokens') - (#;Right [tokens'' a]) - (#;Right [tokens'' (f a)]) + (#R;Success [tokens'' a]) + (#R;Success [tokens'' (f a)]) - (#;Left msg) - (#;Left msg)) + (#R;Error msg) + (#R;Error msg)) - (#;Left msg) - (#;Left msg))))) + (#R;Error msg) + (#R;Error msg))))) (struct: #export _ (Monad Syntax) (def: applicative Applicative<Syntax>) @@ -64,10 +64,10 @@ (def: (join mma) (function [tokens] (case (mma tokens) - (#;Left msg) - (#;Left msg) + (#R;Error msg) + (#R;Error msg) - (#;Right [tokens' ma]) + (#R;Success [tokens' ma]) (ma tokens'))))) ## [Utils] @@ -82,8 +82,8 @@ (Syntax Code) (function [tokens] (case tokens - #;Nil (#;Left "There are no tokens to parse!") - (#;Cons [t tokens']) (#;Right [tokens' t])))) + #;Nil (#R;Error "There are no tokens to parse!") + (#;Cons [t tokens']) (#R;Success [tokens' t])))) (do-template [<get-name> <type> <tag> <eq> <desc>] [(def: #export <get-name> @@ -92,10 +92,10 @@ (function [tokens] (case tokens (#;Cons [[_ (<tag> x)] tokens']) - (#;Right [tokens' x]) + (#R;Success [tokens' x]) _ - (#;Left ($_ Text/append "Cannot parse " <desc> (remaining-inputs tokens))))))] + (#R;Error ($_ Text/append "Cannot parse " <desc> (remaining-inputs tokens))))))] [ bool Bool #;Bool bool;Eq<Bool> "bool"] [ nat Nat #;Nat number;Eq<Nat> "nat"] @@ -118,10 +118,10 @@ remaining (if is-it? tokens' tokens)] - (#;Right [remaining is-it?])) + (#R;Success [remaining is-it?])) _ - (#;Right [tokens false])))) + (#R;Success [tokens false])))) (def: #export (this! ast) {#;doc "Ensures the given Code is the next input."} @@ -130,20 +130,20 @@ (case tokens (#;Cons [token tokens']) (if (Code/= ast token) - (#;Right [tokens' []]) - (#;Left ($_ Text/append "Expected a " (code;to-text ast) " but instead got " (code;to-text token) - (remaining-inputs tokens)))) + (#R;Success [tokens' []]) + (#R;Error ($_ Text/append "Expected a " (code;to-text ast) " but instead got " (code;to-text token) + (remaining-inputs tokens)))) _ - (#;Left "There are no tokens to parse!")))) + (#R;Error "There are no tokens to parse!")))) (def: #export (assert message test) {#;doc "Fails with the given message if the test is false."} (-> Text Bool (Syntax Unit)) (function [tokens] (if test - (#;Right [tokens []]) - (#;Left ($_ Text/append message (remaining-inputs tokens)))))) + (#R;Success [tokens []]) + (#R;Error ($_ Text/append message (remaining-inputs tokens)))))) (do-template [<name> <comp> <error>] [(def: #export <name> @@ -164,10 +164,10 @@ (function [tokens] (case tokens (#;Cons [[_ (<tag> ["" x])] tokens']) - (#;Right [tokens' x]) + (#R;Success [tokens' x]) _ - (#;Left ($_ Text/append "Cannot parse local " <desc> (remaining-inputs tokens))))))] + (#R;Error ($_ Text/append "Cannot parse local " <desc> (remaining-inputs tokens))))))] [local-symbol #;Symbol "symbol"] [ local-tag #;Tag "tag"] @@ -182,11 +182,11 @@ (case tokens (#;Cons [[_ (<tag> members)] tokens']) (case (p members) - (#;Right [#;Nil x]) (#;Right [tokens' x]) - _ (#;Left ($_ Text/append "Syntax was expected to fully consume " <desc> (remaining-inputs tokens)))) + (#R;Success [#;Nil x]) (#R;Success [tokens' x]) + _ (#R;Error ($_ Text/append "Syntax was expected to fully consume " <desc> (remaining-inputs tokens)))) _ - (#;Left ($_ Text/append "Cannot parse " <desc> (remaining-inputs tokens))))))] + (#R;Error ($_ Text/append "Cannot parse " <desc> (remaining-inputs tokens))))))] [ form #;Form "form"] [tuple #;Tuple "tuple"] @@ -200,11 +200,11 @@ (case tokens (#;Cons [[_ (#;Record pairs)] tokens']) (case (p (join-pairs pairs)) - (#;Right [#;Nil x]) (#;Right [tokens' x]) - _ (#;Left ($_ Text/append "Syntax was expected to fully consume record" (remaining-inputs tokens)))) + (#R;Success [#;Nil x]) (#R;Success [tokens' x]) + _ (#R;Error ($_ Text/append "Syntax was expected to fully consume record" (remaining-inputs tokens)))) _ - (#;Left ($_ Text/append "Cannot parse record" (remaining-inputs tokens)))))) + (#R;Error ($_ Text/append "Cannot parse record" (remaining-inputs tokens)))))) (def: #export (opt p) {#;doc "Optionality combinator."} @@ -212,12 +212,12 @@ (-> (Syntax a) (Syntax (Maybe a)))) (function [tokens] (case (p tokens) - (#;Left _) (#;Right [tokens #;None]) - (#;Right [tokens' x]) (#;Right [tokens' (#;Some x)])))) + (#R;Error _) (#R;Success [tokens #;None]) + (#R;Success [tokens' x]) (#R;Success [tokens' (#;Some x)])))) (def: #export (run tokens p) (All [a] - (-> (List Code) (Syntax a) (Error [(List Code) a]))) + (-> (List Code) (Syntax a) (R;Result [(List Code) a]))) (p tokens)) (def: #export (some p) @@ -226,12 +226,12 @@ (-> (Syntax a) (Syntax (List a)))) (function [tokens] (case (p tokens) - (#;Left _) (#;Right [tokens (list)]) - (#;Right [tokens' x]) (run tokens' - (do Monad<Syntax> - [xs (some p)] - (wrap (list& x xs))) - )))) + (#R;Error _) (#R;Success [tokens (list)]) + (#R;Success [tokens' x]) (run tokens' + (do Monad<Syntax> + [xs (some p)] + (wrap (list& x xs))) + )))) (def: #export (many p) {#;doc "1-or-more combinator."} @@ -257,11 +257,11 @@ (-> (Syntax a) (Syntax b) (Syntax (| a b)))) (function [tokens] (case (p1 tokens) - (#;Right [tokens' x1]) (#;Right [tokens' (+0 x1)]) - (#;Left _) (run tokens - (do Monad<Syntax> - [x2 p2] - (wrap (+1 x2)))) + (#R;Success [tokens' x1]) (#R;Success [tokens' (+0 x1)]) + (#R;Error _) (run tokens + (do Monad<Syntax> + [x2 p2] + (wrap (+1 x2)))) ))) (def: #export (either pl pr) @@ -270,7 +270,7 @@ (-> (Syntax a) (Syntax a) (Syntax a))) (function [tokens] (case (pl tokens) - (#;Left _) (pr tokens) + (#R;Error _) (pr tokens) output output ))) @@ -279,16 +279,16 @@ (Syntax Unit) (function [tokens] (case tokens - #;Nil (#;Right [tokens []]) - _ (#;Left ($_ Text/append "Expected list of tokens to be empty!" (remaining-inputs tokens)))))) + #;Nil (#R;Success [tokens []]) + _ (#R;Error ($_ Text/append "Expected list of tokens to be empty!" (remaining-inputs tokens)))))) (def: #export end? {#;doc "Checks whether there are no more inputs."} (Syntax Bool) (function [tokens] (case tokens - #;Nil (#;Right [tokens true]) - _ (#;Right [tokens false])))) + #;Nil (#R;Success [tokens true]) + _ (#R;Success [tokens false])))) (def: #export (exactly n p) {#;doc "Parse exactly N times."} @@ -314,10 +314,10 @@ (if (n.> +0 n) (function [input] (case (p input) - (#;Left msg) - (#;Right [input (list)]) + (#R;Error msg) + (#R;Success [input (list)]) - (#;Right [input' x]) + (#R;Success [input' x]) (run input' (do Monad<Syntax> [xs (at-most (n.dec n) p)] @@ -352,38 +352,38 @@ (All [a] (-> (Syntax a) (Syntax Unit))) (function [input] (case (p input) - (#;Left msg) - (#;Right [input []]) + (#R;Error msg) + (#R;Success [input []]) _ - (#;Left "Expected to fail; yet succeeded.")))) + (#R;Error "Expected to fail; yet succeeded.")))) (def: #export (fail message) (All [a] (-> Text (Syntax a))) (function [input] - (#;Left message))) + (#R;Error message))) (def: #export (default value parser) {#;doc "If the given parser fails, returns the default value."} (All [a] (-> a (Syntax a) (Syntax a))) (function [input] (case (parser input) - (#;Left error) - (#;Right [input value]) + (#R;Error error) + (#R;Success [input value]) - (#;Right [input' output]) - (#;Right [input' output])))) + (#R;Success [input' output]) + (#R;Success [input' output])))) (def: #export (on compiler action) {#;doc "Run a Lux operation as if it was a Syntax parser."} (All [a] (-> Compiler (Lux a) (Syntax a))) (function [input] (case (macro;run compiler action) - (#;Left error) - (#;Left error) + (#R;Error error) + (#R;Error error) - (#;Right value) - (#;Right [input value]) + (#R;Success value) + (#R;Success [input value]) ))) (def: #export (local local-inputs syntax) @@ -391,18 +391,18 @@ (All [a] (-> (List Code) (Syntax a) (Syntax a))) (function [real-inputs] (case (syntax local-inputs) - (#;Left error) - (#;Left error) + (#R;Error error) + (#R;Error error) - (#;Right [unconsumed-inputs value]) + (#R;Success [unconsumed-inputs value]) (case unconsumed-inputs #;Nil - (#;Right [real-inputs value]) + (#R;Success [real-inputs value]) _ - (#;Left (Text/append "Unconsumed inputs: " - (|> (map code;to-text unconsumed-inputs) - (text;join-with ", ")))))))) + (#R;Error (Text/append "Unconsumed inputs: " + (|> (map code;to-text unconsumed-inputs) + (text;join-with ", ")))))))) (def: #export (rec syntax) {#;doc "Combinator for recursive syntax."} @@ -473,10 +473,10 @@ g!end (code;symbol ["" ""]) error-msg (code;text (Text/append "Wrong syntax for " name)) export-ast (: (List Code) (case exported? - (#;Some #;Left) + (#;Some #R;Error) (list (' #hidden)) - (#;Some #;Right) + (#;Some #R;Success) (list (' #export)) _ @@ -492,11 +492,11 @@ ((~' wrap) (do Monad<Lux> [] (~ body)))))) - (#;Right [(~ g!tokens) (~ g!body)]) + (#R;Success [(~ g!tokens) (~ g!body)]) ((~ g!body) (~ g!state)) - (#;Left (~ g!msg)) - (#;Left (text.join-with ": " (list (~ error-msg) (~ g!msg)))))))))))) + (#R;Error (~ g!msg)) + (#R;Error (text.join-with ": " (list (~ error-msg) (~ g!msg)))))))))))) _ (macro;fail "Wrong syntax for syntax:")))) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index e9e979ad2..4e63a8b28 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -7,11 +7,11 @@ applicative monad) (concurrency [promise #+ Promise Monad<Promise>]) - (data (coll [list "List/" Monad<List> Fold<List>]) + (data (coll [list "L/" Monad<List> Fold<List>]) [product] [text] text/format - [error #- fail "Error/" Monad<Error>]) + ["E" result]) [io #- run] ["R" math/random])) @@ -31,41 +31,41 @@ ## [Types] (type: #export Test {#;doc "Tests are asynchronous process which may fail."} - (Promise (Error Unit))) + (Promise (E;Result Unit))) ## [Values] (def: #export (fail message) (All [a] (-> Text Test)) - (:: Monad<Promise> wrap (#;Left message))) + (:: Monad<Promise> wrap (#E;Error message))) (def: #export (assert message condition) {#;doc "Check that a condition is true, and fail with the given message otherwise."} (-> Text Bool Test) (if condition - (:: Monad<Promise> wrap (#;Right [])) + (:: Monad<Promise> wrap (#E;Success [])) (fail message))) (def: #hidden (run' tests) (-> (List [Text (IO Test) Text]) (Promise Nat)) (do Monad<Promise> - [#let [test-runs (List/map (: (-> [Text (IO Test) Text] (Promise Nat)) - (function [[module test description]] - (do @ - [#let [pre (io;run now)] - outcome (io;run test) - #let [post (io;run now) - description+ (:: text;Codec<Text,Text> encode description)]] - (case outcome - (#;Left error) - (exec (log! (format "Error: " description+ " @ " module "\n" error "\n")) - (wrap +0)) - - _ - (exec (log! (format "Success: " description+ " @ " module " in " (%i (i.- pre post)) "ms")) - (wrap +1)))))) - tests)] + [#let [test-runs (L/map (: (-> [Text (IO Test) Text] (Promise Nat)) + (function [[module test description]] + (do @ + [#let [pre (io;run now)] + outcome (io;run test) + #let [post (io;run now) + description+ (:: text;Codec<Text,Text> encode description)]] + (case outcome + (#E;Error error) + (exec (log! (format "Error: " description+ " @ " module "\n" error "\n")) + (wrap +0)) + + _ + (exec (log! (format "Success: " description+ " @ " module " in " (%i (i.- pre post)) "ms")) + (wrap +1)))))) + tests)] test-runs (seqM @ test-runs)] - (wrap (List/fold n.+ +0 test-runs)))) + (wrap (L/fold n.+ +0 test-runs)))) (def: pcg-32-magic-inc Nat +12345) @@ -74,7 +74,7 @@ Nat) (def: (try seed random-test) - (-> Seed (R;Random Test) (Promise (Error Seed))) + (-> Seed (R;Random Test) (Promise (E;Result Seed))) (let [[prng [new-seed test]] (R;run (R;pcg-32 [pcg-32-magic-inc seed]) (do R;Monad<Random> [test random-test @@ -83,11 +83,11 @@ (do Monad<Promise> [result test] (case result - (#;Left error) - (wrap (#;Left error)) + (#E;Error error) + (wrap (#E;Error error)) - (#;Right _) - (wrap (#;Right new-seed)))))) + (#E;Success _) + (wrap (#E;Success new-seed)))))) (def: (repeat' seed times random-test) (-> Seed Nat (R;Random Test) Test) @@ -96,12 +96,12 @@ (do Monad<Promise> [output (try seed random-test)] (case output - (#;Left error) + (#E;Error error) (fail (format "Test failed with this seed: " (%n seed) "\n" error)) - (#;Right seed') + (#E;Success seed') (if (n.= +1 times) - (wrap (#;Right [])) + (wrap (#E;Success [])) (repeat' seed' (n.dec times) random-test)) )))) @@ -156,10 +156,10 @@ (def: #hidden (try-body lazy-body) (-> (IO Test) Test) (case (_lux_proc ["lux" "try"] [lazy-body]) - (#;Right output) + (#E;Success output) output - (#;Left error) + (#E;Error error) (assert error false))) (syntax: #export (test: description [body test^]) @@ -231,7 +231,7 @@ (#;Some (#Times value)) [(` #;None) value]) - bindings' (|> bindings (List/map pair-to-list) List/join)] + bindings' (|> bindings (L/map pair-to-list) L/join)] (` (repeat (~ =seed) (~ (code;nat =times)) (do R;Monad<Random> @@ -251,15 +251,15 @@ (do Monad<Lux> [defs (macro;exports module-name)] (wrap (|> defs - (List/map (function [[def-name [_ def-anns _]]] - (case (macro;get-text-ann (ident-for #;;test) def-anns) - (#;Some description) - [true module-name def-name description] + (L/map (function [[def-name [_ def-anns _]]] + (case (macro;get-text-ann (ident-for #;;test) def-anns) + (#;Some description) + [true module-name def-name description] - _ - [false module-name def-name ""]))) + _ + [false module-name def-name ""]))) (list;filter product;left) - (List/map product;right))))) + (L/map product;right))))) (def: #hidden _appendT_ (-> Text Text Text) (:: text;Monoid<Text> append)) (def: #hidden _%i_ (-> Int Text) %i) @@ -275,19 +275,19 @@ (|> (#;Cons current-module modules) list;reverse (mapM @ exported-tests) - (:: @ map List/join))) - #let [tests+ (List/map (function [[module-name test desc]] - (` [(~ (code;text module-name)) (~ (code;symbol [module-name test])) (~ (code;text desc))])) - tests) + (:: @ map L/join))) + #let [tests+ (L/map (function [[module-name test desc]] + (` [(~ (code;text module-name)) (~ (code;symbol [module-name test])) (~ (code;text desc))])) + tests) num-tests (list;size tests+) groups (list;split-all promise;concurrency-level tests+)]] (wrap (list (` (: (IO Unit) (io (exec (do Monad<Promise> [(~' #let) [(~ g!accum) +0] - (~@ (List/join (List/map (function [group] - (list g!_ (` (run' (list (~@ group)))) - (' #let) (` [(~ g!accum) (n.+ (~ g!_) (~ g!accum))]))) - groups))) + (~@ (L/join (L/map (function [group] + (list g!_ (` (run' (list (~@ group)))) + (' #let) (` [(~ g!accum) (n.+ (~ g!_) (~ g!accum))]))) + groups))) (~' #let) [(~ g!_) (n.- (~ g!accum) (~ (code;nat num-tests)))]] (exec (log! ($_ _appendT_ "Test-suite finished." @@ -310,12 +310,12 @@ [=left left =right right] (case [=left =right] - (^or [(#;Left error) _] - [_ (#;Left error)]) - (wrap (#;Left error)) + (^or [(#E;Error error) _] + [_ (#E;Error error)]) + (wrap (#E;Error error)) _ - (wrap (#;Right []))))) + (wrap (#E;Success []))))) (def: #export (alt left right) {#;doc "Alternative combinator."} @@ -324,7 +324,7 @@ [=left left =right right] (case =left - (#;Right _) + (#E;Success _) (wrap =left) _ diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux index 56198f5ab..e8f24102c 100644 --- a/stdlib/source/lux/type/check.lux +++ b/stdlib/source/lux/type/check.lux @@ -10,14 +10,14 @@ maybe [product] (coll [list]) - [error #- fail]) + ["R" result]) [type "Type/" Eq<Type>] )) (type: #export Fixed (List [[Type Type] Bool])) (type: #export (Check a) - (-> Type-Context (Error [Type-Context a]))) + (-> Type-Context (R;Result [Type-Context a]))) (type: #export Type-Vars (List [Nat (Maybe Type)])) @@ -26,11 +26,11 @@ (def: (map f fa) (function [context] (case (fa context) - (#;Left error) - (#;Left error) + (#R;Error error) + (#R;Error error) - (#;Right [context' output]) - (#;Right [context' (f output)]) + (#R;Success [context' output]) + (#R;Success [context' (f output)]) )))) (struct: #export _ (Applicative Check) @@ -38,21 +38,21 @@ (def: (wrap x) (function [context] - (#;Right [context x]))) + (#R;Success [context x]))) (def: (apply ff fa) (function [context] (case (ff context) - (#;Right [context' f]) + (#R;Success [context' f]) (case (fa context') - (#;Right [context'' a]) - (#;Right [context'' (f a)]) + (#R;Success [context'' a]) + (#R;Success [context'' (f a)]) - (#;Left error) - (#;Left error)) + (#R;Error error) + (#R;Error error)) - (#;Left error) - (#;Left error) + (#R;Error error) + (#R;Error error) ))) ) @@ -62,16 +62,16 @@ (def: (join ffa) (function [context] (case (ffa context) - (#;Right [context' fa]) + (#R;Success [context' fa]) (case (fa context') - (#;Right [context'' a]) - (#;Right [context'' a]) + (#R;Success [context'' a]) + (#R;Success [context'' a]) - (#;Left error) - (#;Left error)) + (#R;Error error) + (#R;Error error)) - (#;Left error) - (#;Left error) + (#R;Error error) + (#R;Error error) ))) ) @@ -121,93 +121,93 @@ ## [[Logic]] (def: #export (run context proc) - (All [a] (-> Type-Context (Check a) (Error a))) + (All [a] (-> Type-Context (Check a) (R;Result a))) (case (proc context) - (#;Left error) - (#;Left error) + (#R;Error error) + (#R;Error error) - (#;Right [context' output]) - (#;Right output))) + (#R;Success [context' output]) + (#R;Success output))) (def: (apply-type! t-func t-arg) (-> Type Type (Check Type)) (function [context] (case (type;apply-type t-func t-arg) #;None - (#;Left (format "Invalid type application: " (%type t-func) " on " (%type t-arg))) + (#R;Error (format "Invalid type application: " (%type t-func) " on " (%type t-arg))) (#;Some output) - (#;Right [context output])))) + (#R;Success [context output])))) (def: #export existential {#;doc "A producer of existential types."} (Check [Nat Type]) (function [context] (let [id (get@ #;ex-counter context)] - (#;Right [(update@ #;ex-counter n.inc context) - [id (#;Ex id)]])))) + (#R;Success [(update@ #;ex-counter n.inc context) + [id (#;Ex id)]])))) (def: #export (bound? id) (-> Nat (Check Bool)) (function [context] (case (|> context (get@ #;var-bindings) (var::get id)) (#;Some (#;Some _)) - (#;Right [context true]) + (#R;Success [context true]) (#;Some #;None) - (#;Right [context false]) + (#R;Success [context false]) #;None - (#;Left (format "Unknown type-var: " (%n id)))))) + (#R;Error (format "Unknown type-var: " (%n id)))))) (def: #export (read-var id) (-> Nat (Check Type)) (function [context] (case (|> context (get@ #;var-bindings) (var::get id)) (#;Some (#;Some type)) - (#;Right [context type]) + (#R;Success [context type]) (#;Some #;None) - (#;Left (format "Unbound type-var: " (%n id))) + (#R;Error (format "Unbound type-var: " (%n id))) #;None - (#;Left (format "Unknown type-var: " (%n id)))))) + (#R;Error (format "Unknown type-var: " (%n id)))))) (def: #export (write-var id type) (-> Nat Type (Check Unit)) (function [context] (case (|> context (get@ #;var-bindings) (var::get id)) (#;Some (#;Some bound)) - (#;Left (format "Cannot rebind type-var: " (%n id) " | Current type: " (%type bound))) + (#R;Error (format "Cannot rebind type-var: " (%n id) " | Current type: " (%type bound))) (#;Some #;None) - (#;Right [(update@ #;var-bindings (var::put id (#;Some type)) context) - []]) + (#R;Success [(update@ #;var-bindings (var::put id (#;Some type)) context) + []]) #;None - (#;Left (format "Unknown type-var: " (%n id)))))) + (#R;Error (format "Unknown type-var: " (%n id)))))) (def: (rewrite-var id type) (-> Nat Type (Check Unit)) (function [context] (case (|> context (get@ #;var-bindings) (var::get id)) (#;Some _) - (#;Right [(update@ #;var-bindings (var::put id (#;Some type)) context) - []]) + (#R;Success [(update@ #;var-bindings (var::put id (#;Some type)) context) + []]) #;None - (#;Left (format "Unknown type-var: " (%n id)))))) + (#R;Error (format "Unknown type-var: " (%n id)))))) (def: #export (clear-var id) (-> Nat (Check Unit)) (function [context] (case (|> context (get@ #;var-bindings) (var::get id)) (#;Some _) - (#;Right [(update@ #;var-bindings (var::put id #;None) context) - []]) + (#R;Success [(update@ #;var-bindings (var::put id #;None) context) + []]) #;None - (#;Left (format "Unknown type-var: " (%n id)))))) + (#R;Error (format "Unknown type-var: " (%n id)))))) (def: #export (clean t-id type) (-> Nat Type (Check Type)) @@ -274,22 +274,22 @@ (Check [Nat Type]) (function [context] (let [id (get@ #;var-counter context)] - (#;Right [(|> context - (update@ #;var-counter n.inc) - (update@ #;var-bindings (var::put id #;None))) - [id (#;Var id)]])))) + (#R;Success [(|> context + (update@ #;var-counter n.inc) + (update@ #;var-bindings (var::put id #;None))) + [id (#;Var id)]])))) (def: get-bindings (Check (List [Nat (Maybe Type)])) (function [context] - (#;Right [context - (get@ #;var-bindings context)]))) + (#R;Success [context + (get@ #;var-bindings context)]))) (def: (set-bindings value) (-> (List [Nat (Maybe Type)]) (Check Unit)) (function [context] - (#;Right [(set@ #;var-bindings value context) - []]))) + (#R;Success [(set@ #;var-bindings value context) + []]))) (def: #export (delete-var id) (-> Nat (Check Unit)) @@ -343,16 +343,16 @@ (All [a] (-> (Check a) (Check (Maybe a)))) (function [context] (case (op context) - (#;Right [context' output]) - (#;Right [context' (#;Some output)]) + (#R;Success [context' output]) + (#R;Success [context' (#;Some output)]) - (#;Left _) - (#;Right [context #;None])))) + (#R;Error _) + (#R;Success [context #;None])))) (def: #export (fail message) (All [a] (-> Text (Check a))) (function [context] - (#;Left message))) + (#R;Error message))) (def: (fail-check expected actual) (All [a] (-> Type Type (Check a))) @@ -363,10 +363,10 @@ (All [a] (-> (Check a) (Check a) (Check a))) (function [context] (case (left context) - (#;Right [context' output]) - (#;Right [context' output]) + (#R;Success [context' output]) + (#R;Success [context' output]) - (#;Left _) + (#R;Error _) (right context)))) (def: (fx-get [e a] fixed) @@ -555,13 +555,13 @@ {#;doc "A simple type-checking function that just returns a yes/no answer."} (-> Type Type Bool) (case (run fresh-context (check expected actual)) - (#;Left error) + (#R;Error error) false - (#;Right _) + (#R;Success _) true)) (def: #export get-context (Check Type-Context) (function [context] - (#;Right [context context]))) + (#R;Success [context context]))) |