From 58090eb3ecd06f563b6864aad7d28a00dc908c66 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 1 May 2018 19:26:29 -0400
Subject: - Allow underscore separators in the hex, octal and binary encoding
 macros for Nat/Int/Deg/Frac.

---
 stdlib/source/lux/data/number.lux    | 89 ++++++++++++++++++++++++------------
 stdlib/test/test/lux/data/number.lux | 18 ++++++++
 2 files changed, 78 insertions(+), 29 deletions(-)

(limited to 'stdlib')

diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux
index 388fa6174..732adbb3b 100644
--- a/stdlib/source/lux/data/number.lux
+++ b/stdlib/source/lux/data/number.lux
@@ -481,12 +481,12 @@
            (map <from-translator>)
            re-join-chunks)))
 
-   (def: (<to> input)
+   (def: <to>
      (-> Text Text)
-     (|> input
-         (segment-digits +1)
-         (map <to-translator>)
-         re-join-chunks))]
+     (|>> "lux text upper"
+          (segment-digits +1)
+          (map <to-translator>)
+          re-join-chunks))]
 
   [binary-to-hex   bin-segment-to-hex   hex-to-binary   hex-segment-to-bin   +4]
   [binary-to-octal bin-segment-to-octal octal-to-binary octal-segment-to-bin +3]
@@ -537,45 +537,76 @@
   [Hex@Codec<Text,Frac>   "Invalid hexadecimal syntax: "   binary-to-hex   hex-to-binary]
   )
 
+(macro: (encoding-doc tokens state)
+  (case tokens
+    (^ (list [cursor (#.Text encoding)] example-1 example-2))
+    (let [encoding ($_ "lux text concat"
+                       "Given syntax for a "
+                       encoding
+                       " number, generates a Nat, an Int, a Deg or a Frac.")
+          underscore "Allows for the presence of underscore in the numbers."
+          description [cursor (#.Text ($_ "lux text concat"
+                                          encoding "\n"
+                                          underscore))]]
+      (#e.Success [state (list (` (doc (~ description)
+                                       (~ example-1)
+                                       (~ example-2))))]))
+
+    _
+    (#e.Error "Wrong syntax for \"encoding-doc\".")))
+
+(def: (underscore-prefixed? number)
+  (-> Text Bool)
+  (case ("lux text index" number "_" +0)
+    (#.Some +0)
+    true
+
+    _
+    false))
+
+(def: (clean-underscores number)
+  (-> Text Text)
+  ("lux text replace-all" number "_" ""))
+
 (do-template [<macro> <nat> <int> <deg> <frac> <error> <doc>]
   [(macro: #export (<macro> tokens state)
      {#.doc <doc>}
      (case tokens
-       (#.Cons [meta (#.Text repr)] #.Nil)
-       (case (:: <nat> decode repr)
-         (#e.Success value)
-         (#e.Success [state (list [meta (#.Nat value)])])
-
-         (^multi (#e.Error _)
-                 [(:: <int> decode repr) (#e.Success value)])
-         (#e.Success [state (list [meta (#.Int value)])])
-
-         (^multi (#e.Error _)
-                 [(:: <deg> decode repr) (#e.Success value)])
-         (#e.Success [state (list [meta (#.Deg value)])])
+       (#.Cons [meta (#.Text repr')] #.Nil)
+       (if (underscore-prefixed? repr')
+         (#e.Error <error>)
+         (let [repr (clean-underscores repr')]
+           (case (:: <nat> decode repr)
+             (#e.Success value)
+             (#e.Success [state (list [meta (#.Nat value)])])
+
+             (^multi (#e.Error _)
+                     [(:: <int> decode repr) (#e.Success value)])
+             (#e.Success [state (list [meta (#.Int value)])])
+
+             (^multi (#e.Error _)
+                     [(:: <deg> decode repr) (#e.Success value)])
+             (#e.Success [state (list [meta (#.Deg value)])])
+
+             (^multi (#e.Error _)
+                     [(:: <frac> decode repr) (#e.Success value)])
+             (#e.Success [state (list [meta (#.Frac value)])])
 
-         (^multi (#e.Error _)
-                 [(:: <frac> decode repr) (#e.Success value)])
-         (#e.Success [state (list [meta (#.Frac value)])])
-
-         _
-         (#e.Error <error>))
+             _
+             (#e.Error <error>))))
 
        _
        (#e.Error <error>)))]
 
   [bin Binary@Codec<Text,Nat> Binary@Codec<Text,Int> Binary@Codec<Text,Deg> Binary@Codec<Text,Frac>
    "Invalid binary syntax."
-   (doc "Given syntax for a binary number, generates a Nat, an Int, a Deg or a Frac."
-        (bin "11001001"))]
+   (encoding-doc "binary" (bin "11001001") (bin "11_00_10_01"))]
   [oct Octal@Codec<Text,Nat>  Octal@Codec<Text,Int>  Octal@Codec<Text,Deg>  Octal@Codec<Text,Frac>
    "Invalid octal syntax."
-   (doc "Given syntax for a octal number, generates a Nat, an Int, a Deg or a Frac."
-        (oct "615243"))]
+   (encoding-doc "octal" (oct "615243") (oct "615_243"))]
   [hex Hex@Codec<Text,Nat>    Hex@Codec<Text,Int>    Hex@Codec<Text,Deg>    Hex@Codec<Text,Frac>
    "Invalid hexadecimal syntax."
-   (doc "Given syntax for a hexadecimal number, generates a Nat, an Int, a Deg or a Frac."
-        (hex "deadBEEF"))]
+   (encoding-doc "hexadecimal" (hex "deadBEEF") (hex "dead_BEEF"))]
   )
 
 ## The following code allows one to encode/decode Deg numbers as text.
diff --git a/stdlib/test/test/lux/data/number.lux b/stdlib/test/test/lux/data/number.lux
index 3ba7db2c2..263dd346d 100644
--- a/stdlib/test/test/lux/data/number.lux
+++ b/stdlib/test/test/lux/data/number.lux
@@ -163,3 +163,21 @@
          #let [sample (|> factor nat-to-int int-to-frac (f/* raw))]]
         (test "Can convert frac values to/from their bit patterns."
               (|> sample frac-to-bits bits-to-frac (f/= sample))))))
+
+(context: "Macros for alternative numeric encodings."
+  ($_ seq
+      (test "Binary."
+            (and (n/= (bin "+11001001") (bin "+11_00_10_01"))
+                 (i/= (bin "11001001") (bin "11_00_10_01"))
+                 (d/= (bin ".11001001") (bin ".11_00_10_01"))
+                 (f/= (bin "1100.1001") (bin "11_00.10_01"))))
+      (test "Octal."
+            (and (n/= (oct "+615243") (oct "+615_243"))
+                 (i/= (oct "615243") (oct "615_243"))
+                 (d/= (oct ".615243") (oct ".615_243"))
+                 (f/= (oct "6152.43") (oct "615_2.43"))))
+      (test "Hexadecimal."
+            (and (n/= (hex "+deadBEEF") (hex "+dead_BEEF"))
+                 (i/= (hex "deadBEEF") (hex "dead_BEEF"))
+                 (d/= (hex ".deadBEEF") (hex ".dead_BEEF"))
+                 (f/= (hex "deadBE.EF") (hex "dead_BE.EF"))))))
-- 
cgit v1.2.3