aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/poly
diff options
context:
space:
mode:
authorEduardo Julian2019-09-07 21:07:03 -0400
committerEduardo Julian2019-09-07 21:07:03 -0400
commit0e2121dbec4f61dc1d9404deb9dd2b3f401ba4df (patch)
tree21cb35470bb304743fa322e4c105a4915f633ab4 /stdlib/source/poly
parentab268d6fce40fac9c5029e39db927542facea201 (diff)
Moved polytypic code generators to their own branch.
Diffstat (limited to 'stdlib/source/poly')
-rw-r--r--stdlib/source/poly/lux/abstract/equivalence.lux163
-rw-r--r--stdlib/source/poly/lux/abstract/functor.lux104
-rw-r--r--stdlib/source/poly/lux/data/format/json.lux333
3 files changed, 600 insertions, 0 deletions
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))))
+ )))))))