aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/polytypic
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/polytypic')
-rw-r--r--stdlib/source/polytypic/lux/abstract/equivalence.lux167
-rw-r--r--stdlib/source/polytypic/lux/abstract/functor.lux110
-rw-r--r--stdlib/source/polytypic/lux/data/format/json.lux335
3 files changed, 612 insertions, 0 deletions
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))))
+ )))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-31 22:39:39 +0000