From 9c21fd1f33eb52fb971d493ad21a67036d68b841 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sun, 12 Jun 2022 02:29:28 -0400
Subject: Re-named the "poly" hierarchy to "polytypic".

---
 .../source/polytypic/lux/abstract/equivalence.lux  | 167 ++++++++++
 stdlib/source/polytypic/lux/abstract/functor.lux   | 110 +++++++
 stdlib/source/polytypic/lux/data/format/json.lux   | 335 +++++++++++++++++++++
 3 files changed, 612 insertions(+)
 create mode 100644 stdlib/source/polytypic/lux/abstract/equivalence.lux
 create mode 100644 stdlib/source/polytypic/lux/abstract/functor.lux
 create mode 100644 stdlib/source/polytypic/lux/data/format/json.lux

(limited to 'stdlib/source/polytypic')

diff --git a/stdlib/source/polytypic/lux/abstract/equivalence.lux b/stdlib/source/polytypic/lux/abstract/equivalence.lux
new file mode 100644
index 000000000..1e882e32d
--- /dev/null
+++ b/stdlib/source/polytypic/lux/abstract/equivalence.lux
@@ -0,0 +1,167 @@
+(.using
+ [library
+  [lux (.except)
+   [abstract
+    [monad (.only Monad do)]]
+   [control
+    ["[0]" maybe]
+    ["<>" parser (.only)
+     ["<[0]>" type]]]
+   [data
+    ["[0]" product]
+    ["[0]" bit]
+    ["[0]" text (.open: "[1]#[0]" monoid)
+     ["%" format (.only format)]]
+    [collection
+     ["[0]" list (.open: "[1]#[0]" monad)]
+     ["[0]" sequence]
+     ["[0]" array]
+     ["[0]" queue]
+     ["[0]" set]
+     ["[0]" dictionary (.only Dictionary)]
+     ["[0]" tree]]]
+   [macro
+    ["[0]" code]]
+   [math
+    [number
+     ["[0]" nat (.open: "[1]#[0]" decimal)]
+     ["[0]" int]
+     ["[0]" rev]
+     ["[0]" frac]]]
+   [time
+    ["[0]" duration]
+    ["[0]" date]
+    ["[0]" instant]
+    ["[0]" day]
+    ["[0]" month]]
+   ["[0]" type (.only)
+    ["[0]" poly (.only poly:)]
+    ["[0]" unit]]]]
+ [\\library
+  ["[0]" /]])
+
+(poly: .public equivalence
+  (`` (do [! <>.monad]
+        [.let [g!_ (code.local "_____________")]
+         *env* <type>.env
+         inputT <type>.next
+         .let [@Equivalence (is (-> Type Code)
+                                (function (_ type)
+                                  (` ((~! /.Equivalence) (~ (poly.code *env* type))))))]]
+        (all <>.either
+             ... Basic types
+             (~~ (with_template [<matcher> <eq>]
+                   [(do !
+                      [_ <matcher>]
+                      (in (` (is (~ (@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
+             (~~ (with_template [<name> <eq>]
+                   [(do !
+                      [[_ argC] (<type>.applied (<>.and (<type>.exactly <name>)
+                                                        equivalence))]
+                      (in (` (is (~ (@Equivalence inputT))
+                                 (<eq> (~ argC))))))]
+
+                   [.Maybe            (~! maybe.equivalence)]
+                   [.List             (~! list.equivalence)]
+                   [sequence.Sequence (~! sequence.equivalence)]
+                   [array.Array       (~! array.equivalence)]
+                   [queue.Queue       (~! queue.equivalence)]
+                   [set.Set           (~! set.equivalence)]
+                   [tree.Tree         (~! tree.equivalence)]
+                   ))
+             (do !
+               [[_ _ valC] (<type>.applied (all <>.and
+                                                (<type>.exactly dictionary.Dictionary)
+                                                <type>.any
+                                                equivalence))]
+               (in (` (is (~ (@Equivalence inputT))
+                          ((~! dictionary.equivalence) (~ valC))))))
+             ... Models
+             (~~ (with_template [<type> <eq>]
+                   [(do !
+                      [_ (<type>.exactly <type>)]
+                      (in (` (is (~ (@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>.applied (<>.and (<type>.exactly unit.Qty)
+                                          <type>.any))]
+               (in (` (is (~ (@Equivalence inputT))
+                          unit.equivalence))))
+             ... Variants
+             (do !
+               [members (<type>.variant (<>.many equivalence))
+                .let [last (-- (list.size members))
+                      g!_ (code.local "_____________")
+                      g!left (code.local "_____________left")
+                      g!right (code.local "_____________right")]]
+               (in (` (is (~ (@Equivalence inputT))
+                          (function ((~ g!_) (~ g!left) (~ g!right))
+                            (case [(~ g!left) (~ g!right)]
+                              (~+ (list#conjoint (list#each (function (_ [tag g!eq])
+                                                              (if (nat.= last tag)
+                                                                (list (` [{(~ (code.nat (-- tag))) #1 (~ g!left)}
+                                                                          {(~ (code.nat (-- tag))) #1 (~ g!right)}])
+                                                                      (` ((~ g!eq) (~ g!left) (~ g!right))))
+                                                                (list (` [{(~ (code.nat tag)) #0 (~ g!left)}
+                                                                          {(~ (code.nat tag)) #0 (~ g!right)}])
+                                                                      (` ((~ g!eq) (~ g!left) (~ g!right))))))
+                                                            (list.enumeration members))))
+                              (~ g!_)
+                              #0))))))
+             ... Tuples
+             (do !
+               [g!eqs (<type>.tuple (<>.many equivalence))
+                .let [g!_ (code.local "_____________")
+                      indices (list.indices (list.size g!eqs))
+                      g!lefts (list#each (|>> nat#encoded (text#composite "left") code.local) indices)
+                      g!rights (list#each (|>> nat#encoded (text#composite "right") code.local) indices)]]
+               (in (` (is (~ (@Equivalence inputT))
+                          (function ((~ g!_) [(~+ g!lefts)] [(~+ g!rights)])
+                            (and (~+ (|> (list.zipped_3 g!eqs g!lefts g!rights)
+                                         (list#each (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 "_____________")]]
+               (in (` (is (~ (@Equivalence inputT))
+                          ((~! /.rec) (.function ((~ g!_) (~ g!self))
+                                        (~ bodyC)))))))
+             <type>.recursive_self
+             ... Type applications
+             (do !
+               [[funcC argsC] (<type>.applied (<>.and equivalence (<>.many equivalence)))]
+               (in (` ((~ funcC) (~+ argsC)))))
+             ... Parameters
+             <type>.parameter
+             ... Polymorphism
+             (do !
+               [[funcC varsC bodyC] (<type>.polymorphic equivalence)]
+               (in (` (is (All ((~ g!_) (~+ varsC))
+                            (-> (~+ (list#each (|>> (~) ((~! /.Equivalence)) (`)) varsC))
+                                ((~! /.Equivalence) ((~ (poly.code *env* inputT)) (~+ varsC)))))
+                          (function ((~ funcC) (~+ varsC))
+                            (~ bodyC))))))
+             <type>.recursive_call
+             ... If all else fails...
+             (|> <type>.any
+                 (at ! each (|>> %.type (format "Cannot create Equivalence for: ") <>.failure))
+                 (at ! conjoint))
+             ))))
diff --git a/stdlib/source/polytypic/lux/abstract/functor.lux b/stdlib/source/polytypic/lux/abstract/functor.lux
new file mode 100644
index 000000000..310c3ff9a
--- /dev/null
+++ b/stdlib/source/polytypic/lux/abstract/functor.lux
@@ -0,0 +1,110 @@
+(.using
+ [library
+  [lux (.except)
+   [abstract
+    [monad (.only Monad do)]]
+   [control
+    ["p" parser (.only)
+     ["<[0]>" type]
+     ["s" code (.only Parser)]]]
+   [data
+    ["[0]" product]
+    ["[0]" text (.only)
+     ["%" format (.only format)]]
+    [collection
+     ["[0]" list (.open: "[1]#[0]" monad monoid)]]]
+   [macro
+    ["[0]" code]]
+   [math
+    [number
+     ["n" nat]]]
+   ["[0]" type (.only)
+    ["[0]" poly (.only poly:)]]]]
+ [\\library
+  ["[0]" /]])
+
+(poly: .public functor
+  (do [! p.monad]
+    [.let [g!_ (code.local "____________")
+           type_funcC (code.local "____________type_funcC")
+           funcC (code.local "____________funcC")
+           inputC (code.local "____________inputC")]
+     *env* <type>.env
+     inputT <type>.next
+     [polyC varsC non_functorT] (<type>.local (list inputT)
+                                              (<type>.polymorphic <type>.any))
+     .let [num_vars (list.size varsC)]
+     .let [@Functor (is (-> Type Code)
+                        (function (_ unwrappedT)
+                          (if (n.= 1 num_vars)
+                            (` ((~! /.Functor) (~ (poly.code *env* unwrappedT))))
+                            (let [paramsC (|> num_vars -- list.indices (list#each (|>> %.nat code.local)))]
+                              (` (All ((~ g!_) (~+ paramsC))
+                                   ((~! /.Functor) ((~ (poly.code *env* unwrappedT)) (~+ paramsC)))))))))
+           Arg<?> (is (-> Code (<type>.Parser Code))
+                      (function (Arg<?> valueC)
+                        (all p.either
+                             ... Type-var
+                             (do p.monad
+                               [.let [varI (|> num_vars (n.* 2) --)]
+                                _ (<type>.this_parameter varI)]
+                               (in (` ((~ funcC) (~ valueC)))))
+                             ... Variants
+                             (do !
+                               [_ (in [])
+                                membersC (<type>.variant (p.many (Arg<?> valueC)))
+                                .let [last (-- (list.size membersC))]]
+                               (in (` (case (~ valueC)
+                                        (~+ (list#conjoint (list#each (function (_ [tag memberC])
+                                                                        (if (n.= last tag)
+                                                                          (list (` {(~ (code.nat (-- tag))) #1 (~ valueC)})
+                                                                                (` {(~ (code.nat (-- tag))) #1 (~ memberC)}))
+                                                                          (list (` {(~ (code.nat tag)) #0 (~ valueC)})
+                                                                                (` {(~ (code.nat tag)) #0 (~ memberC)}))))
+                                                                      (list.enumeration membersC))))))))
+                             ... Tuples
+                             (do p.monad
+                               [pairsCC (is (<type>.Parser (List [Code Code]))
+                                            (<type>.tuple (loop (again [idx 0
+                                                                        pairsCC (is (List [Code Code])
+                                                                                    (list))])
+                                                            (p.either (let [slotC (|> idx %.nat (format "____________slot") code.local)]
+                                                                        (do !
+                                                                          [_ (in [])
+                                                                           memberC (Arg<?> slotC)]
+                                                                          (again (++ idx)
+                                                                                 (list#composite pairsCC (list [slotC memberC])))))
+                                                                      (in pairsCC)))))]
+                               (in (` (case (~ valueC)
+                                        [(~+ (list#each product.left pairsCC))]
+                                        [(~+ (list#each product.right pairsCC))]))))
+                             ... Functions
+                             (do !
+                               [_ (in [])
+                                .let [g! (code.local "____________")
+                                      outL (code.local "____________outL")]
+                                [inT+ outC] (<type>.function (p.many <type>.any)
+                                              (Arg<?> outL))
+                                .let [inC+ (|> (list.size inT+)
+                                               list.indices
+                                               (list#each (|>> %.nat (format "____________inC") code.local)))]]
+                               (in (` (function ((~ g!) (~+ inC+))
+                                        (let [(~ outL) ((~ valueC) (~+ inC+))]
+                                          (~ outC))))))
+                             ... Recursion
+                             (do p.monad
+                               [_ <type>.recursive_call]
+                               (in (` ((~' each) (~ funcC) (~ valueC)))))
+                             ... Parameters
+                             (do p.monad
+                               [_ <type>.any]
+                               (in valueC))
+                             )))]
+     [_ _ outputC] (is (<type>.Parser [Code (List Code) Code])
+                       (p.either (<type>.polymorphic
+                                  (Arg<?> inputC))
+                                 (p.failure (format "Cannot create Functor for: " (%.type inputT)))))]
+    (in (` (is (~ (@Functor inputT))
+               (implementation
+                (def: ((~' each) (~ funcC) (~ inputC))
+                  (~ outputC))))))))
diff --git a/stdlib/source/polytypic/lux/data/format/json.lux b/stdlib/source/polytypic/lux/data/format/json.lux
new file mode 100644
index 000000000..391556a50
--- /dev/null
+++ b/stdlib/source/polytypic/lux/data/format/json.lux
@@ -0,0 +1,335 @@
+(.using
+ [library
+  [lux (.except)
+   ["[0]" debug]
+   [abstract
+    [monad (.only do)]
+    ["[0]" codec]]
+   [control
+    ["[0]" try]
+    ["<>" parser (.only)
+     ["</>" json]
+     ["<[0]>" type]
+     ["<[0]>" code]]]
+   [data
+    ["[0]" text (.only)
+     ["%" format (.only format)]]
+    [collection
+     ["[0]" list (.open: "[1]#[0]" monad)]
+     ["[0]" sequence (.only sequence)]
+     ["[0]" dictionary]]]
+   [macro
+    [syntax (.only syntax)]
+    ["[0]" code]]
+   [math
+    [number
+     ["n" nat (.open: "[1]#[0]" decimal)]
+     ["[0]" i64]
+     ["[0]" int]
+     ["[0]" frac]]]
+   [time
+    ... ["[0]" instant]
+    ... ["[0]" duration]
+    ["[0]" date]
+    ["[0]" day]
+    ["[0]" month]]
+   ["[0]" type (.only)
+    ["[0]" unit]
+    ["[0]" poly (.only poly:)]]]]
+ [\\library
+  ["[0]" / (.only JSON)]])
+
+(def: tag
+  (-> Nat Frac)
+  (|>> .int int.frac))
+
+(def: (rec_encoded non_rec)
+  (All (_ a) (-> (-> (-> a JSON)
+                     (-> a JSON))
+                 (-> a JSON)))
+  (function (_ input)
+    (non_rec (rec_encoded non_rec) input)))
+
+(def: low_mask Nat (|> 1 (i64.left_shifted 32) --))
+(def: high_mask Nat (|> low_mask (i64.left_shifted 32)))
+
+(implementation: nat_codec
+  (codec.Codec JSON Nat)
+  
+  (def: (encoded input)
+    (let [high (|> input (i64.and high_mask) (i64.right_shifted 32))
+          low (i64.and low_mask input)]
+      {/.#Array (sequence (|> high .int int.frac {/.#Number})
+                          (|> low .int int.frac {/.#Number}))}))
+  (def: decoded
+    (</>.result (</>.array
+                 (do <>.monad
+                   [high </>.number
+                    low </>.number]
+                   (in (n.+ (|> high frac.int .nat (i64.left_shifted 32))
+                            (|> low frac.int .nat))))))))
+
+(implementation: int_codec
+  (codec.Codec JSON Int)
+  
+  (def: encoded
+    (|>> .nat (at nat_codec encoded)))
+  (def: decoded
+    (|>> (at nat_codec decoded) (at try.functor each (|>> .int)))))
+
+... Builds a JSON generator for potentially inexistent values.
+(def: (nullable writer)
+  (All (_ a) (-> (-> a JSON) (-> (Maybe a) JSON)))
+  (function (_ elem)
+    (case elem
+      {.#None}       {/.#Null}
+      {.#Some value} (writer value))))
+
+(implementation: qty_codec
+  (All (_ unit)
+    (codec.Codec JSON (unit.Qty unit)))
+  
+  (def: encoded
+    (|>> ((debug.private unit.out'))
+         (at ..int_codec encoded)))
+  (def: decoded
+    (|>> (at ..int_codec decoded)
+         (at try.functor each (debug.private unit.in')))))
+
+(poly: encoded
+  (with_expansions
+    [<basic> (with_template [<matcher> <encoder>]
+               [(do !
+                  [.let [g!_ (code.local "_______")]
+                   _ <matcher>]
+                  (in (` (is (~ (@JSON#encoded inputT))
+                             <encoder>))))]
+
+               [(<type>.exactly Any) (function ((~ g!_) (~ (code.symbol ["" "0"]))) {/.#Null})]
+               [(<type>.sub Bit)     (|>> {/.#Boolean})]
+               [(<type>.sub Nat)     (at (~! ..nat_codec) (~' encoded))]
+               [(<type>.sub Int)     (at (~! ..int_codec) (~' encoded))]
+               [(<type>.sub Frac)    (|>> {/.#Number})]
+               [(<type>.sub Text)    (|>> {/.#String})])
+     <time> (with_template [<type> <codec>]
+              [(do !
+                 [_ (<type>.exactly <type>)]
+                 (in (` (is (~ (@JSON#encoded inputT))
+                            (|>> (at (~! <codec>) (~' encoded)) {/.#String})))))]
+
+              ... [duration.Duration duration.codec]
+              ... [instant.Instant instant.codec]
+              [date.Date date.codec]
+              [day.Day day.codec]
+              [month.Month month.codec])]
+    (do [! <>.monad]
+      [*env* <type>.env
+       .let [g!_ (code.local "_______")
+             @JSON#encoded (is (-> Type Code)
+                               (function (_ type)
+                                 (` (-> (~ (poly.code *env* type)) /.JSON))))]
+       inputT <type>.next]
+      (all <>.either
+           <basic>
+           <time>
+           (do !
+             [unitT (<type>.applied (<>.after (<type>.exactly unit.Qty)
+                                              <type>.any))]
+             (in (` (is (~ (@JSON#encoded inputT))
+                        (at (~! qty_codec) (~' encoded))))))
+           (do !
+             [.let [g!_ (code.local "_______")
+                    g!key (code.local "_______key")
+                    g!val (code.local "_______val")]
+              [_ _ =val=] (<type>.applied (all <>.and
+                                               (<type>.exactly dictionary.Dictionary)
+                                               (<type>.exactly .Text)
+                                               encoded))]
+             (in (` (is (~ (@JSON#encoded inputT))
+                        (|>> ((~! dictionary.entries))
+                             ((~! list#each) (function ((~ g!_) [(~ g!key) (~ g!val)])
+                                               [(~ g!key) ((~ =val=) (~ g!val))]))
+                             ((~! dictionary.of_list) (~! text.hash))
+                             {/.#Object})))))
+           (do !
+             [[_ =sub=] (<type>.applied (all <>.and
+                                             (<type>.exactly .Maybe)
+                                             encoded))]
+             (in (` (is (~ (@JSON#encoded inputT))
+                        ((~! ..nullable) (~ =sub=))))))
+           (do !
+             [[_ =sub=] (<type>.applied (all <>.and
+                                             (<type>.exactly .List)
+                                             encoded))]
+             (in (` (is (~ (@JSON#encoded inputT))
+                        (|>> ((~! list#each) (~ =sub=)) ((~! sequence.of_list)) {/.#Array})))))
+           (do !
+             [.let [g!_ (code.local "_______")
+                    g!input (code.local "_______input")]
+              members (<type>.variant (<>.many encoded))
+              .let [last (-- (list.size members))]]
+             (in (` (is (~ (@JSON#encoded inputT))
+                        (function ((~ g!_) (~ g!input))
+                          (case (~ g!input)
+                            (~+ (list#conjoint (list#each (function (_ [tag g!encoded])
+                                                            (if (n.= last tag)
+                                                              (.list (` {(~ (code.nat (-- tag))) #1 (~ g!input)})
+                                                                     (` ((~! /.json) [(~ (code.frac (..tag (-- tag))))
+                                                                                      #1
+                                                                                      ((~ g!encoded) (~ g!input))])))
+                                                              (.list (` {(~ (code.nat tag)) #0 (~ g!input)})
+                                                                     (` ((~! /.json) [(~ (code.frac (..tag tag)))
+                                                                                      #0
+                                                                                      ((~ g!encoded) (~ g!input))])))))
+                                                          (list.enumeration members))))))))))
+           (do !
+             [g!encoders (<type>.tuple (<>.many encoded))
+              .let [g!_ (code.local "_______")
+                    g!members (|> (list.size g!encoders)
+                                  list.indices
+                                  (list#each (|>> n#encoded code.local)))]]
+             (in (` (is (~ (@JSON#encoded inputT))
+                        (function ((~ g!_) [(~+ g!members)])
+                          ((~! /.json) [(~+ (list#each (function (_ [g!member g!encoded])
+                                                         (` ((~ g!encoded) (~ g!member))))
+                                                       (list.zipped_2 g!members g!encoders)))]))))))
+           ... Type recursion
+           (do !
+             [[selfC non_recC] (<type>.recursive encoded)
+              .let [g! (code.local "____________")]]
+             (in (` (is (~ (@JSON#encoded inputT))
+                        ((~! ..rec_encoded) (.function ((~ g!) (~ selfC))
+                                              (~ non_recC)))))))
+           <type>.recursive_self
+           ... Type applications
+           (do !
+             [partsC (<type>.applied (<>.many encoded))]
+             (in (` ((~+ partsC)))))
+           ... Polymorphism
+           (do !
+             [[funcC varsC bodyC] (<type>.polymorphic encoded)]
+             (in (` (is (All ((~ g!_) (~+ varsC))
+                          (-> (~+ (list#each (function (_ varC) (` (-> (~ varC) /.JSON)))
+                                             varsC))
+                              (-> ((~ (poly.code *env* inputT)) (~+ varsC))
+                                  /.JSON)))
+                        (function ((~ funcC) (~+ varsC))
+                          (~ bodyC))))))
+           <type>.parameter
+           <type>.recursive_call
+           ... If all else fails...
+           (<>.failure (format "Cannot create JSON encoder for: " (type.format inputT)))
+           ))))
+
+(poly: decoded
+  (with_expansions
+    [<basic> (with_template [<matcher> <decoder>]
+               [(do !
+                  [_ <matcher>]
+                  (in (` (is (~ (@JSON#decoded inputT))
+                             (~! <decoder>)))))]
+
+               [(<type>.exactly Any)  </>.null]
+               [(<type>.sub Bit)      </>.boolean]
+               [(<type>.sub Nat)      (<>.codec ..nat_codec </>.any)]
+               [(<type>.sub Int)      (<>.codec ..int_codec </>.any)]
+               [(<type>.sub Frac)     </>.number]
+               [(<type>.sub Text)     </>.string])
+     <time> (with_template [<type> <codec>]
+              [(do !
+                 [_ (<type>.exactly <type>)]
+                 (in (` (is (~ (@JSON#decoded inputT))
+                            ((~! <>.codec) (~! <codec>) (~! </>.string))))))]
+
+              ... [duration.Duration duration.codec]
+              ... [instant.Instant instant.codec]
+              [date.Date date.codec]
+              [day.Day day.codec]
+              [month.Month month.codec])]
+    (do [! <>.monad]
+      [*env* <type>.env
+       .let [g!_ (code.local "_______")
+             @JSON#decoded (is (-> Type Code)
+                               (function (_ type)
+                                 (` (</>.Parser (~ (poly.code *env* type))))))]
+       inputT <type>.next]
+      (all <>.either
+           <basic>
+           <time>
+           (do !
+             [unitT (<type>.applied (<>.after (<type>.exactly unit.Qty)
+                                              <type>.any))]
+             (in (` (is (~ (@JSON#decoded inputT))
+                        ((~! <>.codec) (~! qty_codec) (~! </>.any))))))
+           (do !
+             [[_ _ valC] (<type>.applied (all <>.and
+                                              (<type>.exactly dictionary.Dictionary)
+                                              (<type>.exactly .Text)
+                                              decoded))]
+             (in (` (is (~ (@JSON#decoded inputT))
+                        ((~! </>.dictionary) (~ valC))))))
+           (do !
+             [[_ subC] (<type>.applied (<>.and (<type>.exactly .Maybe)
+                                               decoded))]
+             (in (` (is (~ (@JSON#decoded inputT))
+                        ((~! </>.nullable) (~ subC))))))
+           (do !
+             [[_ subC] (<type>.applied (<>.and (<type>.exactly .List)
+                                               decoded))]
+             (in (` (is (~ (@JSON#decoded inputT))
+                        ((~! </>.array) ((~! <>.some) (~ subC)))))))
+           (do !
+             [members (<type>.variant (<>.many decoded))
+              .let [last (-- (list.size members))]]
+             (in (` (is (~ (@JSON#decoded inputT))
+                        (all ((~! <>.or))
+                             (~+ (list#each (function (_ [tag memberC])
+                                              (if (n.= last tag)
+                                                (` (|> (~ memberC)
+                                                       ((~! <>.after) ((~! </>.this_boolean) (~ (code.bit #1))))
+                                                       ((~! <>.after) ((~! </>.this_number) (~ (code.frac (..tag (-- tag))))))
+                                                       ((~! </>.array))))
+                                                (` (|> (~ memberC)
+                                                       ((~! <>.after) ((~! </>.this_boolean) (~ (code.bit #0))))
+                                                       ((~! <>.after) ((~! </>.this_number) (~ (code.frac (..tag tag)))))
+                                                       ((~! </>.array))))))
+                                            (list.enumeration members))))))))
+           (do !
+             [g!decoders (<type>.tuple (<>.many decoded))]
+             (in (` (is (~ (@JSON#decoded inputT))
+                        ((~! </>.array) (all ((~! <>.and)) (~+ g!decoders)))))))
+           ... Type recursion
+           (do !
+             [[selfC bodyC] (<type>.recursive decoded)
+              .let [g! (code.local "____________")]]
+             (in (` (is (~ (@JSON#decoded inputT))
+                        ((~! <>.rec) (.function ((~ g!) (~ selfC))
+                                       (~ bodyC)))))))
+           <type>.recursive_self
+           ... Type applications
+           (do !
+             [[funcC argsC] (<type>.applied (<>.and decoded (<>.many decoded)))]
+             (in (` ((~ funcC) (~+ argsC)))))
+           ... Polymorphism
+           (do !
+             [[funcC varsC bodyC] (<type>.polymorphic decoded)]
+             (in (` (is (All ((~ g!_) (~+ varsC))
+                          (-> (~+ (list#each (|>> (~) </>.Parser (`)) varsC))
+                              (</>.Parser ((~ (poly.code *env* inputT)) (~+ varsC)))))
+                        (function ((~ funcC) (~+ varsC))
+                          (~ bodyC))))))
+           <type>.parameter
+           <type>.recursive_call
+           ... If all else fails...
+           (<>.failure (format "Cannot create JSON decoder for: " (type.format inputT)))
+           ))))
+
+(def: .public codec
+  (syntax (_ [inputT <code>.any])
+    (in (.list (` (is (codec.Codec /.JSON (~ inputT))
+                      (implementation
+                       (def: (~' encoded)
+                         ((~! ..encoded) (~ inputT)))
+                       (def: (~' decoded)
+                         ((~! </>.result) ((~! ..decoded) (~ inputT))))
+                       )))))))
-- 
cgit v1.2.3