From 036f3b68983381c6fd2c380f01011ddaf0d8021f Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 4 Sep 2017 21:16:42 -0400
Subject: - Simplified code for JSON format. - Moved JSON polytypism to the
 lux/macro/poly/* branch.

---
 stdlib/source/lux/data/format/json.lux        | 366 ++++++++++++++++++---
 stdlib/source/lux/data/format/json/codec.lux  | 439 --------------------------
 stdlib/source/lux/data/format/json/reader.lux | 177 -----------
 stdlib/source/lux/data/text/format.lux        |   5 +-
 stdlib/source/lux/macro/poly/json.lux         | 296 +++++++++++++++++
 5 files changed, 624 insertions(+), 659 deletions(-)
 delete mode 100644 stdlib/source/lux/data/format/json/codec.lux
 delete mode 100644 stdlib/source/lux/data/format/json/reader.lux
 create mode 100644 stdlib/source/lux/macro/poly/json.lux

(limited to 'stdlib/source')

diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index 847b5fa0f..097525b1d 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -1,10 +1,10 @@
-(;module: {#;doc "Functionality for generating and processing values in the JSON format.
+(;module: {#;doc "Functionality for reading and writing values in the JSON format.
 
                   For more information, please see: http://www.json.org/"}
   lux
   (lux (control functor
                 applicative
-                ["M" monad #+ do Monad]
+                [monad #+ do Monad]
                 [eq #+ Eq]
                 codec
                 ["p" parser "p/" Monad<Parser>])
@@ -26,7 +26,6 @@
        [type]
        ))
 
-## [Types]
 (do-template [<name> <type>]
   [(type: #export <name> <type>)]
 
@@ -55,7 +54,6 @@
   {#;doc "JSON reader."}
   (p;Parser (List JSON) a))
 
-## [Syntax]
 (syntax: #export (json token)
   {#;doc (doc "A simple way to produce JSON literals."
               (json true)
@@ -83,27 +81,22 @@
 
       [_ (#;Record pairs)]
       (do Monad<Lux>
-        [pairs' (M;map @
-                       (function [[slot value]]
-                         (case slot
-                           [_ (#;Text key-name)]
-                           (wrap (` [(~ (code;text key-name)) (~ (wrapper value))]))
-
-                           _
-                           (macro;fail "Wrong syntax for JSON object.")))
-                       pairs)]
+        [pairs' (monad;map @
+                           (function [[slot value]]
+                             (case slot
+                               [_ (#;Text key-name)]
+                               (wrap (` [(~ (code;text key-name)) (~ (wrapper value))]))
+
+                               _
+                               (macro;fail "Wrong syntax for JSON object.")))
+                           pairs)]
         (wrap (list (` (: JSON (#Object (d;from-list text;Hash<Text> (list (~@ pairs')))))))))
       
       _
       (wrap (list token))
       )))
 
-(def: #export null
-  {#;doc "The null JSON value."}
-  JSON
-  #Null)
-
-(def: #export (fields json)
+(def: #export (get-fields json)
   {#;doc "Get all the fields in a JSON object."}
   (-> JSON (R;Result (List String)))
   (case json
@@ -159,27 +152,6 @@
   [get-object  #Object  Object  "objects"]
   )
 
-(do-template [<name> <type> <tag> <desc>]
-  [(def: #export (<name> value)
-     {#;doc (#;TextA ($_ text/append "A JSON generator for " <desc> "."))}
-     (-> <type> JSON)
-     (<tag> value))]
-
-  [boolean Boolean #Boolean "booleans"]
-  [number  Number  #Number  "numbers"]
-  [string  String  #String  "strings"]
-  [array   Array   #Array   "arrays"]
-  [object  Object  #Object  "objects"]
-  )
-
-(def: #export (nullable writer)
-  {#;doc "Builds a JSON generator for potentially inexistent values."}
-  (All [a] (-> (-> a JSON) (-> (Maybe a) JSON)))
-  (function [elem]
-    (case elem
-      #;None         #Null
-      (#;Some value) (writer value))))
-
 (struct: #export _ (Eq JSON)
   (def: (= x y)
     (case [x y]
@@ -217,3 +189,317 @@
       
       _
       false)))
+
+############################################################
+############################################################
+############################################################
+
+(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  Frac #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!  Frac number;Eq<Frac> (:: number;Codec<Text,Frac> 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."))))
+
+############################################################
+############################################################
+############################################################
+
+(def: #hidden (show-null _) (-> Null Text) "null")
+(do-template [<name> <type> <codec>]
+  [(def: <name> (-> <type> Text) <codec>)]
+
+  [show-boolean Boolean (:: bool;Codec<Text,Bool> encode)]
+  [show-number  Number (:: number;Codec<Text,Frac> encode)]
+  [show-string  String text;encode])
+
+(def: (show-array show-json elems)
+  (-> (-> JSON Text) (-> Array Text))
+  ($_ text/append "["
+      (|> elems (Vector/map show-json) vector;to-list (text;join-with ","))
+      "]"))
+
+(def: (show-object show-json object)
+  (-> (-> JSON Text) (-> Object Text))
+  ($_ 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)
+  (case json
+    (^template [<tag> <show>]
+      (<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)])
+    ))
+
+(def: space~
+  (l;Lexer Text)
+  (l;some l;space))
+
+(def: data-sep
+  (l;Lexer [Text Unit Text])
+  ($_ p;seq space~ (l;this ",") space~))
+
+(def: null~
+  (l;Lexer Null)
+  (do p;Monad<Parser>
+    [_ (l;this "null")]
+    (wrap [])))
+
+(do-template [<name> <token> <value>]
+  [(def: <name>
+     (l;Lexer Boolean)
+     (do p;Monad<Parser>
+       [_ (l;this <token>)]
+       (wrap <value>)))]
+
+  [t~ "true"  true]
+  [f~ "false" false]
+  )
+
+(def: boolean~
+  (l;Lexer Boolean)
+  (p;either t~ f~))
+
+(def: number~
+  (l;Lexer Number)
+  (do p;Monad<Parser>
+    [signed? (l;this? "-")
+     digits (l;many l;decimal)
+     decimals (p;default "0"
+                (do @
+                  [_ (l;this ".")]
+                  (l;many l;decimal)))
+     exp (p;default ""
+           (do @
+             [mark (l;one-of "eE")
+              signed?' (l;this? "-")
+              offset (l;many l;decimal)]
+             (wrap ($_ text/append mark (if signed?' "-" "") offset))))]
+    (case (frac/decode ($_ text/append (if signed? "-" "") digits "." decimals exp))
+      (#R;Error message)
+      (p;fail message)
+      
+      (#R;Success value)
+      (wrap value))))
+
+(def: escaped~
+  (l;Lexer Text)
+  ($_ p;either
+      (p;after (l;this "\\t") (p/wrap "\t"))
+      (p;after (l;this "\\b") (p/wrap "\b"))
+      (p;after (l;this "\\n") (p/wrap "\n"))
+      (p;after (l;this "\\r") (p/wrap "\r"))
+      (p;after (l;this "\\f") (p/wrap "\f"))
+      (p;after (l;this "\\\"") (p/wrap "\""))
+      (p;after (l;this "\\\\") (p/wrap "\\"))))
+
+(def: string~
+  (l;Lexer String)
+  (<| (l;enclosed ["\"" "\""])
+      (loop [_ []])
+      (do p;Monad<Parser>
+        [chars (l;some (l;none-of "\\\""))
+         stop l;peek])
+      (if (text/= "\\" stop)
+        (do @
+          [escaped escaped~
+           next-chars (recur [])]
+          (wrap ($_ text/append chars escaped next-chars)))
+        (wrap chars))))
+
+(def: (kv~ json~)
+  (-> (-> Unit (l;Lexer JSON)) (l;Lexer [String JSON]))
+  (do p;Monad<Parser>
+    [key string~
+     _ space~
+     _ (l;this ":")
+     _ space~
+     value (json~ [])]
+    (wrap [key value])))
+
+(do-template [<name> <type> <open> <close> <elem-parser> <prep>]
+  [(def: (<name> json~)
+     (-> (-> Unit (l;Lexer JSON)) (l;Lexer <type>))
+     (do p;Monad<Parser>
+       [_ (l;this <open>)
+        _ space~
+        elems (p;sep-by data-sep <elem-parser>)
+        _ space~
+        _ (l;this <close>)]
+       (wrap (<prep> elems))))]
+
+  [array~  Array  "[" "]" (json~ [])  vector;from-list]
+  [object~ Object "{" "}" (kv~ json~) (d;from-list text;Hash<Text>)]
+  )
+
+(def: (json~' _)
+  (-> Unit (l;Lexer JSON))
+  ($_ p;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
+
+(struct: #export _ (Codec Text JSON)
+  (def: encode show-json)
+  (def: decode (function [input] (l;run input (json~' [])))))
diff --git a/stdlib/source/lux/data/format/json/codec.lux b/stdlib/source/lux/data/format/json/codec.lux
deleted file mode 100644
index 6fa1d566c..000000000
--- a/stdlib/source/lux/data/format/json/codec.lux
+++ /dev/null
@@ -1,439 +0,0 @@
-(;module: {#;doc "Codecs for values in the JSON format.
-
-                  For more information, please see: http://www.json.org/"}
-  lux
-  (lux (control functor
-                applicative
-                [monad #+ do Monad]
-                [eq #+ Eq]
-                codec
-                ["p" parser "p/" Monad<Parser>])
-       (data [bool]
-             [bit]
-             [text "text/" Eq<Text> Monoid<Text>]
-             (text ["l" lexer])
-             [number "frac/" Codec<Text,Frac> "nat/" Codec<Text,Nat>]
-             maybe
-             ["R" result]
-             [sum]
-             [product]
-             (coll [list "L/" Fold<List> Monad<List>]
-                   [vector #+ Vector vector "Vector/" Monad<Vector>]
-                   ["d" dict]))
-       (time ["i" instant]
-             ["du" duration]
-             ["da" date])
-       [macro #+ Monad<Lux> with-gensyms]
-       (macro ["s" syntax #+ syntax:]
-              [code]
-              [poly #+ poly:])
-       [type]
-       )
-  [.. #+ JSON]
-  [../reader])
-
-## [Values]
-(def: #hidden (show-null _) (-> ..;Null Text) "null")
-(do-template [<name> <type> <codec>]
-  [(def: <name> (-> <type> Text) <codec>)]
-
-  [show-boolean ..;Boolean (:: bool;Codec<Text,Bool> encode)]
-  [show-number  ..;Number (:: number;Codec<Text,Frac> encode)]
-  [show-string  ..;String text;encode])
-
-(def: (show-array show-json elems)
-  (-> (-> JSON Text) (-> ..;Array Text))
-  ($_ text/append "["
-      (|> elems (Vector/map show-json) vector;to-list (text;join-with ","))
-      "]"))
-
-(def: (show-object show-json object)
-  (-> (-> JSON Text) (-> ..;Object Text))
-  ($_ 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)
-  (case json
-    (^template [<tag> <show>]
-      (<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)])
-    ))
-
-(def: space~
-  (l;Lexer Text)
-  (l;some l;space))
-
-(def: data-sep
-  (l;Lexer [Text Unit Text])
-  ($_ p;seq space~ (l;this ",") space~))
-
-(def: null~
-  (l;Lexer ..;Null)
-  (do p;Monad<Parser>
-    [_ (l;this "null")]
-    (wrap [])))
-
-(do-template [<name> <token> <value>]
-  [(def: <name>
-     (l;Lexer ..;Boolean)
-     (do p;Monad<Parser>
-       [_ (l;this <token>)]
-       (wrap <value>)))]
-
-  [t~ "true"  true]
-  [f~ "false" false]
-  )
-
-(def: boolean~
-  (l;Lexer ..;Boolean)
-  (p;either t~ f~))
-
-(def: number~
-  (l;Lexer ..;Number)
-  (do p;Monad<Parser>
-    [signed? (l;this? "-")
-     digits (l;many l;decimal)
-     decimals (p;default "0"
-                (do @
-                  [_ (l;this ".")]
-                  (l;many l;decimal)))
-     exp (p;default ""
-           (do @
-             [mark (l;one-of "eE")
-              signed?' (l;this? "-")
-              offset (l;many l;decimal)]
-             (wrap ($_ text/append mark (if signed?' "-" "") offset))))]
-    (case (frac/decode ($_ text/append (if signed? "-" "") digits "." decimals exp))
-      (#R;Error message)
-      (p;fail message)
-      
-      (#R;Success value)
-      (wrap value))))
-
-(def: escaped~
-  (l;Lexer Text)
-  ($_ p;either
-      (p;after (l;this "\\t") (p/wrap "\t"))
-      (p;after (l;this "\\b") (p/wrap "\b"))
-      (p;after (l;this "\\n") (p/wrap "\n"))
-      (p;after (l;this "\\r") (p/wrap "\r"))
-      (p;after (l;this "\\f") (p/wrap "\f"))
-      (p;after (l;this "\\\"") (p/wrap "\""))
-      (p;after (l;this "\\\\") (p/wrap "\\"))))
-
-(def: string~
-  (l;Lexer ..;String)
-  (<| (l;enclosed ["\"" "\""])
-      (loop [_ []])
-      (do p;Monad<Parser>
-        [chars (l;some (l;none-of "\\\""))
-         stop l;peek])
-      (if (text/= "\\" stop)
-        (do @
-          [escaped escaped~
-           next-chars (recur [])]
-          (wrap ($_ text/append chars escaped next-chars)))
-        (wrap chars))))
-
-(def: (kv~ json~)
-  (-> (-> Unit (l;Lexer JSON)) (l;Lexer [..;String JSON]))
-  (do p;Monad<Parser>
-    [key string~
-     _ space~
-     _ (l;this ":")
-     _ space~
-     value (json~ [])]
-    (wrap [key value])))
-
-(do-template [<name> <type> <open> <close> <elem-parser> <prep>]
-  [(def: (<name> json~)
-     (-> (-> Unit (l;Lexer JSON)) (l;Lexer <type>))
-     (do p;Monad<Parser>
-       [_ (l;this <open>)
-        _ space~
-        elems (p;sep-by data-sep <elem-parser>)
-        _ space~
-        _ (l;this <close>)]
-       (wrap (<prep> elems))))]
-
-  [array~  ..;Array  "[" "]" (json~ [])  vector;from-list]
-  [object~ ..;Object "{" "}" (kv~ json~) (d;from-list text;Hash<Text>)]
-  )
-
-(def: (json~' _)
-  (-> Unit (l;Lexer JSON))
-  ($_ p;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
-
-(struct: #export _ (Codec Text JSON)
-  (def: encode show-json)
-  (def: decode (function [input] (l;run input (json~' [])))))
-
-## [Polytypism]
-(def: #hidden _map_
-  (All [a b] (-> (-> a b) (List a) (List b)))
-  L/map)
-
-(def: tag
-  (-> Nat Frac)
-  (|>. nat-to-int int-to-frac))
-
-(def: #hidden (rec-encode non-rec)
-  (All [a] (-> (-> (-> a JSON)
-                   (-> a JSON))
-               (-> a JSON)))
-  (function [input]
-    (non-rec (rec-encode non-rec) input)))
-
-(def: low-mask Nat (|> +1 (bit;shift-left +32) n.dec))
-(def: high-mask Nat (|> low-mask (bit;shift-left +32)))
-
-(struct: #hidden _ (Codec JSON Nat)
-  (def: (encode input)
-    (let [high (|> input (bit;and high-mask) (bit;unsigned-shift-right +32))
-          low (bit;and low-mask input)]
-      (..;array (vector (|> high nat-to-int int-to-frac #..;Number)
-                        (|> low nat-to-int int-to-frac #..;Number)))))
-  (def: (decode input)
-    (<| (../reader;run input)
-        (do p;Monad<Parser>
-          [high ../reader;number
-           low ../reader;number])
-        (wrap (n.+ (|> high frac-to-int int-to-nat (bit;shift-left +32))
-                   (|> low frac-to-int int-to-nat))))))
-
-(struct: #hidden _ (Codec JSON Int)
-  (def: encode (|>. int-to-nat (:: Codec<JSON,Nat> encode)))
-  (def: decode
-    (|>. (:: Codec<JSON,Nat> decode) (:: R;Functor<Result> map nat-to-int))))
-
-(poly: #hidden Codec<JSON,?>//encode
-  (with-expansions
-    [<basic> (do-template [<type> <matcher> <encoder>]
-               [(do @
-                  [_ <matcher>]
-                  (wrap (` (: (~ (@JSON//encode inputT))
-                              <encoder>))))]
-
-               [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)]
-               [Bool poly;bool ..;boolean]
-               [Nat  poly;nat  (:: ;;Codec<JSON,Nat> (~' encode))]
-               [Int  poly;int  (:: ;;Codec<JSON,Int> (~' encode))]
-               [Frac poly;frac ..;number]
-               [Text poly;text ..;string])
-     <time> (do-template [<type> <codec>]
-              [(do @
-                 [_ (poly;this <type>)]
-                 (wrap (` (: (~ (@JSON//encode inputT))
-                             (|>. (:: <codec> (~' encode)) ..;string)))))]
-
-              [du;Duration du;Codec<Text,Duration>]
-              [i;Instant   i;Codec<Text,Instant>]
-              [da;Date     da;Codec<Text,Date>]
-              [da;Day      da;Codec<Text,Day>]
-              [da;Month    da;Codec<Text,Month>])]
-    (do @
-      [*env* poly;env
-       #let [@JSON//encode (: (-> Type Code)
-                              (function [type]
-                                (` (-> (~ (poly;to-ast *env* type)) ..;JSON))))]
-       inputT poly;peek]
-      ($_ p;either
-          <basic>
-          <time>
-          (do @
-            [#let [g!key (code;local-symbol "\u0000key")
-                   g!val (code;local-symbol "\u0000val")]
-             [_ _ .val.] (poly;apply ($_ p;seq
-                                         (poly;this d;Dict)
-                                         poly;text
-                                         Codec<JSON,?>//encode))]
-            (wrap (` (: (~ (@JSON//encode inputT))
-                        (|>. d;entries
-                             (;;_map_ (function [[(~ g!key) (~ g!val)]]
-                                        [(~ g!key) ((~ .val.) (~ g!val))]))
-                             (d;from-list text;Hash<Text>)
-                             #..;Object)))))
-          (do @
-            [[_ .sub.] (poly;apply ($_ p;seq
-                                       (poly;this ;Maybe)
-                                       Codec<JSON,?>//encode))]
-            (wrap (` (: (~ (@JSON//encode inputT))
-                        (..;nullable (~ .sub.))))))
-          (do @
-            [[_ .sub.] (poly;apply ($_ p;seq
-                                       (poly;this ;List)
-                                       Codec<JSON,?>//encode))]
-            (wrap (` (: (~ (@JSON//encode inputT))
-                        (|>. (;;_map_ (~ .sub.)) vector;from-list ..;array)))))
-          (do @
-            [#let [g!input (code;local-symbol "\u0000input")]
-             members (poly;variant (p;many Codec<JSON,?>//encode))]
-            (wrap (` (: (~ (@JSON//encode inputT))
-                        (function [(~ g!input)]
-                          (case (~ g!input)
-                            (~@ (L/join (L/map (function [[tag g!encode]]
-                                                 (list (` ((~ (code;nat tag)) (~ g!input)))
-                                                       (` (..;json [(~ (code;frac (;;tag tag)))
-                                                                    ((~ g!encode) (~ g!input))]))))
-                                               (list;enumerate members))))))))))
-          (do @
-            [g!encoders (poly;tuple (p;many Codec<JSON,?>//encode))
-             #let [g!members (|> (list;size g!encoders) n.dec
-                                 (list;n.range +0)
-                                 (L/map (|>. nat/encode code;local-symbol)))]]
-            (wrap (` (: (~ (@JSON//encode inputT))
-                        (function [[(~@ g!members)]]
-                          (..;json [(~@ (L/map (function [[g!member g!encode]]
-                                                 (` ((~ g!encode) (~ g!member))))
-                                               (list;zip2 g!members g!encoders)))]))))))
-          ## Type recursion
-          (do @
-            [[selfC non-recC] (poly;recursive Codec<JSON,?>//encode)]
-            (wrap (` (: (~ (@JSON//encode inputT))
-                        (;;rec-encode (;function [(~ selfC)]
-                                        (~ non-recC)))))))
-          poly;recursive-self
-          ## Type applications
-          (do @
-            [partsC (poly;apply (p;many Codec<JSON,?>//encode))]
-            (wrap (` ((~@ partsC)))))
-          ## Polymorphism
-          (do @
-            [[funcC varsC bodyC] (poly;polymorphic Codec<JSON,?>//encode)]
-            (wrap (` (: (All [(~@ varsC)]
-                          (-> (~@ (L/map (function [varC] (` (->  (~ varC) ..;JSON)))
-                                         varsC))
-                              (-> ((~ (poly;to-ast *env* inputT)) (~@ varsC))
-                                  ..;JSON)))
-                        (function (~ funcC) [(~@ varsC)]
-                          (~ bodyC))))))
-          poly;bound
-          poly;recursive-call
-          ## If all else fails...
-          (p;fail (text/append "Cannot create JSON encoder for: " (type;to-text inputT)))
-          ))))
-
-(poly: #hidden Codec<JSON,?>//decode
-  (with-expansions
-    [<basic> (do-template [<type> <matcher> <decoder>]
-               [(do @
-                  [_ <matcher>]
-                  (wrap (` (: (~ (@JSON//decode inputT))
-                              <decoder>))))]
-
-               [Unit poly;unit ../reader;null]
-               [Bool poly;bool ../reader;boolean]
-               [Nat  poly;nat  (p;codec ;;Codec<JSON,Nat> ../reader;any)]
-               [Int  poly;int  (p;codec ;;Codec<JSON,Int> ../reader;any)]
-               [Frac poly;frac ../reader;number]
-               [Text poly;text ../reader;string])
-     <time> (do-template [<type> <codec>]
-              [(do @
-                 [_ (poly;this <type>)]
-                 (wrap (` (: (~ (@JSON//decode inputT))
-                             (p;codec <codec> ../reader;string)))))]
-
-              [du;Duration du;Codec<Text,Duration>]
-              [i;Instant   i;Codec<Text,Instant>]
-              [da;Date     da;Codec<Text,Date>]
-              [da;Day      da;Codec<Text,Day>]
-              [da;Month    da;Codec<Text,Month>])]
-    (do @
-      [*env* poly;env
-       #let [@JSON//decode (: (-> Type Code)
-                              (function [type]
-                                (` (..;Reader (~ (poly;to-ast *env* type))))))]
-       inputT poly;peek]
-      ($_ p;either
-          <basic>
-          <time>
-          (do @
-            [[_ _ valC] (poly;apply ($_ p;seq
-                                        (poly;this d;Dict)
-                                        poly;text
-                                        Codec<JSON,?>//decode))]
-            (wrap (` (: (~ (@JSON//decode inputT))
-                        (../reader;object (~ valC))))))
-          (do @
-            [[_ subC] (poly;apply (p;seq (poly;this ;Maybe)
-                                         Codec<JSON,?>//decode))]
-            (wrap (` (: (~ (@JSON//decode inputT))
-                        (../reader;nullable (~ subC))))))
-          (do @
-            [[_ subC] (poly;apply (p;seq (poly;this ;List)
-                                         Codec<JSON,?>//decode))]
-            (wrap (` (: (~ (@JSON//decode inputT))
-                        (../reader;array (p;some (~ subC)))))))
-          (do @
-            [members (poly;variant (p;many Codec<JSON,?>//decode))]
-            (wrap (` (: (~ (@JSON//decode inputT))
-                        ($_ p;alt
-                            (~@ (L/map (function [[tag memberC]]
-                                         (` (|> (~ memberC)
-                                                (p;after (../reader;number! (~ (code;frac (;;tag tag)))))
-                                                ../reader;array)))
-                                       (list;enumerate members))))))))
-          (do @
-            [g!decoders (poly;tuple (p;many Codec<JSON,?>//decode))]
-            (wrap (` (: (~ (@JSON//decode inputT))
-                        (../reader;array ($_ p;seq (~@ g!decoders)))))))
-          ## Type recursion
-          (do @
-            [[selfC bodyC] (poly;recursive Codec<JSON,?>//decode)]
-            (wrap (` (: (~ (@JSON//decode inputT))
-                        (p;rec (;function [(~ selfC)]
-                                 (~ bodyC)))))))
-          poly;recursive-self
-          ## Type applications
-          (do @
-            [[funcC argsC] (poly;apply (p;seq Codec<JSON,?>//decode (p;many Codec<JSON,?>//decode)))]
-            (wrap (` ((~ funcC) (~@ argsC)))))
-          ## Polymorphism
-          (do @
-            [[funcC varsC bodyC] (poly;polymorphic Codec<JSON,?>//decode)]
-            (wrap (` (: (All [(~@ varsC)]
-                          (-> (~@ (L/map (|>. (~) ..;Reader (`)) varsC))
-                              (..;Reader ((~ (poly;to-ast *env* inputT)) (~@ varsC)))))
-                        (function (~ funcC) [(~@ varsC)]
-                          (~ bodyC))))))
-          poly;bound
-          poly;recursive-call
-          ## If all else fails...
-          (p;fail (text/append "Cannot create JSON decoder for: " (type;to-text inputT)))
-          ))))
-
-(syntax: #export (Codec<JSON,?> inputT)
-  {#;doc (doc "A macro for automatically producing JSON codecs."
-              (type: Variant
-                (#Case0 Bool)
-                (#Case1 Text)
-                (#Case2 Frac))
-
-              (type: Record
-                {#unit Unit
-                 #bool Bool
-                 #frac Frac
-                 #text Text
-                 #maybe (Maybe Frac)
-                 #list (List Frac)
-                 #variant Variant
-                 #tuple [Bool Frac Text]
-                 #dict (Dict Text Frac)})
-
-              (derived: (Codec<JSON,?> Record)))}
-  (with-gensyms [g!inputs]
-    (wrap (list (` (: (Codec ..;JSON (~ inputT))
-                      (struct (def: (~' encode) (Codec<JSON,?>//encode (~ inputT)))
-                              (def: ((~' decode) (~ g!inputs)) (../reader;run (~ g!inputs) (Codec<JSON,?>//decode (~ inputT))))
-                              )))))))
diff --git a/stdlib/source/lux/data/format/json/reader.lux b/stdlib/source/lux/data/format/json/reader.lux
deleted file mode 100644
index 1b26d746d..000000000
--- a/stdlib/source/lux/data/format/json/reader.lux
+++ /dev/null
@@ -1,177 +0,0 @@
-(;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 "frac/" Codec<Text,Frac> "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  Frac #..;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!  Frac number;Eq<Frac> (:: number;Codec<Text,Frac> 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."))))
diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux
index db33bdc05..d24dbbf59 100644
--- a/stdlib/source/lux/data/text/format.lux
+++ b/stdlib/source/lux/data/text/format.lux
@@ -8,8 +8,7 @@
              [ident]
              (coll [list "L/" Monad<List>])
              (format [xml]
-                     [json]
-                     [json/codec]))
+                     [json]))
        (time [instant]
              [duration]
              [date])
@@ -51,7 +50,7 @@
   [%oct      Nat               (:: number;Octal@Codec<Text,Nat> encode)]
   [%hex      Nat               (:: number;Hex@Codec<Text,Nat> encode)]
   [%xml      xml;XML           (:: xml;Codec<Text,XML> encode)]
-  [%json     json;JSON         (:: json/codec;Codec<Text,JSON> encode)]
+  [%json     json;JSON         (:: json;Codec<Text,JSON> encode)]
   [%instant  instant;Instant   (:: instant;Codec<Text,Instant> encode)]
   [%duration duration;Duration (:: duration;Codec<Text,Duration> encode)]
   [%date     date;Date         (:: date;Codec<Text,Date> encode)]
diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux
new file mode 100644
index 000000000..2c87603d3
--- /dev/null
+++ b/stdlib/source/lux/macro/poly/json.lux
@@ -0,0 +1,296 @@
+(;module: {#;doc "Codecs for values in the JSON format."}
+  lux
+  (lux (control functor
+                applicative
+                [monad #+ do Monad]
+                [eq #+ Eq]
+                codec
+                ["p" parser "p/" Monad<Parser>])
+       (data [bool]
+             [bit]
+             [text "text/" Eq<Text> Monoid<Text>]
+             (text ["l" lexer])
+             [number "frac/" Codec<Text,Frac> "nat/" Codec<Text,Nat>]
+             maybe
+             ["R" result]
+             [sum]
+             [product]
+             (coll [list "L/" Fold<List> Monad<List>]
+                   [vector #+ Vector vector "Vector/" Monad<Vector>]
+                   ["d" dict])
+             (format [".." json #+ JSON]))
+       (time ["i" instant]
+             ["du" duration]
+             ["da" date])
+       [macro #+ Monad<Lux> with-gensyms]
+       (macro ["s" syntax #+ syntax:]
+              [code]
+              [poly #+ poly:])
+       [type]
+       ))
+
+(def: #hidden _map_
+  (All [a b] (-> (-> a b) (List a) (List b)))
+  L/map)
+
+(def: tag
+  (-> Nat Frac)
+  (|>. nat-to-int int-to-frac))
+
+(def: #hidden (rec-encode non-rec)
+  (All [a] (-> (-> (-> a JSON)
+                   (-> a JSON))
+               (-> a JSON)))
+  (function [input]
+    (non-rec (rec-encode non-rec) input)))
+
+(def: low-mask Nat (|> +1 (bit;shift-left +32) n.dec))
+(def: high-mask Nat (|> low-mask (bit;shift-left +32)))
+
+(struct: #hidden _ (Codec JSON Nat)
+  (def: (encode input)
+    (let [high (|> input (bit;and high-mask) (bit;unsigned-shift-right +32))
+          low (bit;and low-mask input)]
+      (#..;Array (vector (|> high nat-to-int int-to-frac #..;Number)
+                         (|> low nat-to-int int-to-frac #..;Number)))))
+  (def: (decode input)
+    (<| (..;run input)
+        (do p;Monad<Parser>
+          [high ..;number
+           low ..;number])
+        (wrap (n.+ (|> high frac-to-int int-to-nat (bit;shift-left +32))
+                   (|> low frac-to-int int-to-nat))))))
+
+(struct: #hidden _ (Codec JSON Int)
+  (def: encode (|>. int-to-nat (:: Codec<JSON,Nat> encode)))
+  (def: decode
+    (|>. (:: Codec<JSON,Nat> decode) (:: R;Functor<Result> map nat-to-int))))
+
+(def: #hidden (nullable writer)
+  {#;doc "Builds a JSON generator for potentially inexistent values."}
+  (All [a] (-> (-> a JSON) (-> (Maybe a) JSON)))
+  (function [elem]
+    (case elem
+      #;None         #..;Null
+      (#;Some value) (writer value))))
+
+(poly: #hidden Codec<JSON,?>//encode
+  (with-expansions
+    [<basic> (do-template [<type> <matcher> <encoder>]
+               [(do @
+                  [_ <matcher>]
+                  (wrap (` (: (~ (@JSON//encode inputT))
+                              <encoder>))))]
+
+               [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)]
+               [Bool poly;bool (|>. #..;Boolean)]
+               [Nat  poly;nat  (:: ;;Codec<JSON,Nat> (~' encode))]
+               [Int  poly;int  (:: ;;Codec<JSON,Int> (~' encode))]
+               [Frac poly;frac (|>. #..;Number)]
+               [Text poly;text (|>. #..;String)])
+     <time> (do-template [<type> <codec>]
+              [(do @
+                 [_ (poly;this <type>)]
+                 (wrap (` (: (~ (@JSON//encode inputT))
+                             (|>. (:: <codec> (~' encode)) ..;string)))))]
+
+              [du;Duration du;Codec<Text,Duration>]
+              [i;Instant   i;Codec<Text,Instant>]
+              [da;Date     da;Codec<Text,Date>]
+              [da;Day      da;Codec<Text,Day>]
+              [da;Month    da;Codec<Text,Month>])]
+    (do @
+      [*env* poly;env
+       #let [@JSON//encode (: (-> Type Code)
+                              (function [type]
+                                (` (-> (~ (poly;to-ast *env* type)) ..;JSON))))]
+       inputT poly;peek]
+      ($_ p;either
+          <basic>
+          <time>
+          (do @
+            [#let [g!key (code;local-symbol "\u0000key")
+                   g!val (code;local-symbol "\u0000val")]
+             [_ _ .val.] (poly;apply ($_ p;seq
+                                         (poly;this d;Dict)
+                                         poly;text
+                                         Codec<JSON,?>//encode))]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (|>. d;entries
+                             (;;_map_ (function [[(~ g!key) (~ g!val)]]
+                                        [(~ g!key) ((~ .val.) (~ g!val))]))
+                             (d;from-list text;Hash<Text>)
+                             #..;Object)))))
+          (do @
+            [[_ .sub.] (poly;apply ($_ p;seq
+                                       (poly;this ;Maybe)
+                                       Codec<JSON,?>//encode))]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (;;nullable (~ .sub.))))))
+          (do @
+            [[_ .sub.] (poly;apply ($_ p;seq
+                                       (poly;this ;List)
+                                       Codec<JSON,?>//encode))]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (|>. (;;_map_ (~ .sub.)) vector;from-list #..;Array)))))
+          (do @
+            [#let [g!input (code;local-symbol "\u0000input")]
+             members (poly;variant (p;many Codec<JSON,?>//encode))]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (function [(~ g!input)]
+                          (case (~ g!input)
+                            (~@ (L/join (L/map (function [[tag g!encode]]
+                                                 (list (` ((~ (code;nat tag)) (~ g!input)))
+                                                       (` (..;json [(~ (code;frac (;;tag tag)))
+                                                                    ((~ g!encode) (~ g!input))]))))
+                                               (list;enumerate members))))))))))
+          (do @
+            [g!encoders (poly;tuple (p;many Codec<JSON,?>//encode))
+             #let [g!members (|> (list;size g!encoders) n.dec
+                                 (list;n.range +0)
+                                 (L/map (|>. nat/encode code;local-symbol)))]]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (function [[(~@ g!members)]]
+                          (..;json [(~@ (L/map (function [[g!member g!encode]]
+                                                 (` ((~ g!encode) (~ g!member))))
+                                               (list;zip2 g!members g!encoders)))]))))))
+          ## Type recursion
+          (do @
+            [[selfC non-recC] (poly;recursive Codec<JSON,?>//encode)]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (;;rec-encode (;function [(~ selfC)]
+                                        (~ non-recC)))))))
+          poly;recursive-self
+          ## Type applications
+          (do @
+            [partsC (poly;apply (p;many Codec<JSON,?>//encode))]
+            (wrap (` ((~@ partsC)))))
+          ## Polymorphism
+          (do @
+            [[funcC varsC bodyC] (poly;polymorphic Codec<JSON,?>//encode)]
+            (wrap (` (: (All [(~@ varsC)]
+                          (-> (~@ (L/map (function [varC] (` (->  (~ varC) ..;JSON)))
+                                         varsC))
+                              (-> ((~ (poly;to-ast *env* inputT)) (~@ varsC))
+                                  ..;JSON)))
+                        (function (~ funcC) [(~@ varsC)]
+                          (~ bodyC))))))
+          poly;bound
+          poly;recursive-call
+          ## If all else fails...
+          (p;fail (text/append "Cannot create JSON encoder for: " (type;to-text inputT)))
+          ))))
+
+(poly: #hidden Codec<JSON,?>//decode
+  (with-expansions
+    [<basic> (do-template [<type> <matcher> <decoder>]
+               [(do @
+                  [_ <matcher>]
+                  (wrap (` (: (~ (@JSON//decode inputT))
+                              <decoder>))))]
+
+               [Unit poly;unit ..;null]
+               [Bool poly;bool ..;boolean]
+               [Nat  poly;nat  (p;codec ;;Codec<JSON,Nat> ..;any)]
+               [Int  poly;int  (p;codec ;;Codec<JSON,Int> ..;any)]
+               [Frac poly;frac ..;number]
+               [Text poly;text ..;string])
+     <time> (do-template [<type> <codec>]
+              [(do @
+                 [_ (poly;this <type>)]
+                 (wrap (` (: (~ (@JSON//decode inputT))
+                             (p;codec <codec> ..;string)))))]
+
+              [du;Duration du;Codec<Text,Duration>]
+              [i;Instant   i;Codec<Text,Instant>]
+              [da;Date     da;Codec<Text,Date>]
+              [da;Day      da;Codec<Text,Day>]
+              [da;Month    da;Codec<Text,Month>])]
+    (do @
+      [*env* poly;env
+       #let [@JSON//decode (: (-> Type Code)
+                              (function [type]
+                                (` (..;Reader (~ (poly;to-ast *env* type))))))]
+       inputT poly;peek]
+      ($_ p;either
+          <basic>
+          <time>
+          (do @
+            [[_ _ valC] (poly;apply ($_ p;seq
+                                        (poly;this d;Dict)
+                                        poly;text
+                                        Codec<JSON,?>//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        (..;object (~ valC))))))
+          (do @
+            [[_ subC] (poly;apply (p;seq (poly;this ;Maybe)
+                                         Codec<JSON,?>//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        (..;nullable (~ subC))))))
+          (do @
+            [[_ subC] (poly;apply (p;seq (poly;this ;List)
+                                         Codec<JSON,?>//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        (..;array (p;some (~ subC)))))))
+          (do @
+            [members (poly;variant (p;many Codec<JSON,?>//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        ($_ p;alt
+                            (~@ (L/map (function [[tag memberC]]
+                                         (` (|> (~ memberC)
+                                                (p;after (..;number! (~ (code;frac (;;tag tag)))))
+                                                ..;array)))
+                                       (list;enumerate members))))))))
+          (do @
+            [g!decoders (poly;tuple (p;many Codec<JSON,?>//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        (..;array ($_ p;seq (~@ g!decoders)))))))
+          ## Type recursion
+          (do @
+            [[selfC bodyC] (poly;recursive Codec<JSON,?>//decode)]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        (p;rec (;function [(~ selfC)]
+                                 (~ bodyC)))))))
+          poly;recursive-self
+          ## Type applications
+          (do @
+            [[funcC argsC] (poly;apply (p;seq Codec<JSON,?>//decode (p;many Codec<JSON,?>//decode)))]
+            (wrap (` ((~ funcC) (~@ argsC)))))
+          ## Polymorphism
+          (do @
+            [[funcC varsC bodyC] (poly;polymorphic Codec<JSON,?>//decode)]
+            (wrap (` (: (All [(~@ varsC)]
+                          (-> (~@ (L/map (|>. (~) ..;Reader (`)) varsC))
+                              (..;Reader ((~ (poly;to-ast *env* inputT)) (~@ varsC)))))
+                        (function (~ funcC) [(~@ varsC)]
+                          (~ bodyC))))))
+          poly;bound
+          poly;recursive-call
+          ## If all else fails...
+          (p;fail (text/append "Cannot create JSON decoder for: " (type;to-text inputT)))
+          ))))
+
+(syntax: #export (Codec<JSON,?> inputT)
+  {#;doc (doc "A macro for automatically producing JSON codecs."
+              (type: Variant
+                (#Case0 Bool)
+                (#Case1 Text)
+                (#Case2 Frac))
+
+              (type: Record
+                {#unit Unit
+                 #bool Bool
+                 #frac Frac
+                 #text Text
+                 #maybe (Maybe Frac)
+                 #list (List Frac)
+                 #variant Variant
+                 #tuple [Bool Frac Text]
+                 #dict (Dict Text Frac)})
+
+              (derived: (Codec<JSON,?> Record)))}
+  (with-gensyms [g!inputs]
+    (wrap (list (` (: (Codec ..;JSON (~ inputT))
+                      (struct (def: (~' encode) (Codec<JSON,?>//encode (~ inputT)))
+                              (def: ((~' decode) (~ g!inputs)) (..;run (~ g!inputs) (Codec<JSON,?>//decode (~ inputT))))
+                              )))))))
-- 
cgit v1.2.3