diff options
author | Eduardo Julian | 2022-06-12 02:29:28 -0400 |
---|---|---|
committer | Eduardo Julian | 2022-06-12 02:29:28 -0400 |
commit | 9c21fd1f33eb52fb971d493ad21a67036d68b841 (patch) | |
tree | 525d0f841edfa94645317ac905cb69c8a7983a5c /stdlib/source/poly | |
parent | b48ea68a83d01903554c7696c77eedaaf1035680 (diff) |
Re-named the "poly" hierarchy to "polytypic".
Diffstat (limited to 'stdlib/source/poly')
-rw-r--r-- | stdlib/source/poly/lux/abstract/equivalence.lux | 167 | ||||
-rw-r--r-- | stdlib/source/poly/lux/abstract/functor.lux | 110 | ||||
-rw-r--r-- | stdlib/source/poly/lux/data/format/json.lux | 335 |
3 files changed, 0 insertions, 612 deletions
diff --git a/stdlib/source/poly/lux/abstract/equivalence.lux b/stdlib/source/poly/lux/abstract/equivalence.lux deleted file mode 100644 index 1e882e32d..000000000 --- a/stdlib/source/poly/lux/abstract/equivalence.lux +++ /dev/null @@ -1,167 +0,0 @@ -(.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/poly/lux/abstract/functor.lux b/stdlib/source/poly/lux/abstract/functor.lux deleted file mode 100644 index 310c3ff9a..000000000 --- a/stdlib/source/poly/lux/abstract/functor.lux +++ /dev/null @@ -1,110 +0,0 @@ -(.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/poly/lux/data/format/json.lux b/stdlib/source/poly/lux/data/format/json.lux deleted file mode 100644 index 391556a50..000000000 --- a/stdlib/source/poly/lux/data/format/json.lux +++ /dev/null @@ -1,335 +0,0 @@ -(.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)))) - ))))))) |