From 0e2121dbec4f61dc1d9404deb9dd2b3f401ba4df Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sat, 7 Sep 2019 21:07:03 -0400
Subject: Moved polytypic code generators to their own branch.

---
 stdlib/source/poly/lux/abstract/equivalence.lux | 163 ++++++++++++
 stdlib/source/poly/lux/abstract/functor.lux     | 104 ++++++++
 stdlib/source/poly/lux/data/format/json.lux     | 333 ++++++++++++++++++++++++
 3 files changed, 600 insertions(+)
 create mode 100644 stdlib/source/poly/lux/abstract/equivalence.lux
 create mode 100644 stdlib/source/poly/lux/abstract/functor.lux
 create mode 100644 stdlib/source/poly/lux/data/format/json.lux

(limited to 'stdlib/source/poly')

diff --git a/stdlib/source/poly/lux/abstract/equivalence.lux b/stdlib/source/poly/lux/abstract/equivalence.lux
new file mode 100644
index 000000000..5ecdaf12a
--- /dev/null
+++ b/stdlib/source/poly/lux/abstract/equivalence.lux
@@ -0,0 +1,163 @@
+(.module:
+  [lux #*
+   [abstract
+    [monad (#+ Monad do)]]
+   [control
+    ["p" parser
+     ["<.>" type]
+     ["s" code (#+ Parser)]]]
+   [data
+    ["." product]
+    ["." bit]
+    ["." maybe]
+    [number
+     ["." nat ("#@." decimal)]
+     ["." int]
+     ["." rev]
+     ["." frac]]
+    ["." text ("#@." monoid)
+     ["%" format (#+ format)]]
+    [collection
+     ["." list ("#@." monad)]
+     ["." row]
+     ["." array]
+     ["." queue]
+     ["." set]
+     ["." dictionary (#+ Dictionary)]
+     ["." tree]]]
+   [time
+    ["." duration]
+    ["." date]
+    ["." instant]
+    ["." day]
+    ["." month]]
+   ["." macro
+    ["." code]
+    [syntax (#+ syntax:)
+     ["." common]]
+    ["." poly (#+ poly:)]]
+   ["." type
+    ["." unit]]]
+  {1
+   ["." /]})
+
+(poly: #export equivalence
+  (`` (do @
+        [#let [g!_ (code.local-identifier "_____________")]
+         *env* <type>.env
+         inputT <type>.peek
+         #let [@Equivalence (: (-> Type Code)
+                               (function (_ type)
+                                 (` ((~! /.Equivalence) (~ (poly.to-code *env* type))))))]]
+        ($_ p.either
+            ## Basic types
+            (~~ (template [<matcher> <eq>]
+                  [(do @
+                     [_ <matcher>]
+                     (wrap (` (: (~ (@Equivalence inputT))
+                                 <eq>))))]
+
+                  [(<type>.exactly Any) (function ((~ g!_) (~ g!_) (~ g!_)) #1)]
+                  [(<type>.sub Bit)     (~! bit.equivalence)]
+                  [(<type>.sub Nat)     (~! nat.equivalence)]
+                  [(<type>.sub Int)     (~! int.equivalence)]
+                  [(<type>.sub Rev)     (~! rev.equivalence)]
+                  [(<type>.sub Frac)    (~! frac.equivalence)]
+                  [(<type>.sub Text)    (~! text.equivalence)]))
+            ## Composite types
+            (~~ (template [<name> <eq>]
+                  [(do @
+                     [[_ argC] (<type>.apply (p.and (<type>.exactly <name>)
+                                                    equivalence))]
+                     (wrap (` (: (~ (@Equivalence inputT))
+                                 (<eq> (~ argC))))))]
+
+                  [.Maybe      (~! maybe.equivalence)]
+                  [.List       (~! list.equivalence)]
+                  [row.Row     (~! row.equivalence)]
+                  [array.Array (~! array.equivalence)]
+                  [queue.Queue (~! queue.equivalence)]
+                  [set.Set     (~! set.equivalence)]
+                  [tree.Tree   (~! tree.equivalence)]
+                  ))
+            (do @
+              [[_ _ valC] (<type>.apply ($_ p.and
+                                            (<type>.exactly dictionary.Dictionary)
+                                            <type>.any
+                                            equivalence))]
+              (wrap (` (: (~ (@Equivalence inputT))
+                          ((~! dictionary.equivalence) (~ valC))))))
+            ## Models
+            (~~ (template [<type> <eq>]
+                  [(do @
+                     [_ (<type>.exactly <type>)]
+                     (wrap (` (: (~ (@Equivalence inputT))
+                                 <eq>))))]
+
+                  [duration.Duration duration.equivalence]
+                  [instant.Instant instant.equivalence]
+                  [date.Date date.equivalence]
+                  [day.Day day.equivalence]
+                  [month.Month month.equivalence]
+                  ))
+            (do @
+              [_ (<type>.apply (p.and (<type>.exactly unit.Qty)
+                                      <type>.any))]
+              (wrap (` (: (~ (@Equivalence inputT))
+                          unit.equivalence))))
+            ## Variants
+            (do @
+              [members (<type>.variant (p.many equivalence))
+               #let [g!_ (code.local-identifier "_____________")
+                     g!left (code.local-identifier "_____________left")
+                     g!right (code.local-identifier "_____________right")]]
+              (wrap (` (: (~ (@Equivalence inputT))
+                          (function ((~ g!_) (~ g!left) (~ g!right))
+                            (case [(~ g!left) (~ g!right)]
+                              (~+ (list@join (list@map (function (_ [tag g!eq])
+                                                         (list (` [((~ (code.nat tag)) (~ g!left))
+                                                                   ((~ (code.nat tag)) (~ g!right))])
+                                                               (` ((~ g!eq) (~ g!left) (~ g!right)))))
+                                                       (list.enumerate members))))
+                              (~ g!_)
+                              #0))))))
+            ## Tuples
+            (do @
+              [g!eqs (<type>.tuple (p.many equivalence))
+               #let [g!_ (code.local-identifier "_____________")
+                     indices (list.indices (list.size g!eqs))
+                     g!lefts (list@map (|>> nat@encode (text@compose "left") code.local-identifier) indices)
+                     g!rights (list@map (|>> nat@encode (text@compose "right") code.local-identifier) indices)]]
+              (wrap (` (: (~ (@Equivalence inputT))
+                          (function ((~ g!_) [(~+ g!lefts)] [(~+ g!rights)])
+                            (and (~+ (|> (list.zip3 g!eqs g!lefts g!rights)
+                                         (list@map (function (_ [g!eq g!left g!right])
+                                                     (` ((~ g!eq) (~ g!left) (~ g!right)))))))))))))
+            ## Type recursion
+            (do @
+              [[g!self bodyC] (<type>.recursive equivalence)
+               #let [g!_ (code.local-identifier "_____________")]]
+              (wrap (` (: (~ (@Equivalence inputT))
+                          ((~! /.rec) (.function ((~ g!_) (~ g!self))
+                                        (~ bodyC)))))))
+            <type>.recursive-self
+            ## Type applications
+            (do @
+              [[funcC argsC] (<type>.apply (p.and equivalence (p.many equivalence)))]
+              (wrap (` ((~ funcC) (~+ argsC)))))
+            ## Parameters
+            <type>.parameter
+            ## Polymorphism
+            (do @
+              [[funcC varsC bodyC] (<type>.polymorphic equivalence)]
+              (wrap (` (: (All [(~+ varsC)]
+                            (-> (~+ (list@map (|>> (~) ((~! /.Equivalence)) (`)) varsC))
+                                ((~! /.Equivalence) ((~ (poly.to-code *env* inputT)) (~+ varsC)))))
+                          (function ((~ funcC) (~+ varsC))
+                            (~ bodyC))))))
+            <type>.recursive-call
+            ## If all else fails...
+            (|> <type>.any
+                (:: @ map (|>> %.type (format "Cannot create Equivalence for: ") p.fail))
+                (:: @ join))
+            ))))
diff --git a/stdlib/source/poly/lux/abstract/functor.lux b/stdlib/source/poly/lux/abstract/functor.lux
new file mode 100644
index 000000000..747d3c811
--- /dev/null
+++ b/stdlib/source/poly/lux/abstract/functor.lux
@@ -0,0 +1,104 @@
+(.module:
+  [lux #*
+   [abstract
+    [monad (#+ Monad do)]]
+   [control
+    ["p" parser
+     ["<.>" type]
+     ["s" code (#+ Parser)]]]
+   [data
+    ["." product]
+    [number
+     ["n" nat]]
+    ["." text
+     ["%" format (#+ format)]]
+    [collection
+     ["." list ("#;." monad monoid)]]]
+   ["." macro
+    ["." code]
+    [syntax (#+ syntax:)
+     ["." common]]
+    ["." poly (#+ poly:)]]
+   ["." type]]
+  {1
+   ["." /]})
+
+(poly: #export functor
+  (do @
+    [#let [type-funcC (code.local-identifier "____________type-funcC")
+           funcC (code.local-identifier "____________funcC")
+           inputC (code.local-identifier "____________inputC")]
+     *env* <type>.env
+     inputT <type>.peek
+     [polyC varsC non-functorT] (<type>.local (list inputT)
+                                              (<type>.polymorphic <type>.any))
+     #let [num-vars (list.size varsC)]
+     #let [@Functor (: (-> Type Code)
+                       (function (_ unwrappedT)
+                         (if (n.= 1 num-vars)
+                           (` ((~! /.Functor) (~ (poly.to-code *env* unwrappedT))))
+                           (let [paramsC (|> num-vars dec list.indices (list;map (|>> %.nat code.local-identifier)))]
+                             (` (All [(~+ paramsC)]
+                                  ((~! /.Functor) ((~ (poly.to-code *env* unwrappedT)) (~+ paramsC)))))))))
+           Arg<?> (: (-> Code (<type>.Parser Code))
+                     (function (Arg<?> valueC)
+                       ($_ p.either
+                           ## Type-var
+                           (do p.monad
+                             [#let [varI (|> num-vars (n.* 2) dec)]
+                              _ (<type>.parameter! varI)]
+                             (wrap (` ((~ funcC) (~ valueC)))))
+                           ## Variants
+                           (do @
+                             [_ (wrap [])
+                              membersC (<type>.variant (p.many (Arg<?> valueC)))]
+                             (wrap (` (case (~ valueC)
+                                        (~+ (list;join (list;map (function (_ [tag memberC])
+                                                                   (list (` ((~ (code.nat tag)) (~ valueC)))
+                                                                         (` ((~ (code.nat tag)) (~ memberC)))))
+                                                                 (list.enumerate membersC))))))))
+                           ## Tuples
+                           (do p.monad
+                             [pairsCC (: (<type>.Parser (List [Code Code]))
+                                         (<type>.tuple (loop [idx 0
+                                                              pairsCC (: (List [Code Code])
+                                                                         (list))]
+                                                         (p.either (let [slotC (|> idx %.nat (format "____________slot") code.local-identifier)]
+                                                                     (do @
+                                                                       [_ (wrap [])
+                                                                        memberC (Arg<?> slotC)]
+                                                                       (recur (inc idx)
+                                                                              (list;compose pairsCC (list [slotC memberC])))))
+                                                                   (wrap pairsCC)))))]
+                             (wrap (` (case (~ valueC)
+                                        [(~+ (list;map product.left pairsCC))]
+                                        [(~+ (list;map product.right pairsCC))]))))
+                           ## Functions
+                           (do @
+                             [_ (wrap [])
+                              #let [g! (code.local-identifier "____________")
+                                    outL (code.local-identifier "____________outL")]
+                              [inT+ outC] (<type>.function (p.many <type>.any)
+                                            (Arg<?> outL))
+                              #let [inC+ (|> (list.size inT+)
+                                             list.indices
+                                             (list;map (|>> %.nat (format "____________inC") code.local-identifier)))]]
+                             (wrap (` (function ((~ g!) (~+ inC+))
+                                        (let [(~ outL) ((~ valueC) (~+ inC+))]
+                                          (~ outC))))))
+                           ## Recursion
+                           (do p.monad
+                             [_ <type>.recursive-call]
+                             (wrap (` ((~' map) (~ funcC) (~ valueC)))))
+                           ## Parameters
+                           (do p.monad
+                             [_ <type>.any]
+                             (wrap valueC))
+                           )))]
+     [_ _ outputC] (: (<type>.Parser [Code (List Code) Code])
+                      (p.either (<type>.polymorphic
+                                 (Arg<?> inputC))
+                                (p.fail (format "Cannot create Functor for: " (%.type inputT)))))]
+    (wrap (` (: (~ (@Functor inputT))
+                (structure (def: ((~' map) (~ funcC) (~ inputC))
+                             (~ outputC))))))))
diff --git a/stdlib/source/poly/lux/data/format/json.lux b/stdlib/source/poly/lux/data/format/json.lux
new file mode 100644
index 000000000..b8c43df31
--- /dev/null
+++ b/stdlib/source/poly/lux/data/format/json.lux
@@ -0,0 +1,333 @@
+(.module: {#.doc "Codecs for values in the JSON format."}
+  [lux #*
+   [abstract
+    [monad (#+ Monad do)]
+    [equivalence (#+ Equivalence)]
+    ["." codec]]
+   [control
+    ["e" try]
+    ["p" parser
+     ["<.>" type]
+     ["</>" json]
+     ["l" text]
+     ["s" code]]]
+   [data
+    ["." bit]
+    maybe
+    ["." sum]
+    ["." product]
+    [number
+     ["." i64]
+     ["n" nat ("#@." decimal)]
+     ["." int]
+     ["." frac ("#@." decimal)]]
+    ["." text ("#@." equivalence)
+     ["%" format (#+ format)]]
+    [collection
+     ["." list ("#@." fold monad)]
+     ["." row (#+ Row row) ("#@." monad)]
+     ["d" dictionary]]]
+   [time
+    ## ["." instant]
+    ## ["." duration]
+    ["." date]
+    ["." day]
+    ["." month]]
+   [macro (#+ with-gensyms)
+    [syntax (#+ syntax:)]
+    ["." code]
+    ["." poly (#+ poly:)]]
+   ["." type
+    ["." unit]]]
+  {1
+   ["." / (#+ JSON)]})
+
+(def: tag
+  (-> Nat Frac)
+  (|>> .int int.frac))
+
+(def: (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 (i64.left-shift 32) dec))
+(def: high-mask Nat (|> low-mask (i64.left-shift 32)))
+
+(structure: nat-codec (codec.Codec JSON Nat)
+  (def: (encode input)
+    (let [high (|> input (i64.and high-mask) (i64.logic-right-shift 32))
+          low (i64.and low-mask input)]
+      (#/.Array (row (|> high .int int.frac #/.Number)
+                     (|> low .int int.frac #/.Number)))))
+  (def: (decode input)
+    (<| (</>.run input)
+        </>.array
+        (do p.monad
+          [high </>.number
+           low </>.number])
+        (wrap (n.+ (|> high frac.int .nat (i64.left-shift 32))
+                   (|> low frac.int .nat))))))
+
+(structure: int-codec (codec.Codec JSON Int)
+  (def: encode (|>> .nat (:: nat-codec encode)))
+  (def: decode
+    (|>> (:: nat-codec decode) (:: e.functor map .int))))
+
+(def: (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))))
+
+(structure: qty-codec
+  (All [unit] (codec.Codec JSON (unit.Qty unit)))
+  
+  (def: encode
+    (|>> unit.out (:: ..int-codec encode)))
+  (def: decode
+    (|>> (:: ..int-codec decode) (:: e.functor map unit.in))))
+
+(poly: #export codec//encode
+  (with-expansions
+    [<basic> (template [<matcher> <encoder>]
+               [(do @
+                  [#let [g!_ (code.local-identifier "_______")]
+                   _ <matcher>]
+                  (wrap (` (: (~ (@JSON//encode inputT))
+                              <encoder>))))]
+
+               [(<type>.exactly Any) (function ((~ g!_) (~ (code.identifier ["" "0"]))) #/.Null)]
+               [(<type>.sub Bit)     (|>> #/.Boolean)]
+               [(<type>.sub Nat)     (:: (~! ..nat-codec) (~' encode))]
+               [(<type>.sub Int)     (:: (~! ..int-codec) (~' encode))]
+               [(<type>.sub Frac)    (|>> #/.Number)]
+               [(<type>.sub Text)    (|>> #/.String)])
+     <time> (template [<type> <codec>]
+              [(do @
+                 [_ (<type>.exactly <type>)]
+                 (wrap (` (: (~ (@JSON//encode inputT))
+                             (|>> (:: (~! <codec>) (~' encode)) #/.String)))))]
+
+              ## [duration.Duration duration.codec]
+              ## [instant.Instant instant.codec]
+              [date.Date date.codec]
+              [day.Day day.codec]
+              [month.Month month.codec])]
+    (do @
+      [*env* <type>.env
+       #let [@JSON//encode (: (-> Type Code)
+                              (function (_ type)
+                                (` (-> (~ (poly.to-code *env* type)) /.JSON))))]
+       inputT <type>.peek]
+      ($_ p.either
+          <basic>
+          <time>
+          (do @
+            [unitT (<type>.apply (p.after (<type>.exactly unit.Qty)
+                                          <type>.any))]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (:: (~! qty-codec) (~' encode))))))
+          (do @
+            [#let [g!_ (code.local-identifier "_______")
+                   g!key (code.local-identifier "_______key")
+                   g!val (code.local-identifier "_______val")]
+             [_ _ =val=] (<type>.apply ($_ p.and
+                                           (<type>.exactly d.Dictionary)
+                                           (<type>.exactly .Text)
+                                           codec//encode))]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (|>> ((~! d.entries))
+                             ((~! list@map) (function ((~ g!_) [(~ g!key) (~ g!val)])
+                                              [(~ g!key) ((~ =val=) (~ g!val))]))
+                             ((~! d.from-list) (~! text.hash))
+                             #/.Object)))))
+          (do @
+            [[_ =sub=] (<type>.apply ($_ p.and
+                                         (<type>.exactly .Maybe)
+                                         codec//encode))]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        ((~! ..nullable) (~ =sub=))))))
+          (do @
+            [[_ =sub=] (<type>.apply ($_ p.and
+                                         (<type>.exactly .List)
+                                         codec//encode))]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (|>> ((~! list@map) (~ =sub=)) ((~! row.from-list)) #/.Array)))))
+          (do @
+            [#let [g!_ (code.local-identifier "_______")
+                   g!input (code.local-identifier "_______input")]
+             members (<type>.variant (p.many codec//encode))]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (function ((~ g!_) (~ g!input))
+                          (case (~ g!input)
+                            (~+ (list@join (list@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 (<type>.tuple (p.many codec//encode))
+             #let [g!_ (code.local-identifier "_______")
+                   g!members (|> (list.size g!encoders)
+                                 list.indices
+                                 (list@map (|>> n@encode code.local-identifier)))]]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (function ((~ g!_) [(~+ g!members)])
+                          ((~! /.json) [(~+ (list@map (function (_ [g!member g!encode])
+                                                        (` ((~ g!encode) (~ g!member))))
+                                                      (list.zip2 g!members g!encoders)))]))))))
+          ## Type recursion
+          (do @
+            [[selfC non-recC] (<type>.recursive codec//encode)
+             #let [g! (code.local-identifier "____________")]]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        ((~! ..rec-encode) (.function ((~ g!) (~ selfC))
+                                             (~ non-recC)))))))
+          <type>.recursive-self
+          ## Type applications
+          (do @
+            [partsC (<type>.apply (p.many codec//encode))]
+            (wrap (` ((~+ partsC)))))
+          ## Polymorphism
+          (do @
+            [[funcC varsC bodyC] (<type>.polymorphic codec//encode)]
+            (wrap (` (: (All [(~+ varsC)]
+                          (-> (~+ (list@map (function (_ varC) (` (-> (~ varC) /.JSON)))
+                                            varsC))
+                              (-> ((~ (poly.to-code *env* inputT)) (~+ varsC))
+                                  /.JSON)))
+                        (function ((~ funcC) (~+ varsC))
+                          (~ bodyC))))))
+          <type>.parameter
+          <type>.recursive-call
+          ## If all else fails...
+          (p.fail (format "Cannot create JSON encoder for: " (type.to-text inputT)))
+          ))))
+
+(poly: #export codec//decode
+  (with-expansions
+    [<basic> (template [<matcher> <decoder>]
+               [(do @
+                  [_ <matcher>]
+                  (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])
+     <time> (template [<type> <codec>]
+              [(do @
+                 [_ (<type>.exactly <type>)]
+                 (wrap (` (: (~ (@JSON//decode inputT))
+                             ((~! p.codec) (~! <codec>) (~! </>.string))))))]
+
+              ## [duration.Duration duration.codec]
+              ## [instant.Instant instant.codec]
+              [date.Date date.codec]
+              [day.Day day.codec]
+              [month.Month month.codec])
+     ]
+    (do @
+      [*env* <type>.env
+       #let [@JSON//decode (: (-> Type Code)
+                              (function (_ type)
+                                (` (</>.Parser (~ (poly.to-code *env* type))))))]
+       inputT <type>.peek]
+      ($_ p.either
+          <basic>
+          <time>
+          (do @
+            [unitT (<type>.apply (p.after (<type>.exactly unit.Qty)
+                                          <type>.any))]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        ((~! 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))))))
+          (do @
+            [[_ subC] (<type>.apply (p.and (<type>.exactly .Maybe)
+                                           codec//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        ((~! </>.nullable) (~ subC))))))
+          (do @
+            [[_ subC] (<type>.apply (p.and (<type>.exactly .List)
+                                           codec//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        ((~! </>.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)))))
+                                          (list.enumerate members))))))))
+          (do @
+            [g!decoders (<type>.tuple (p.many codec//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        ((~! </>.array) ($_ ((~! p.and)) (~+ g!decoders)))))))
+          ## Type recursion
+          (do @
+            [[selfC bodyC] (<type>.recursive codec//decode)
+             #let [g! (code.local-identifier "____________")]]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        ((~! p.rec) (.function ((~ g!) (~ selfC))
+                                      (~ bodyC)))))))
+          <type>.recursive-self
+          ## Type applications
+          (do @
+            [[funcC argsC] (<type>.apply (p.and codec//decode (p.many codec//decode)))]
+            (wrap (` ((~ funcC) (~+ argsC)))))
+          ## Polymorphism
+          (do @
+            [[funcC varsC bodyC] (<type>.polymorphic codec//decode)]
+            (wrap (` (: (All [(~+ varsC)]
+                          (-> (~+ (list@map (|>> (~) </>.Parser (`)) varsC))
+                              (</>.Parser ((~ (poly.to-code *env* inputT)) (~+ varsC)))))
+                        (function ((~ funcC) (~+ varsC))
+                          (~ bodyC))))))
+          <type>.parameter
+          <type>.recursive-call
+          ## If all else fails...
+          (p.fail (format "Cannot create JSON decoder for: " (type.to-text inputT)))
+          ))))
+
+(syntax: #export (codec inputT)
+  {#.doc (doc "A macro for automatically producing JSON codecs."
+              (type: Variant
+                (#Bit Bit)
+                (#Text Text)
+                (#Frac Frac))
+
+              (type: Record
+                {#bit Bit
+                 #frac Frac
+                 #text Text
+                 #maybe (Maybe Frac)
+                 #list (List Frac)
+                 #variant Variant
+                 #tuple [Bit Frac Text]
+                 #dictionary (Dictionary Text Frac)})
+
+              (derived: (..codec Record)))}
+  (with-gensyms [g!inputs]
+    (wrap (list (` (: (codec.Codec /.JSON (~ inputT))
+                      (structure (def: (~' encode)
+                                   (..codec//encode (~ inputT)))
+                                 (def: ((~' decode) (~ g!inputs))
+                                   ((~! </>.run) (~ g!inputs)
+                                    (..codec//decode (~ inputT))))
+                                 )))))))
-- 
cgit v1.2.3