diff options
Diffstat (limited to 'stdlib/source/poly')
| -rw-r--r-- | stdlib/source/poly/lux/abstract/equivalence.lux | 163 | ||||
| -rw-r--r-- | stdlib/source/poly/lux/abstract/functor.lux | 104 | ||||
| -rw-r--r-- | stdlib/source/poly/lux/data/format/json.lux | 333 |
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)))) + ))))))) |