1 files changed, 177 insertions, 0 deletions
diff --git a/stdlib/source/lux/data/format/json/reader.lux b/stdlib/source/lux/data/format/json/reader.lux
new file mode 100644
index 000000000..83713bcf3
--- /dev/null
+++ b/stdlib/source/lux/data/format/json/reader.lux
@@ -0,0 +1,177 @@
+(;module: {#;doc "Functionality for reading values in the JSON format.
+
+                  For more information, please see: http://www.json.org/"}
+  lux
+  (lux (control [monad #+ do Monad]
+                [eq #+ Eq]
+                codec
+                ["p" parser "p/" Monad<Parser>])
+       (data [bool]
+             [text "text/" Monoid<Text>]
+             [number "real/" Codec<Text,Real> "nat/" Codec<Text,Nat>]
+             ["R" result]
+             (coll [list]
+                   [vector]
+                   ["d" dict]))
+       )
+  [.. #+ JSON Reader])
+
+(def: unconsumed-input-error Text "Unconsumed JSON.")
+
+(def: #export (run json parser)
+  (All [a] (-> JSON (Reader a) (R;Result a)))
+  (case (p;run (list json) parser)
+    (#R;Success [remainder output])
+    (case remainder
+      #;Nil
+      (#R;Success output)
+
+      _
+      (#R;Error unconsumed-input-error))
+    
+    (#R;Error error)
+    (#R;Error error)))
+
+(def: #export (fail error)
+  (All [a] (-> Text (Reader a)))
+  (function [inputs]
+    (#R;Error error)))
+
+(def: #export any
+  {#;doc "Just returns the JSON input without applying any logic."}
+  (Reader JSON)
+  (<| (function [inputs])
+      (case inputs
+        #;Nil
+        (#R;Error "Empty JSON stream.")
+        
+        (#;Cons head tail)
+        (#R;Success [tail head]))))
+
+(do-template [<name> <type> <tag> <desc>]
+  [(def: #export <name>
+     {#;doc (#;TextA ($_ text/append "Reads a JSON value as " <desc> "."))}
+     (Reader <type>)
+     (do p;Monad<Parser>
+       [head any]
+       (case head
+         (<tag> value)
+         (wrap value)
+
+         _
+         (fail ($_ text/append "JSON value is not " <desc> ".")))))]
+
+  [null    Unit #..;Null    "null"]
+  [boolean Bool #..;Boolean "boolean"]
+  [number  Real #..;Number  "number"]
+  [string  Text #..;String  "string"]
+  )
+
+(do-template [<test> <check> <type> <eq> <encoder> <tag> <desc> <pre>]
+  [(def: #export (<test> test)
+     {#;doc (#;TextA ($_ text/append "Asks whether a JSON value is a " <desc> "."))}
+     (-> <type> (Reader Bool))
+     (do p;Monad<Parser>
+       [head any]
+       (case head
+         (<tag> value)
+         (wrap (:: <eq> = test (<pre> value)))
+
+         _
+         (fail ($_ text/append "JSON value is not " <desc> ".")))))
+
+   (def: #export (<check> test)
+     {#;doc (#;TextA ($_ text/append "Ensures a JSON value is a " <desc> "."))}
+     (-> <type> (Reader Unit))
+     (do p;Monad<Parser>
+       [head any]
+       (case head
+         (<tag> value)
+         (let [value (<pre> value)]
+           (if (:: <eq> = test value)
+             (wrap [])
+             (fail ($_ text/append "Value mismatch: " (<encoder> test) "=/=" (<encoder> value)))))
+
+         _
+         (fail ($_ text/append "JSON value is not a " <desc> ".")))))]
+
+  [boolean? boolean! Bool bool;Eq<Bool>   (:: bool;Codec<Text,Bool> encode)   #..;Boolean "boolean" id]
+  [number?  number!  Real number;Eq<Real> (:: number;Codec<Text,Real> encode) #..;Number  "number"  id]
+  [string?  string!  Text text;Eq<Text>   text;encode                         #..;String  "string"  id]
+  )
+
+(def: #export (nullable parser)
+  (All [a] (-> (Reader a) (Reader (Maybe a))))
+  (p;alt null
+         parser))
+
+(def: #export (array parser)
+  {#;doc "Parses a JSON array, assuming that every element can be parsed the same way."}
+  (All [a] (-> (Reader a) (Reader a)))
+  (do p;Monad<Parser>
+    [head any]
+    (case head
+      (#..;Array values)
+      (case (p;run (vector;to-list values) parser)
+        (#R;Error error)
+        (fail error)
+
+        (#R;Success [remainder output])
+        (case remainder
+          #;Nil
+          (wrap output)
+
+          _
+          (fail unconsumed-input-error)))
+
+      _
+      (fail "JSON value is not an array."))))
+
+(def: #export (object parser)
+  {#;doc "Parses a JSON object, assuming that every element can be parsed the same way."}
+  (All [a] (-> (Reader a) (Reader (d;Dict Text a))))
+  (do p;Monad<Parser>
+    [head any]
+    (case head
+      (#..;Object object)
+      (case (do R;Monad<Result>
+              []
+              (|> (d;entries object)
+                  (monad;map @ (function [[key val]]
+                                 (do @
+                                   [val (run val parser)]
+                                   (wrap [key val]))))
+                  (:: @ map (d;from-list text;Hash<Text>))))
+        (#R;Success table)
+        (wrap table)
+
+        (#R;Error error)
+        (fail error))
+
+      _
+      (fail "JSON value is not an array."))))
+
+(def: #export (field field-name parser)
+  {#;doc "Parses a field inside a JSON object."}
+  (All [a] (-> Text (Reader a) (Reader a)))
+  (do p;Monad<Parser>
+    [head any]
+    (case head
+      (#..;Object object)
+      (case (d;get field-name object)
+        (#;Some value)
+        (case (run value parser)
+          (#R;Success output)
+          (function [tail]
+            (#R;Success [(#;Cons (#..;Object (d;remove field-name object))
+                                 tail)
+                         output]))
+
+          (#R;Error error)
+          (fail error))
+
+        _
+        (fail ($_ text/append "JSON object does not have field \"" field-name "\".")))
+
+      _
+      (fail "JSON value is not an object."))))