From 27466e65e78af24f8e750549055123d6c8559839 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 31 Jul 2017 20:34:12 -0400
Subject: - Added formatters for JSON, XML and time types.

---
 stdlib/source/lux/data/format/json.lux | 87 +++++++++++++++++-----------------
 1 file changed, 43 insertions(+), 44 deletions(-)

(limited to 'stdlib/source/lux/data/format/json.lux')

diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index 6d7ed16a7..c4951f188 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -9,10 +9,9 @@
                 codec
                 ["p" parser "p/" Monad<Parser>])
        (data [bool]
-             [text "Text/" Eq<Text> Monoid<Text>]
-             text/format
+             [text "text/" Eq<Text> Monoid<Text>]
              (text ["l" lexer])
-             [number "Real/" Codec<Text,Real>]
+             [number "real/" Codec<Text,Real> "nat/" Codec<Text,Nat>]
              maybe
              ["R" result]
              [sum]
@@ -116,18 +115,18 @@
 
 (def: (show-array show-json elems)
   (-> (-> JSON Text) (-> Array Text))
-  (format "["
-          (|> elems (Vector/map show-json) vector;to-list (text;join-with ","))
-          "]"))
+  ($_ text/append "["
+      (|> elems (Vector/map show-json) vector;to-list (text;join-with ","))
+      "]"))
 
 (def: (show-object show-json object)
   (-> (-> JSON Text) (-> Object Text))
-  (format "{"
-          (|> object
-              d;entries
-              (L/map (function [[key value]] (format (show-string key) ":" (show-json value))))
-              (text;join-with ","))
-          "}"))
+  ($_ text/append "{"
+      (|> object
+          d;entries
+          (L/map (function [[key value]] ($_ text/append (show-string key) ":" (show-json value))))
+          (text;join-with ","))
+      "}"))
 
 (def: (show-json json)
   (-> JSON Text)
@@ -156,7 +155,7 @@
     (#R;Success (d;keys obj))
 
     _
-    (#R;Error (format "Cannot get the fields of a non-object."))))
+    (#R;Error ($_ text/append "Cannot get the fields of a non-object."))))
 
 (def: #export (get key json)
   {#;doc "A JSON object field getter."}
@@ -168,10 +167,10 @@
       (#R;Success value)
 
       #;None
-      (#R;Error (format "Missing field " (show-string key) " on object.")))
+      (#R;Error ($_ text/append "Missing field " (show-string key) " on object.")))
 
     _
-    (#R;Error (format "Cannot get field " (show-string key) " of a non-object."))))
+    (#R;Error ($_ text/append "Cannot get field " (show-string key) " of a non-object."))))
 
 (def: #export (set key value json)
   {#;doc "A JSON object field setter."}
@@ -181,18 +180,18 @@
     (#R;Success (#Object (d;put key value obj)))
 
     _
-    (#R;Error (format "Cannot set field " (show-string key) " of a non-object."))))
+    (#R;Error ($_ text/append "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> "."))}
+     {#;doc (#;TextA ($_ text/append "A JSON object field getter for " <desc> "."))}
      (-> Text JSON (R;Result <type>))
      (case (get key json)
        (#R;Success (<tag> value))
        (#R;Success value)
 
        (#R;Success _)
-       (#R;Error (format "Wrong value type at key " (show-string key)))
+       (#R;Error ($_ text/append "Wrong value type at key " (show-string key)))
 
        (#R;Error error)
        (#R;Error error)))]
@@ -206,7 +205,7 @@
 
 (do-template [<name> <type> <tag> <desc>]
   [(def: #export (<name> value)
-     {#;doc (#;TextA (format "A JSON generator for " <desc> "."))}
+     {#;doc (#;TextA ($_ text/append "A JSON generator for " <desc> "."))}
      (Gen <type>)
      (<tag> value))]
 
@@ -269,8 +268,8 @@
              [mark (l;one-of "eE")
               signed?' (l;this? "-")
               offset (l;many l;decimal)]
-             (wrap (format mark (if signed?' "-" "") offset))))]
-    (case (Real/decode (format (if signed? "-" "") digits "." decimals exp))
+             (wrap ($_ text/append mark (if signed?' "-" "") offset))))]
+    (case (real/decode ($_ text/append (if signed? "-" "") digits "." decimals exp))
       (#R;Error message)
       (p;fail message)
       
@@ -295,11 +294,11 @@
         (do p;Monad<Parser>
           [chars (l;some (l;none-of "\\\""))
            stop l;peek]
-          (if (Text/= "\\" stop)
+          (if (text/= "\\" stop)
             (do @
               [escaped escaped~
                next-chars (recur [])]
-              (wrap (format chars escaped next-chars)))
+              (wrap ($_ text/append chars escaped next-chars)))
             (wrap chars))))))
 
 (def: (kv~ json~)
@@ -378,14 +377,14 @@
 ## Syntax
 (do-template [<name> <type> <tag> <desc> <pre>]
   [(def: #export (<name> json)
-     {#;doc (#;TextA (format "Reads a JSON value as " <desc> "."))}
+     {#;doc (#;TextA ($_ text/append "Reads a JSON value as " <desc> "."))}
      (Parser <type>)
      (case json
        (<tag> value)
        (#R;Success (<pre> value))
 
        _
-       (#R;Error (format "JSON value is not " <desc> ": " (show-json json)))))]
+       (#R;Error ($_ text/append "JSON value is not " <desc> ": " (show-json json)))))]
 
   [unit Unit #Null    "unit" id]
   [bool Bool #Boolean "bool" id]
@@ -396,28 +395,28 @@
 
 (do-template [<test> <check> <type> <eq> <encoder> <tag> <desc> <pre>]
   [(def: #export (<test> test json)
-     {#;doc (#;TextA (format "Asks whether a JSON value is a " <desc> "."))}
+     {#;doc (#;TextA ($_ text/append "Asks whether a JSON value is a " <desc> "."))}
      (-> <type> (Parser Bool))
      (case json
        (<tag> value)
        (#R;Success (:: <eq> = test (<pre> value)))
 
        _
-       (#R;Error (format "JSON value is not a " <desc> ": " (show-json json)))))
+       (#R;Error ($_ text/append "JSON value is not a " <desc> ": " (show-json json)))))
 
    (def: #export (<check> test json)
-     {#;doc (#;TextA (format "Ensures a JSON value is a " <desc> "."))}
+     {#;doc (#;TextA ($_ text/append "Ensures a JSON value is a " <desc> "."))}
      (-> <type> (Parser Unit))
      (case json
        (<tag> value)
        (let [value (<pre> value)]
          (if (:: <eq> = test value)
            (#R;Success [])
-           (#R;Error (format "Value mismatch: "
-                             (<encoder> test) "=/=" (<encoder> value)))))
+           (#R;Error ($_ text/append "Value mismatch: "
+                         (<encoder> test) "=/=" (<encoder> value)))))
 
        _
-       (#R;Error (format "JSON value is not a " <desc> ": " (show-json json)))))]
+       (#R;Error ($_ text/append "JSON value is not a " <desc> ": " (show-json json)))))]
 
   [bool? bool! Bool bool;Eq<Bool>   (:: bool;Codec<Text,Bool> encode)   #Boolean "boolean" id]
   [int?  int!  Int  number;Eq<Int>  (:: number;Codec<Text,Int> encode)  #Number  "number"  real-to-int]
@@ -453,7 +452,7 @@
         (wrap elems))
 
       _
-      (#R;Error (format "JSON value is not an array: " (show-json json))))))
+      (#R;Error ($_ text/append "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."}
@@ -471,7 +470,7 @@
         (wrap (d;from-list text;Hash<Text> kvs)))
 
       _
-      (#R;Error (format "JSON value is not an object: " (show-json json))))))
+      (#R;Error ($_ text/append "JSON value is not an object: " (show-json json))))))
 
 (def: #export (nth idx parser)
   {#;doc "Parses an element inside a JSON array."}
@@ -486,13 +485,13 @@
           (#R;Success output)
 
           (#R;Error error)
-          (#R;Error (format "JSON array index [" (%n idx) "]: (" error ") @ " (show-json json))))
+          (#R;Error ($_ text/append "JSON array index [" (nat/encode idx) "]: (" error ") @ " (show-json json))))
 
         #;None
-        (#R;Error (format "JSON array does not have index " (%n idx) " @ " (show-json json))))
+        (#R;Error ($_ text/append "JSON array does not have index " (nat/encode idx) " @ " (show-json json))))
       
       _
-      (#R;Error (format "JSON value is not an array: " (show-json json))))))
+      (#R;Error ($_ text/append "JSON value is not an array: " (show-json json))))))
 
 (def: #export (field field-name parser)
   {#;doc "Parses a field inside a JSON object."}
@@ -505,10 +504,10 @@
         (#R;Success output)
 
         (#R;Error error)
-        (#R;Error (format "Failed to get JSON object field " (show-string field-name) ": (" error ") @ " (show-json json))))
+        (#R;Error ($_ text/append "Failed to get JSON object field " (show-string field-name) ": (" error ") @ " (show-json json))))
 
       (#R;Error _)
-      (#R;Error (format "JSON object does not have field " (show-string field-name) " @ " (show-json json))))))
+      (#R;Error ($_ text/append "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."}
@@ -583,10 +582,10 @@
       (#Array parts)
       (if (n.= size (vector;size parts))
         (#R;Success [])
-        (#R;Error (format "JSON array does no have size " (%n size) " " (show-json json))))
+        (#R;Error ($_ text/append "JSON array does no have size " (nat/encode size) " " (show-json json))))
 
       _
-      (#R;Error (format "JSON value is not an array: " (show-json json))))))
+      (#R;Error ($_ text/append "JSON value is not an array: " (show-json json))))))
 
 (def: #export (object-fields! wanted-fields)
   {#;doc "Ensures that every field in the list of wanted-fields is present in a JSON object."}
@@ -599,10 +598,10 @@
                  (list;every? (list;member? text;Eq<Text> wanted-fields)
                               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) "]"))))
+          (#R;Error ($_ text/append "JSON object has wrong field-set. Expected: [" (text;join-with ", " wanted-fields) "]. Actual: [" (text;join-with ", " actual-fields) "]"))))
 
       _
-      (#R;Error (format "JSON value is not an object: " (show-json json))))))
+      (#R;Error ($_ text/append "JSON value is not an object: " (show-json json))))))
 
 ## [Structures]
 (struct: #export _ (Eq JSON)
@@ -876,7 +875,7 @@
           ## Bound type-vars
           (poly;bound env :x:)
           ## If all else fails...
-          (macro;fail (format "Cannot create JSON encoder for: " (%type :x:)))
+          (macro;fail ($_ text/append "Cannot create JSON encoder for: " (type;to-text :x:)))
           ))))
 
 (def: #hidden (rec-decode non-rec)
@@ -1063,7 +1062,7 @@
             [g!bound (poly;bound env :x:)]
             (wrap g!bound))
           ## If all else fails...
-          (macro;fail (format "Cannot create JSON decoder for: " (%type :x:)))
+          (macro;fail ($_ text/append "Cannot create JSON decoder for: " (type;to-text :x:)))
           ))))
 
 (syntax: #export (Codec<JSON,?> :x:)
-- 
cgit v1.2.3