diff options
| -rw-r--r-- | stdlib/source/lux/data/number.lux | 242 | ||||
| -rw-r--r-- | stdlib/test/test/lux/data/number.lux | 29 |
2 files changed, 120 insertions, 151 deletions
diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 62c7abd6b..a854e8bf7 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -131,6 +131,22 @@ [ Min@Monoid<Deg> Deg (:: Interval<Deg> top) d.min] ) +(do-template [<name> <const> <doc>] + [(def: #export <name> + {#;doc <doc>} + Real + (_lux_proc ["real" <const>] []))] + + [not-a-number "not-a-number" "Not-a-number."] + [positive-infinity "positive-infinity" "Positive infinity."] + [negative-infinity "negative-infinity" "Negative infinity."] + ) + +(def: #export (not-a-number? number) + {#;doc "Tests whether a real is actually not-a-number."} + (-> Real Bool) + (not (r.= number number))) + (do-template [<type> <encoder> <decoder> <error>] [(struct: #export _ (Codec Text <type>) (def: (encode x) @@ -144,103 +160,10 @@ #;None (#;Left <error>))))] - [ Deg [ "deg" "encode"] [ "deg" "decode"] "Couldn't decode Deg"] [Real ["real" "encode"] ["real" "decode"] "Couldn't decode Real"] + [ Deg [ "deg" "encode"] [ "deg" "decode"] "Couldn't decode Deg"] ) -(def: (digit-to-text digit) - (-> Nat Text) - (case digit - +0 "0" - +1 "1" +2 "2" +3 "3" - +4 "4" +5 "5" +6 "6" - +7 "7" +8 "8" +9 "9" - _ (undefined))) - -(def: (text-to-digit digit) - (-> Text (Maybe Nat)) - (case digit - "0" (#;Some +0) - "1" (#;Some +1) "2" (#;Some +2) "3" (#;Some +3) - "4" (#;Some +4) "5" (#;Some +5) "6" (#;Some +6) - "7" (#;Some +7) "8" (#;Some +8) "9" (#;Some +9) - _ #;None)) - -(struct: #export _ (Codec Text Int) - (def: (encode value) - (if (i.= 0 value) - "0" - (let [sign (if (i.> 0 value) - "" - "-")] - (loop [input (|> value (i./ 10) (:: Number<Int> abs)) - output (|> value (i.% 10) (:: Number<Int> abs) int-to-nat digit-to-text)] - (if (i.= 0 input) - (_lux_proc ["text" "append"] [sign output]) - (recur (i./ 10 input) - (_lux_proc ["text" "append"] [(|> input (i.% 10) int-to-nat digit-to-text) - output]))))) - )) - - (def: (decode repr) - (let [input-size (_lux_proc ["text" "size"] [repr])] - (if (n.>= +1 input-size) - (let [sign (case (_lux_proc ["text" "char"] [repr +0]) - (#;Some #"-") - -1 - - _ - 1)] - (loop [idx (if (i.= -1 sign) +1 +0) - output 0] - (if (n.< input-size idx) - (case (_lux_proc ["text" "char"] [repr idx]) - (^=> (#;Some sample) - [(text-to-digit (_lux_proc ["char" "to-text"] [sample])) (#;Some digit)]) - (recur (n.inc idx) - (|> output (i.* 10) (i.+ (nat-to-int digit)))) - - _ - (undefined)) - (#;Right (i.* sign output))))) - (#;Left "Invalid syntax for Int."))))) - -(struct: #export _ (Codec Text Nat) - (def: (encode value) - (case value - +0 - "+0" - - _ - (loop [input value - output ""] - (if (n.= +0 input) - (_lux_proc ["text" "append"] ["+" output]) - (recur (n./ +10 input) - (_lux_proc ["text" "append"] [(digit-to-text (n.% +10 input)) output])))))) - - (def: (decode repr) - (let [input-size (_lux_proc ["text" "size"] [repr])] - (if (n.>= +2 input-size) - (case (_lux_proc ["text" "char"] [repr +0]) - (#;Some #"+") - (loop [idx +1 - output +0] - (if (n.< input-size idx) - (case (_lux_proc ["text" "char"] [repr idx]) - (^=> (#;Some sample) - [(text-to-digit (_lux_proc ["char" "to-text"] [sample])) (#;Some digit)]) - (recur (n.inc idx) - (|> output (n.* +10) (n.+ digit))) - - _ - (undefined)) - (#;Right output))) - - _ - (#;Left "Invalid syntax for Nat.")) - (#;Left "Invalid syntax for Nat."))))) - (struct: #export _ (Hash Nat) (def: eq Eq<Nat>) (def: hash id)) @@ -255,24 +178,8 @@ (def: (hash value) (_lux_proc ["real" "hash"] [value]))) -(do-template [<name> <const> <doc>] - [(def: #export <name> - {#;doc <doc>} - Real - (_lux_proc ["real" <const>] []))] - - [not-a-number "not-a-number" "Not-a-number."] - [positive-infinity "positive-infinity" "Positive infinity."] - [negative-infinity "negative-infinity" "Negative infinity."] - ) - -(def: #export (not-a-number? number) - {#;doc "Tests whether a real is actually not-a-number."} - (-> Real Bool) - (not (r.= number number))) - ## [Values & Syntax] -(do-template [<struct> <base> <macro> <error> <char-set> <doc>] +(do-template [<struct> <base> <char-set> <error>] [(struct: #export <struct> (Codec Text Nat) (def: (encode value) (loop [input value @@ -282,16 +189,75 @@ output]) input' (n./ <base> input)] (if (n.= +0 input') - output' + (_lux_proc ["text" "append"] ["+" output']) (recur input' output'))))) (def: (decode repr) (let [input-size (_lux_proc ["text" "size"] [repr])] - (if (n.= +0 input-size) - (#;Left "Empty input.") - (let [input (_lux_proc ["text" "upper-case"] [repr])] - (loop [idx +0 - output +0] + (if (n.>= +2 input-size) + (case (_lux_proc ["text" "char"] [repr +0]) + (#;Some #"+") + (let [input (_lux_proc ["text" "upper-case"] [repr])] + (loop [idx +1 + output +0] + (if (n.< input-size idx) + (let [digit (assume (_lux_proc ["text" "char"] [input idx]))] + (case (_lux_proc ["text" "index"] + [<char-set> + (_lux_proc ["char" "to-text"] [digit]) + +0]) + #;None + (#;Left (_lux_proc ["text" "append"] [<error> repr])) + + (#;Some index) + (recur (n.inc idx) + (|> output (n.* <base>) (n.+ index))))) + (#;Right output)))) + + _ + (#;Left (_lux_proc ["text" "append"] [<error> repr]))) + (#;Left (_lux_proc ["text" "append"] [<error> repr]))))))] + + [Binary@Codec<Text,Nat> +2 "01" "Invalid binary syntax: "] + [Octal@Codec<Text,Nat> +8 "01234567" "Invalid octal syntax: "] + [_ +10 "0123456789" "Invalid syntax for Nat: "] + [Hex@Codec<Text,Nat> +16 "0123456789ABCDEF" "Invalid hexadecimal syntax: "] + ) + +(do-template [<struct> <base> <char-set> <error>] + [(struct: #export <struct> (Codec Text Int) + (def: (encode value) + (if (i.= 0 value) + "0" + (let [sign (if (i.< 0 value) + "-" + "")] + (loop [input (|> value (i./ <base>) (:: Number<Int> abs)) + output (|> value (i.% <base>) (:: Number<Int> abs) + int-to-nat [<char-set>] (_lux_proc ["text" "char"]) + assume + [] + (_lux_proc ["char" "to-text"]))] + (let [digit (assume (_lux_proc ["text" "char"] [<char-set> (int-to-nat (i.% <base> input))])) + output' (_lux_proc ["text" "append"] [(_lux_proc ["char" "to-text"] [digit]) + output]) + input' (i./ <base> input)] + (if (i.= 0 input') + (_lux_proc ["text" "append"] [sign output']) + (recur input' output'))))))) + + (def: (decode repr) + (let [input-size (_lux_proc ["text" "size"] [repr])] + (if (n.>= +1 input-size) + (let [sign (case (_lux_proc ["text" "char"] [repr +0]) + (#;Some #"-") + -1 + + _ + 1) + input (_lux_proc ["text" "upper-case"] [repr])] + (loop [idx (if (i.= -1 sign) +1 +0) + output 0] (if (n.< input-size idx) (let [digit (assume (_lux_proc ["text" "char"] [input idx]))] (case (_lux_proc ["text" "index"] @@ -303,33 +269,45 @@ (#;Some index) (recur (n.inc idx) - (|> output (n.* <base>) (n.+ index))))) - (#;Right output)))))))) + (|> output (i.* <base>) (i.+ (nat-to-int index)))))) + (#;Right (i.* sign output))))) + (#;Left <error>)))))] + + [Binary@Codec<Text,Int> 2 "01" "Invalid binary syntax."] + [Octal@Codec<Text,Int> 8 "01234567" "Invalid octal syntax."] + [_ 10 "0123456789" "Invalid syntax for Int: "] + [Hex@Codec<Text,Int> 16 "0123456789ABCDEF" "Invalid hexadecimal syntax."] + ) - (macro: #export (<macro> tokens state) +(do-template [<macro> <nat> <int> <error> <doc>] + [(macro: #export (<macro> tokens state) {#;doc <doc>} (case tokens (#;Cons [meta (#;TextS repr)] #;Nil) - (case (:: <struct> decode repr) + (case (:: <nat> decode repr) (#;Right value) (#;Right [state (list [meta (#;NatS value)])]) - (#;Left error) - (#;Left error)) + (^=> (#;Left _) + [(:: <int> decode repr) (#;Right value)]) + (#;Right [state (list [meta (#;IntS value)])]) + + _ + (#;Left <error>)) _ (#;Left <error>)))] - [Binary@Codec<Text,Nat> +2 bin "Invalid binary syntax." - "01" - (doc "Given syntax for a binary number, generates a Nat." + [bin Binary@Codec<Text,Nat> Binary@Codec<Text,Int> + "Invalid binary syntax." + (doc "Given syntax for a binary number, generates a Nat, an Int, a Real or a Deg." (bin "11001001"))] - [Octal@Codec<Text,Nat> +8 oct "Invalid octal syntax." - "01234567" - (doc "Given syntax for an octal number, generates a Nat." + [oct Octal@Codec<Text,Nat> Octal@Codec<Text,Int> + "Invalid octal syntax." + (doc "Given syntax for an octal number, generates a Nat, an Int, a Real or a Deg." (oct "615243"))] - [Hex@Codec<Text,Nat> +16 hex "Invalid hexadecimal syntax." - "0123456789ABCDEF" - (doc "Given syntax for a hexadecimal number, generates a Nat." + [hex Hex@Codec<Text,Nat> Hex@Codec<Text,Int> + "Invalid hexadecimal syntax." + (doc "Given syntax for a hexadecimal number, generates a Nat, an Int, a Real or a Deg." (hex "deadBEEF"))] ) diff --git a/stdlib/test/test/lux/data/number.lux b/stdlib/test/test/lux/data/number.lux index eefbd584b..8e959cf6f 100644 --- a/stdlib/test/test/lux/data/number.lux +++ b/stdlib/test/test/lux/data/number.lux @@ -110,25 +110,6 @@ ) (do-template [<category> <rand-gen> <Eq> <Codec>] - [(test: (format "[" <category> "] " "Codec") - [x <rand-gen>] - (assert "Can encode/decode values." - (|> x - (:: <Codec> encode) - (:: <Codec> decode) - (case> (#;Right x') - (:: <Eq> = x x') - - (#;Left _) - false))))] - - ["Nat" R;nat Eq<Nat> Codec<Text,Nat>] - ["Int" R;int Eq<Int> Codec<Text,Int>] - ["Real" R;real Eq<Real> Codec<Text,Real>] - ["Deg" R;deg Eq<Deg> Codec<Text,Deg>] - ) - -(do-template [<category> <rand-gen> <Eq> <Codec>] [(test: (format "[" <category> "] " "Alternative formats") [x <rand-gen>] (assert "Can encode/decode values." @@ -143,5 +124,15 @@ ["Nat/Binary" R;nat Eq<Nat> Binary@Codec<Text,Nat>] ["Nat/Octal" R;nat Eq<Nat> Octal@Codec<Text,Nat>] + ["Nat" R;nat Eq<Nat> Codec<Text,Nat>] ["Nat/Hex" R;nat Eq<Nat> Hex@Codec<Text,Nat>] + + ["Int/Binary" R;int Eq<Int> Binary@Codec<Text,Int>] + ["Int/Octal" R;int Eq<Int> Octal@Codec<Text,Int>] + ["Int" R;int Eq<Int> Codec<Text,Int>] + ["Int/Hex" R;int Eq<Int> Hex@Codec<Text,Int>] + + ["Deg" R;deg Eq<Deg> Codec<Text,Deg>] + + ["Real" R;real Eq<Real> Codec<Text,Real>] ) |