aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/lux/data/number.lux242
-rw-r--r--stdlib/test/test/lux/data/number.lux29
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>]
)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 20:10:06 +0000