Moved the JSON parser under "lux/control/parser/".

5 files changed, 256 insertions, 244 deletions

diff --git a/stdlib/source/lux/control/parser/json.lux b/stdlib/source/lux/control/parser/json.lux
new file mode 100644
index 000000000..cf3d308db
--- /dev/null
+++ b/stdlib/source/lux/control/parser/json.lux
@@ -0,0 +1,201 @@
+(.module:
+  [lux #*
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["." exception (#+ exception:)]]
+   [data
+    ["." bit]
+    ["." error (#+ Error)]
+    ["." text ("#@." equivalence monoid)]
+    [number
+     ["." frac]]
+    [collection
+     ["." list ("#@." functor)]
+     ["." row]
+     ["." dictionary (#+ Dictionary)]]
+    [format
+     ["/" json (#+ JSON)]]]
+   [macro
+    ["." code]]]
+  ["." // ("#@." functor)])
+
+(type: #export (Parser a)
+  {#.doc "JSON parser."}
+  (//.Parser (List JSON) a))
+
+(exception: #export (unconsumed-input {input (List JSON)})
+  (exception.report
+   ["Input" (exception.enumerate /.format input)]))
+
+(exception: #export empty-input)
+
+(def: #export (run json parser)
+  (All [a] (-> JSON (Parser a) (Error a)))
+  (case (//.run (list json) parser)
+    (#error.Success [remainder output])
+    (case remainder
+      #.Nil
+      (#error.Success output)
+
+      _
+      (exception.throw unconsumed-input remainder))
+    
+    (#error.Failure error)
+    (#error.Failure error)))
+
+(def: #export (fail error)
+  (All [a] (-> Text (Parser a)))
+  (function (_ inputs)
+    (#error.Failure error)))
+
+(def: #export any
+  {#.doc "Just returns the JSON input without applying any logic."}
+  (Parser JSON)
+  (<| (function (_ inputs))
+      (case inputs
+        #.Nil
+        (exception.throw empty-input [])
+        
+        (#.Cons head tail)
+        (#error.Success [tail head]))))
+
+(template [<name> <type> <tag> <desc>]
+  [(def: #export <name>
+     {#.doc (code.text ($_ text@compose "Reads a JSON value as " <desc> "."))}
+     (Parser <type>)
+     (do //.monad
+       [head any]
+       (case head
+         (<tag> value)
+         (wrap value)
+
+         _
+         (fail ($_ text@compose "JSON value is not " <desc> ".")))))]
+
+  [null    Any  #/.Null    "null"]
+  [boolean Bit  #/.Boolean "boolean"]
+  [number  Frac #/.Number  "number"]
+  [string  Text #/.String  "string"]
+  )
+
+(template [<test> <check> <type> <eq> <encoder> <tag> <desc>]
+  [(def: #export (<test> test)
+     {#.doc (code.text ($_ text@compose "Asks whether a JSON value is a " <desc> "."))}
+     (-> <type> (Parser Bit))
+     (do //.monad
+       [head any]
+       (case head
+         (<tag> value)
+         (wrap (:: <eq> = test value))
+
+         _
+         (fail ($_ text@compose "JSON value is not " <desc> ".")))))
+
+   (def: #export (<check> test)
+     {#.doc (code.text ($_ text@compose "Ensures a JSON value is a " <desc> "."))}
+     (-> <type> (Parser Any))
+     (do //.monad
+       [head any]
+       (case head
+         (<tag> value)
+         (if (:: <eq> = test value)
+           (wrap [])
+           (fail ($_ text@compose "Value mismatch: " (|> test <encoder>) " =/= " (|> value <encoder>))))
+
+         _
+         (fail ($_ text@compose "JSON value is not a " <desc> ".")))))]
+
+  [boolean? boolean! Bit  bit.equivalence  (<| /.format #/.Boolean) #/.Boolean "boolean"]
+  [number?  number!  Frac frac.equivalence (:: frac.decimal encode) #/.Number  "number"]
+  [string?  string!  Text text.equivalence text.encode              #/.String  "string"]
+  )
+
+(def: #export (nullable parser)
+  (All [a] (-> (Parser a) (Parser (Maybe a))))
+  (//.or null
+         parser))
+
+(def: #export (array parser)
+  {#.doc "Parses a JSON array."}
+  (All [a] (-> (Parser a) (Parser a)))
+  (do //.monad
+    [head any]
+    (case head
+      (#/.Array values)
+      (case (//.run (row.to-list values) parser)
+        (#error.Failure error)
+        (fail error)
+
+        (#error.Success [remainder output])
+        (case remainder
+          #.Nil
+          (wrap output)
+
+          _
+          (fail (exception.construct unconsumed-input remainder))))
+
+      _
+      (fail (text@compose "JSON value is not an array: " (/.format head))))))
+
+(def: #export (object parser)
+  {#.doc "Parses a JSON object. Use this with the 'field' combinator."}
+  (All [a] (-> (Parser a) (Parser a)))
+  (do //.monad
+    [head any]
+    (case head
+      (#/.Object kvs)
+      (case (//.run (|> kvs
+                        dictionary.entries
+                        (list@map (function (_ [key value])
+                                    (list (#/.String key) value)))
+                        list.concat)
+                    parser)
+        (#error.Failure error)
+        (fail error)
+
+        (#error.Success [remainder output])
+        (case remainder
+          #.Nil
+          (wrap output)
+
+          _
+          (fail (exception.construct unconsumed-input remainder))))
+      
+      _
+      (fail (text@compose "JSON value is not an object: " (/.format head))))))
+
+(def: #export (field field-name parser)
+  {#.doc "Parses a field inside a JSON object. Use this inside the 'object' combinator."}
+  (All [a] (-> Text (Parser a) (Parser a)))
+  (function (recur inputs)
+    (case inputs
+      (^ (list& (#/.String key) value inputs'))
+      (if (text@= key field-name)
+        (case (//.run (list value) parser)
+          (#error.Success [#.Nil output])
+          (#error.Success [inputs' output])
+
+          (#error.Success [inputs'' _])
+          (exception.throw unconsumed-input inputs'')
+
+          (#error.Failure error)
+          (#error.Failure error))
+        (do error.monad
+          [[inputs'' output] (recur inputs')]
+          (wrap [(list& (#/.String key) value inputs'')
+                 output])))
+
+      #.Nil
+      (exception.throw empty-input [])
+
+      _
+      (exception.throw unconsumed-input inputs))))
+
+(def: #export dictionary
+  {#.doc "Parses a dictionary-like JSON object."}
+  (All [a] (-> (Parser a) (Parser (Dictionary Text a))))
+  (|>> (//.and ..string)
+       //.some
+       object
+       (//@map (dictionary.from-list text.hash))))
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index 162cf8387..417db04b6 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -2,25 +2,23 @@
                        "For more information, please see: http://www.json.org/")}
   [lux #*
    [abstract
-    ["." monad (#+ Monad do)]
+    ["." monad (#+ do)]
     [equivalence (#+ Equivalence)]
     codec]
    [control
     pipe
     ["p" parser ("#@." monad)
-     ["l" text (#+ Parser)]]
-    ["ex" exception (#+ exception:)]]
+     ["l" text (#+ Parser)]]]
    [data
     ["." bit]
     ["." maybe]
     ["." error (#+ Error)]
-    ["." sum]
     ["." product]
     [number
      ["." frac ("#@." decimal)]]
     ["." text ("#@." equivalence monoid)]
     [collection
-     ["." list ("#@." fold monad)]
+     ["." list ("#@." fold functor)]
      ["." row (#+ Row row) ("#@." monad)]
      ["." dictionary (#+ Dictionary)]]]
    ["." macro (#+ monad with-gensyms)
@@ -51,10 +49,6 @@
   [Object  (Dictionary String JSON)]
   )
 
-(type: #export (Reader a)
-  {#.doc "JSON reader."}
-  (p.Parser (List JSON) a))
-
 (syntax: #export (json token)
   {#.doc (doc "A simple way to produce JSON literals."
               (json #1)
@@ -194,14 +188,16 @@
 ############################################################
 ############################################################
 
-(def: encode-boolean
-  (-> Bit Text)
+(def: (format-null _) (-> Null Text) "null")
+
+(def: format-boolean
+  (-> Boolean Text)
   (|>> (case>
         #0 "false"
         #1 "true")))
 
-(def: encode-number
-  (-> Frac Text)
+(def: format-number
+  (-> Number Text)
   (|>> (case>
         +0.0 "0.0"
         -0.0 "0.0"
@@ -210,231 +206,41 @@
                   raw
                   (|> raw (text.split 1) maybe.assume product.right))))))
 
-(def: (show-null _) (-> Null Text) "null")
-
-(template [<name> <type> <codec>]
-  [(def: <name> (-> <type> Text) <codec>)]
-
-  [show-boolean Boolean ..encode-boolean]
-  [show-number  Number  ..encode-number]
-  [show-string  String  text.encode]
-  )
+(def: format-string (-> String Text) text.encode)
 
-(def: (show-array show-json elems)
+(def: (format-array format elems)
   (-> (-> JSON Text) (-> Array Text))
   ($_ text@compose "["
-      (|> elems (row@map show-json) row.to-list (text.join-with ","))
+      (|> elems (row@map format) row.to-list (text.join-with ","))
       "]"))
 
-(def: (show-object show-json object)
+(def: (format-object format object)
   (-> (-> JSON Text) (-> Object Text))
   ($_ text@compose "{"
       (|> object
           dictionary.entries
-          (list@map (function (_ [key value]) ($_ text@compose (show-string key) ":" (show-json value))))
+          (list@map (function (_ [key value]) ($_ text@compose (format-string key) ":" (format value))))
           (text.join-with ","))
       "}"))
 
-(def: (show-json json)
+(def: #export (format json)
   (-> JSON Text)
   (case json
-    (^template [<tag> <show>]
+    (^template [<tag> <format>]
       (<tag> value)
-      (<show> value))
-    ([#Null    show-null]
-     [#Boolean show-boolean]
-     [#Number  show-number]
-     [#String  show-string]
-     [#Array   (show-array show-json)]
-     [#Object  (show-object show-json)])
+      (<format> value))
+    ([#Null    format-null]
+     [#Boolean format-boolean]
+     [#Number  format-number]
+     [#String  format-string]
+     [#Array   (format-array format)]
+     [#Object  (format-object format)])
     ))
 
 ############################################################
 ############################################################
 ############################################################
 
-(exception: #export (unconsumed-input {input (List JSON)})
-  (|> input
-      (list@map show-json)
-      (text.join-with text.new-line)))
-
-(exception: #export (empty-input)
-  "")
-
-(def: #export (run json parser)
-  (All [a] (-> JSON (Reader a) (Error a)))
-  (case (p.run (list json) parser)
-    (#error.Success [remainder output])
-    (case remainder
-      #.Nil
-      (#error.Success output)
-
-      _
-      (ex.throw unconsumed-input remainder))
-    
-    (#error.Failure error)
-    (#error.Failure error)))
-
-(def: #export (fail error)
-  (All [a] (-> Text (Reader a)))
-  (function (_ inputs)
-    (#error.Failure error)))
-
-(def: #export any
-  {#.doc "Just returns the JSON input without applying any logic."}
-  (Reader JSON)
-  (<| (function (_ inputs))
-      (case inputs
-        #.Nil
-        (ex.throw empty-input [])
-        
-        (#.Cons head tail)
-        (#error.Success [tail head]))))
-
-(template [<name> <type> <tag> <desc>]
-  [(def: #export <name>
-     {#.doc (code.text ($_ text@compose "Reads a JSON value as " <desc> "."))}
-     (Reader <type>)
-     (do p.monad
-       [head any]
-       (case head
-         (<tag> value)
-         (wrap value)
-
-         _
-         (fail ($_ text@compose "JSON value is not " <desc> ".")))))]
-
-  [null    Any  #Null    "null"]
-  [boolean Bit  #Boolean "boolean"]
-  [number  Frac #Number  "number"]
-  [string  Text #String  "string"]
-  )
-
-(template [<test> <check> <type> <eq> <encoder> <tag> <desc>]
-  [(def: #export (<test> test)
-     {#.doc (code.text ($_ text@compose "Asks whether a JSON value is a " <desc> "."))}
-     (-> <type> (Reader Bit))
-     (do p.monad
-       [head any]
-       (case head
-         (<tag> value)
-         (wrap (:: <eq> = test value))
-
-         _
-         (fail ($_ text@compose "JSON value is not " <desc> ".")))))
-
-   (def: #export (<check> test)
-     {#.doc (code.text ($_ text@compose "Ensures a JSON value is a " <desc> "."))}
-     (-> <type> (Reader Any))
-     (do p.monad
-       [head any]
-       (case head
-         (<tag> value)
-         (if (:: <eq> = test value)
-           (wrap [])
-           (fail ($_ text@compose "Value mismatch: " (<encoder> test) " =/= " (<encoder> value))))
-
-         _
-         (fail ($_ text@compose "JSON value is not a " <desc> ".")))))]
-
-  [boolean? boolean! Bit  bit.equivalence  encode-boolean           #Boolean "boolean"]
-  [number?  number!  Frac frac.equivalence (:: frac.decimal encode) #Number  "number"]
-  [string?  string!  Text text.equivalence text.encode              #String  "string"]
-  )
-
-(def: #export (nullable parser)
-  (All [a] (-> (Reader a) (Reader (Maybe a))))
-  (p.or null
-        parser))
-
-(def: #export (array parser)
-  {#.doc "Parses a JSON array."}
-  (All [a] (-> (Reader a) (Reader a)))
-  (do p.monad
-    [head any]
-    (case head
-      (#Array values)
-      (case (p.run (row.to-list values) parser)
-        (#error.Failure error)
-        (fail error)
-
-        (#error.Success [remainder output])
-        (case remainder
-          #.Nil
-          (wrap output)
-
-          _
-          (fail (ex.construct unconsumed-input remainder))))
-
-      _
-      (fail (text@compose "JSON value is not an array: " (show-json head))))))
-
-(def: #export (object parser)
-  {#.doc "Parses a JSON object. Use this with the 'field' combinator."}
-  (All [a] (-> (Reader a) (Reader a)))
-  (do p.monad
-    [head any]
-    (case head
-      (#Object kvs)
-      (case (p.run (|> kvs
-                       dictionary.entries
-                       (list@map (function (_ [key value])
-                                   (list (#String key) value)))
-                       list.concat)
-                   parser)
-        (#error.Failure error)
-        (fail error)
-
-        (#error.Success [remainder output])
-        (case remainder
-          #.Nil
-          (wrap output)
-
-          _
-          (fail (ex.construct unconsumed-input remainder))))
-      
-      _
-      (fail (text@compose "JSON value is not an object: " (show-json head))))))
-
-(def: #export (field field-name parser)
-  {#.doc "Parses a field inside a JSON object. Use this inside the 'object' combinator."}
-  (All [a] (-> Text (Reader a) (Reader a)))
-  (function (recur inputs)
-    (case inputs
-      (^ (list& (#String key) value inputs'))
-      (if (text@= key field-name)
-        (case (p.run (list value) parser)
-          (#error.Success [#.Nil output])
-          (#error.Success [inputs' output])
-
-          (#error.Success [inputs'' _])
-          (ex.throw unconsumed-input inputs'')
-
-          (#error.Failure error)
-          (#error.Failure error))
-        (do error.monad
-          [[inputs'' output] (recur inputs')]
-          (wrap [(list& (#String key) value inputs'')
-                 output])))
-
-      #.Nil
-      (ex.throw empty-input [])
-
-      _
-      (ex.throw unconsumed-input inputs))))
-
-(def: #export dictionary
-  {#.doc "Parses a dictionary-like JSON object."}
-  (All [a] (-> (Reader a) (Reader (Dictionary Text a))))
-  (|>> (p.and ..string)
-       p.some
-       object
-       (p@map (dictionary.from-list text.hash))))
-
-############################################################
-############################################################
-############################################################
-
 (def: space~
   (Parser Text)
   (l.some l.space))
@@ -548,5 +354,5 @@
   ($_ p.or null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
 
 (structure: #export codec (Codec Text JSON)
-  (def: encode show-json)
+  (def: encode ..format)
   (def: decode (function (_ input) (l.run input (json~' [])))))
diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux
index 1253ec328..f30c26437 100644
--- a/stdlib/source/lux/macro/poly/json.lux
+++ b/stdlib/source/lux/macro/poly/json.lux
@@ -7,6 +7,7 @@
    [control
     ["p" parser
      ["<.>" type]
+     ["</>" json]
      ["l" text]]]
    [data
     ["." bit]
@@ -60,11 +61,11 @@
       (#/.Array (row (|> high .int int-to-frac #/.Number)
                      (|> low .int int-to-frac #/.Number)))))
   (def: (decode input)
-    (<| (/.run input)
-        /.array
+    (<| (</>.run input)
+        </>.array
         (do p.monad
-          [high /.number
-           low /.number])
+          [high </>.number
+           low </>.number])
         (wrap (n/+ (|> high frac-to-int .nat (i64.left-shift 32))
                    (|> low frac-to-int .nat))))))
 
@@ -214,17 +215,17 @@
                   (wrap (` (: (~ (@JSON//decode inputT))
                               (~! <decoder>)))))]
 
-               [(<type>.exactly Any)  /.null]
-               [(<type>.sub Bit)      /.boolean]
-               [(<type>.sub Nat)      (p.codec ..nat-codec /.any)]
-               [(<type>.sub Int)      (p.codec ..int-codec /.any)]
-               [(<type>.sub Frac)     /.number]
-               [(<type>.sub Text)     /.string])
+               [(<type>.exactly Any)  </>.null]
+               [(<type>.sub Bit)      </>.boolean]
+               [(<type>.sub Nat)      (p.codec ..nat-codec </>.any)]
+               [(<type>.sub Int)      (p.codec ..int-codec </>.any)]
+               [(<type>.sub Frac)     </>.number]
+               [(<type>.sub Text)     </>.string])
      <time> (template [<type> <codec>]
               [(do @
                  [_ (<type>.exactly <type>)]
                  (wrap (` (: (~ (@JSON//decode inputT))
-                             ((~! p.codec) (~! <codec>) (~! /.string))))))]
+                             ((~! p.codec) (~! <codec>) (~! </>.string))))))]
 
               ## [duration.Duration duration.codec]
               ## [instant.Instant instant.codec]
@@ -236,7 +237,7 @@
       [*env* <type>.env
        #let [@JSON//decode (: (-> Type Code)
                               (function (_ type)
-                                (` (/.Reader (~ (poly.to-code *env* type))))))]
+                                (` (</>.Parser (~ (poly.to-code *env* type))))))]
        inputT <type>.peek]
       ($_ p.either
           <basic>
@@ -245,37 +246,37 @@
             [unitT (<type>.apply (p.after (<type>.exactly unit.Qty)
                                           <type>.any))]
             (wrap (` (: (~ (@JSON//decode inputT))
-                        ((~! p.codec) (~! qty-codec) (~! /.any))))))
+                        ((~! p.codec) (~! qty-codec) (~! </>.any))))))
           (do @
             [[_ _ valC] (<type>.apply ($_ p.and
                                           (<type>.exactly d.Dictionary)
                                           (<type>.exactly .Text)
                                           codec//decode))]
             (wrap (` (: (~ (@JSON//decode inputT))
-                        ((~! /.dictionary) (~ valC))))))
+                        ((~! </>.dictionary) (~ valC))))))
           (do @
             [[_ subC] (<type>.apply (p.and (<type>.exactly .Maybe)
                                            codec//decode))]
             (wrap (` (: (~ (@JSON//decode inputT))
-                        ((~! /.nullable) (~ subC))))))
+                        ((~! </>.nullable) (~ subC))))))
           (do @
             [[_ subC] (<type>.apply (p.and (<type>.exactly .List)
                                            codec//decode))]
             (wrap (` (: (~ (@JSON//decode inputT))
-                        ((~! /.array) ((~! p.some) (~ subC)))))))
+                        ((~! </>.array) ((~! p.some) (~ subC)))))))
           (do @
             [members (<type>.variant (p.many codec//decode))]
             (wrap (` (: (~ (@JSON//decode inputT))
                         ($_ ((~! p.or))
                             (~+ (list@map (function (_ [tag memberC])
                                             (` (|> (~ memberC)
-                                                   ((~! p.after) ((~! /.number!) (~ (code.frac (..tag tag)))))
-                                                   ((~! /.array)))))
+                                                   ((~! p.after) ((~! </>.number!) (~ (code.frac (..tag tag)))))
+                                                   ((~! </>.array)))))
                                           (list.enumerate members))))))))
           (do @
             [g!decoders (<type>.tuple (p.many codec//decode))]
             (wrap (` (: (~ (@JSON//decode inputT))
-                        ((~! /.array) ($_ ((~! p.and)) (~+ g!decoders)))))))
+                        ((~! </>.array) ($_ ((~! p.and)) (~+ g!decoders)))))))
           ## Type recursion
           (do @
             [[selfC bodyC] (<type>.recursive codec//decode)
@@ -292,8 +293,8 @@
           (do @
             [[funcC varsC bodyC] (<type>.polymorphic codec//decode)]
             (wrap (` (: (All [(~+ varsC)]
-                          (-> (~+ (list@map (|>> (~) /.Reader (`)) varsC))
-                              (/.Reader ((~ (poly.to-code *env* inputT)) (~+ varsC)))))
+                          (-> (~+ (list@map (|>> (~) </>.Parser (`)) varsC))
+                              (</>.Parser ((~ (poly.to-code *env* inputT)) (~+ varsC)))))
                         (function ((~ funcC) (~+ varsC))
                           (~ bodyC))))))
           <type>.parameter
@@ -325,6 +326,6 @@
                       (structure (def: (~' encode)
                                    (..codec//encode (~ inputT)))
                                  (def: ((~' decode) (~ g!inputs))
-                                   ((~! /.run) (~ g!inputs)
+                                   ((~! </>.run) (~ g!inputs)
                                     (..codec//decode (~ inputT))))
                                  )))))))
diff --git a/stdlib/source/lux/world/net/http/request.lux b/stdlib/source/lux/world/net/http/request.lux
index e13ae884d..15f3f33e3 100644
--- a/stdlib/source/lux/world/net/http/request.lux
+++ b/stdlib/source/lux/world/net/http/request.lux
@@ -5,7 +5,9 @@
     ["." monad (#+ do)]
     [concurrency
      ["." promise (#+ Promise)]
-     ["." frp]]]
+     ["." frp]]
+    [parser
+     ["<.>" json]]]
    [data
     ["." maybe]
     ["." error (#+ Error)]
@@ -49,7 +51,7 @@
 (def: failure (//response.bad-request ""))
 
 (def: #export (json reader server)
-  (All [a] (-> (json.Reader a) (-> a Server) Server))
+  (All [a] (-> (<json>.Reader a) (-> a Server) Server))
   (function (_ (^@ request [identification protocol resource message]))
     (do promise.monad
       [?raw (read-text-body (get@ #//.body message))]
diff --git a/stdlib/source/test/lux/macro/poly/json.lux b/stdlib/source/test/lux/macro/poly/json.lux
index 1209aa90a..78ed58a9a 100644
--- a/stdlib/source/test/lux/macro/poly/json.lux
+++ b/stdlib/source/test/lux/macro/poly/json.lux
@@ -4,7 +4,7 @@
    ["_" test (#+ Test)]
    [abstract
     codec
-    [monad (#+ do Monad)]
+    [monad (#+ do)]
     [equivalence (#+ Equivalence)]
     {[0 #test]
      [/
@@ -12,7 +12,9 @@
       ["$." codec]]}]
    [control
     pipe
-    ["p" parser]]
+    ["p" parser
+     ## TODO: Get rid of this import ASAP
+     [json (#+)]]]
    [data
     ["." error]
     ["." bit]