diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/control/parser/type.lux | 348 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly.lux | 376 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/equivalence.lux | 57 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/functor.lux | 49 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/json.lux | 115 | ||||
| -rw-r--r-- | stdlib/source/test/lux.lux | 7 |
6 files changed, 487 insertions, 465 deletions
diff --git a/stdlib/source/lux/control/parser/type.lux b/stdlib/source/lux/control/parser/type.lux new file mode 100644 index 000000000..56942e5c4 --- /dev/null +++ b/stdlib/source/lux/control/parser/type.lux @@ -0,0 +1,348 @@ +(.module: + [lux (#- function log!) + [abstract + ["." monad (#+ do)]] + [control + ["." exception (#+ exception:)] + ["." function]] + [data + ["." name ("#@." codec)] + ["." error (#+ Error)] + [number + ["." nat ("#@." decimal)]] + ["." text ("#@." monoid) + format] + [collection + ["." list ("#@." functor)] + ["." dictionary (#+ Dictionary)]]] + [macro + ["." code]] + ["." type ("#@." equivalence) + ["." check]]] + ["." // (#+ Parser)]) + +(template [<name>] + [(exception: #export (<name> {type Type}) + (exception.report + ["Type" (%type type)]))] + + [not-existential] + [not-recursive] + [not-named] + [not-parameter] + [unknown-parameter] + [not-function] + [not-application] + [not-polymorphic] + [not-variant] + [not-tuple] + ) + +(template [<name>] + [(exception: #export (<name> {expected Type} {actual Type}) + (exception.report + ["Expected" (%type expected)] + ["Actual" (%type actual)]))] + + [types-do-not-match] + [wrong-parameter] + ) + +(exception: #export (unconsumed {remaining (List Type)}) + (exception.report + ["Types" (|> remaining + (list@map (|>> %type (format text.new-line "* "))) + (text.join-with ""))])) + +(type: #export Env + (Dictionary Nat [Type Code])) + +(type: #export (Poly a) + (Parser [Env (List Type)] a)) + +(def: #export fresh Env (dictionary.new nat.hash)) + +(def: (run' env types poly) + (All [a] (-> Env (List Type) (Poly a) (Error a))) + (case (//.run [env types] poly) + (#error.Failure error) + (#error.Failure error) + + (#error.Success [[env' remaining] output]) + (case remaining + #.Nil + (#error.Success output) + + _ + (exception.throw unconsumed remaining)))) + +(def: #export (run type poly) + (All [a] (-> Type (Poly a) (Error a))) + (run' fresh (list type) poly)) + +(def: #export env + (Poly Env) + (.function (_ [env inputs]) + (#error.Success [[env inputs] env]))) + +(def: (with-env temp poly) + (All [a] (-> Env (Poly a) (Poly a))) + (.function (_ [env inputs]) + (case (//.run [temp inputs] poly) + (#error.Failure error) + (#error.Failure error) + + (#error.Success [[_ remaining] output]) + (#error.Success [[env remaining] output])))) + +(def: #export peek + (Poly Type) + (.function (_ [env inputs]) + (case inputs + #.Nil + (#error.Failure "Empty stream of types.") + + (#.Cons headT tail) + (#error.Success [[env inputs] headT])))) + +(def: #export any + (Poly Type) + (.function (_ [env inputs]) + (case inputs + #.Nil + (#error.Failure "Empty stream of types.") + + (#.Cons headT tail) + (#error.Success [[env tail] headT])))) + +(def: #export (local types poly) + (All [a] (-> (List Type) (Poly a) (Poly a))) + (.function (_ [env pass-through]) + (case (run' env types poly) + (#error.Failure error) + (#error.Failure error) + + (#error.Success output) + (#error.Success [[env pass-through] output])))) + +(def: (label idx) + (-> Nat Code) + (code.local-identifier ($_ text@compose "label" text.tab (nat@encode idx)))) + +(def: #export (with-extension type poly) + (All [a] (-> Type (Poly a) (Poly [Code a]))) + (.function (_ [env inputs]) + (let [current-id (dictionary.size env) + g!var (label current-id)] + (case (//.run [(dictionary.put current-id [type g!var] env) + inputs] + poly) + (#error.Failure error) + (#error.Failure error) + + (#error.Success [[_ inputs'] output]) + (#error.Success [[env inputs'] [g!var output]]))))) + +(template [<name> <flattener> <tag> <exception>] + [(def: #export (<name> poly) + (All [a] (-> (Poly a) (Poly a))) + (do //.monad + [headT any] + (let [members (<flattener> (type.un-name headT))] + (if (n/> 1 (list.size members)) + (local members poly) + (//.fail (exception.construct <exception> headT))))))] + + [variant type.flatten-variant #.Sum not-variant] + [tuple type.flatten-tuple #.Product not-tuple] + ) + +(def: polymorphic' + (Poly [Nat Type]) + (do //.monad + [headT any + #let [[num-arg bodyT] (type.flatten-univ-q (type.un-name headT))]] + (if (n/= 0 num-arg) + (//.fail (exception.construct not-polymorphic headT)) + (wrap [num-arg bodyT])))) + +(def: #export (polymorphic poly) + (All [a] (-> (Poly a) (Poly [Code (List Code) a]))) + (do //.monad + [headT any + funcI (:: @ map dictionary.size ..env) + [num-args non-poly] (local (list headT) polymorphic') + env ..env + #let [funcL (label funcI) + [all-varsL env'] (loop [current-arg 0 + env' env + all-varsL (: (List Code) (list))] + (if (n/< num-args current-arg) + (if (n/= 0 current-arg) + (let [varL (label (inc funcI))] + (recur (inc current-arg) + (|> env' + (dictionary.put funcI [headT funcL]) + (dictionary.put (inc funcI) [(#.Parameter (inc funcI)) varL])) + (#.Cons varL all-varsL))) + (let [partialI (|> current-arg (n/* 2) (n/+ funcI)) + partial-varI (inc partialI) + partial-varL (label partial-varI) + partialC (` ((~ funcL) (~+ (|> (list.indices num-args) + (list@map (|>> (n/* 2) inc (n/+ funcI) label)) + list.reverse))))] + (recur (inc current-arg) + (|> env' + (dictionary.put partialI [.Nothing partialC]) + (dictionary.put partial-varI [(#.Parameter partial-varI) partial-varL])) + (#.Cons partial-varL all-varsL)))) + [all-varsL env']))]] + (|> (do @ + [output poly] + (wrap [funcL all-varsL output])) + (local (list non-poly)) + (with-env env')))) + +(def: #export (function in-poly out-poly) + (All [i o] (-> (Poly i) (Poly o) (Poly [i o]))) + (do //.monad + [headT any + #let [[inputsT outputT] (type.flatten-function (type.un-name headT))]] + (if (n/> 0 (list.size inputsT)) + (//.and (local inputsT in-poly) + (local (list outputT) out-poly)) + (//.fail (exception.construct not-function headT))))) + +(def: #export (apply poly) + (All [a] (-> (Poly a) (Poly a))) + (do //.monad + [headT any + #let [[funcT paramsT] (type.flatten-application (type.un-name headT))]] + (if (n/= 0 (list.size paramsT)) + (//.fail (exception.construct not-application headT)) + (local (#.Cons funcT paramsT) poly)))) + +(template [<name> <test>] + [(def: #export (<name> expected) + (-> Type (Poly Any)) + (do //.monad + [actual any] + (if (<test> expected actual) + (wrap []) + (//.fail (exception.construct types-do-not-match [expected actual])))))] + + [exactly type@=] + [sub check.checks?] + [super (function.flip check.checks?)] + ) + +(def: #export (adjusted-idx env idx) + (-> Env Nat Nat) + (let [env-level (n// 2 (dictionary.size env)) + parameter-level (n// 2 idx) + parameter-idx (n/% 2 idx)] + (|> env-level dec (n/- parameter-level) (n/* 2) (n/+ parameter-idx)))) + +(def: #export parameter + (Poly Code) + (do //.monad + [env ..env + headT any] + (case headT + (#.Parameter idx) + (case (dictionary.get (adjusted-idx env idx) env) + (#.Some [poly-type poly-code]) + (wrap poly-code) + + #.None + (//.fail (exception.construct unknown-parameter headT))) + + _ + (//.fail (exception.construct not-parameter headT))))) + +(def: #export (parameter! id) + (-> Nat (Poly Any)) + (do //.monad + [env ..env + headT any] + (case headT + (#.Parameter idx) + (if (n/= id (adjusted-idx env idx)) + (wrap []) + (//.fail (exception.construct wrong-parameter [(#.Parameter id) headT]))) + + _ + (//.fail (exception.construct not-parameter headT))))) + +(def: #export existential + (Poly Nat) + (do //.monad + [headT any] + (case headT + (#.Ex ex-id) + (wrap ex-id) + + _ + (//.fail (exception.construct not-existential headT))))) + +(def: #export named + (Poly [Name Type]) + (do //.monad + [inputT any] + (case inputT + (#.Named name anonymousT) + (wrap [name anonymousT]) + + _ + (//.fail (exception.construct not-named inputT))))) + +(def: #export (recursive poly) + (All [a] (-> (Poly a) (Poly [Code a]))) + (do //.monad + [headT any] + (case (type.un-name headT) + (#.Apply (#.Named ["lux" "Nothing"] _) (#.UnivQ _ headT')) + (do @ + [[recT _ output] (|> poly + (with-extension .Nothing) + (with-extension headT) + (local (list headT')))] + (wrap [recT output])) + + _ + (//.fail (exception.construct not-recursive headT))))) + +(def: #export recursive-self + (Poly Code) + (do //.monad + [env ..env + headT any] + (case (type.un-name headT) + (^multi (#.Apply (#.Named ["lux" "Nothing"] _) (#.Parameter funcT-idx)) + (n/= 0 (adjusted-idx env funcT-idx)) + [(dictionary.get 0 env) (#.Some [self-type self-call])]) + (wrap self-call) + + _ + (//.fail (exception.construct not-recursive headT))))) + +(def: #export recursive-call + (Poly Code) + (do //.monad + [env ..env + [funcT argsT] (apply (//.and any (//.many any))) + _ (local (list funcT) (..parameter! 0)) + allC (let [allT (list& funcT argsT)] + (|> allT + (monad.map @ (function.constant ..parameter)) + (local allT)))] + (wrap (` ((~+ allC)))))) + +(def: #export log! + (All [a] (Poly a)) + (do //.monad + [current any + #let [_ (.log! ($_ text@compose + "{" (name@encode (name-of ..log)) "} " + (%type current)))]] + (//.fail "LOGGING"))) diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index a3d78177a..695284e0a 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -1,356 +1,24 @@ (.module: - [lux (#- function) + [lux #* [abstract - ["." monad (#+ Monad do)] - [equivalence]] + ["." monad (#+ do)]] [control - ["p" parser] - ["ex" exception (#+ exception:)] - ["." function]] + ["p" parser + ["<.>" type (#+ Env)]]] [data ["." product] - ["." bit] ["." maybe] - ["." name ("#;." codec)] - ["." error (#+ Error)] - ["." number (#+ hex) - ["." nat ("#;." decimal)]] - ["." text ("#;." monoid) - format] + ["." text] [collection - ["." list ("#;." fold monad monoid)] - ["dict" dictionary (#+ Dictionary)]]] + ["." list ("#@." fold functor)] + ["." dictionary]]] ["." macro (#+ with-gensyms) ["." code] - ["s" syntax (#+ Syntax syntax:)] - [syntax - ["cs" common + ["s" syntax (#+ syntax:) + [common ["csr" reader] ["csw" writer]]]] - ["." type ("#;." equivalence) - ["." check]]]) - -(template [<name>] - [(exception: #export (<name> {type Type}) - (%type type))] - - [not-existential] - [not-recursive] - [not-named] - [not-parameter] - [unknown-parameter] - [not-function] - [not-application] - [not-polymorphic] - [not-variant] - [not-tuple] - ) - -(template [<name>] - [(exception: #export (<name> {expected Type} {actual Type}) - (ex.report ["Expected" (%type expected)] - ["Actual" (%type actual)]))] - - [types-do-not-match] - [wrong-parameter] - ) - -(exception: #export (unconsumed {remaining (List Type)}) - (ex.report ["Types" (|> remaining - (list;map (|>> %type (format text.new-line "* "))) - (text.join-with ""))])) - -(type: #export Env (Dictionary Nat [Type Code])) - -(type: #export (Poly a) - (p.Parser [Env (List Type)] a)) - -(def: #export fresh Env (dict.new nat.hash)) - -(def: (run' env types poly) - (All [a] (-> Env (List Type) (Poly a) (Error a))) - (case (p.run [env types] poly) - (#error.Failure error) - (#error.Failure error) - - (#error.Success [[env' remaining] output]) - (case remaining - #.Nil - (#error.Success output) - - _ - (ex.throw unconsumed remaining)))) - -(def: #export (run type poly) - (All [a] (-> Type (Poly a) (Error a))) - (run' fresh (list type) poly)) - -(def: #export env - (Poly Env) - (.function (_ [env inputs]) - (#error.Success [[env inputs] env]))) - -(def: (with-env temp poly) - (All [a] (-> Env (Poly a) (Poly a))) - (.function (_ [env inputs]) - (case (p.run [temp inputs] poly) - (#error.Failure error) - (#error.Failure error) - - (#error.Success [[_ remaining] output]) - (#error.Success [[env remaining] output])))) - -(def: #export peek - (Poly Type) - (.function (_ [env inputs]) - (case inputs - #.Nil - (#error.Failure "Empty stream of types.") - - (#.Cons headT tail) - (#error.Success [[env inputs] headT])))) - -(def: #export any - (Poly Type) - (.function (_ [env inputs]) - (case inputs - #.Nil - (#error.Failure "Empty stream of types.") - - (#.Cons headT tail) - (#error.Success [[env tail] headT])))) - -(def: #export (local types poly) - (All [a] (-> (List Type) (Poly a) (Poly a))) - (.function (_ [env pass-through]) - (case (run' env types poly) - (#error.Failure error) - (#error.Failure error) - - (#error.Success output) - (#error.Success [[env pass-through] output])))) - -(def: (label idx) - (-> Nat Code) - (code.local-identifier ($_ text;compose "label" text.tab (nat;encode idx)))) - -(def: #export (with-extension type poly) - (All [a] (-> Type (Poly a) (Poly [Code a]))) - (.function (_ [env inputs]) - (let [current-id (dict.size env) - g!var (label current-id)] - (case (p.run [(dict.put current-id [type g!var] env) - inputs] - poly) - (#error.Failure error) - (#error.Failure error) - - (#error.Success [[_ inputs'] output]) - (#error.Success [[env inputs'] [g!var output]]))))) - -(template [<name> <flattener> <tag> <exception>] - [(def: #export (<name> poly) - (All [a] (-> (Poly a) (Poly a))) - (do p.monad - [headT any] - (let [members (<flattener> (type.un-name headT))] - (if (n/> 1 (list.size members)) - (local members poly) - (p.fail (ex.construct <exception> headT))))))] - - [variant type.flatten-variant #.Sum not-variant] - [tuple type.flatten-tuple #.Product not-tuple] - ) - -(def: polymorphic' - (Poly [Nat Type]) - (do p.monad - [headT any - #let [[num-arg bodyT] (type.flatten-univ-q (type.un-name headT))]] - (if (n/= 0 num-arg) - (p.fail (ex.construct not-polymorphic headT)) - (wrap [num-arg bodyT])))) - -(def: #export (polymorphic poly) - (All [a] (-> (Poly a) (Poly [Code (List Code) a]))) - (do p.monad - [headT any - funcI (:: @ map dict.size ..env) - [num-args non-poly] (local (list headT) polymorphic') - env ..env - #let [funcL (label funcI) - [all-varsL env'] (loop [current-arg 0 - env' env - all-varsL (: (List Code) (list))] - (if (n/< num-args current-arg) - (if (n/= 0 current-arg) - (let [varL (label (inc funcI))] - (recur (inc current-arg) - (|> env' - (dict.put funcI [headT funcL]) - (dict.put (inc funcI) [(#.Parameter (inc funcI)) varL])) - (#.Cons varL all-varsL))) - (let [partialI (|> current-arg (n/* 2) (n/+ funcI)) - partial-varI (inc partialI) - partial-varL (label partial-varI) - partialC (` ((~ funcL) (~+ (|> (list.indices num-args) - (list;map (|>> (n/* 2) inc (n/+ funcI) label)) - list.reverse))))] - (recur (inc current-arg) - (|> env' - (dict.put partialI [.Nothing partialC]) - (dict.put partial-varI [(#.Parameter partial-varI) partial-varL])) - (#.Cons partial-varL all-varsL)))) - [all-varsL env']))]] - (|> (do @ - [output poly] - (wrap [funcL all-varsL output])) - (local (list non-poly)) - (with-env env')))) - -(def: #export (function in-poly out-poly) - (All [i o] (-> (Poly i) (Poly o) (Poly [i o]))) - (do p.monad - [headT any - #let [[inputsT outputT] (type.flatten-function (type.un-name headT))]] - (if (n/> 0 (list.size inputsT)) - (p.and (local inputsT in-poly) - (local (list outputT) out-poly)) - (p.fail (ex.construct not-function headT))))) - -(def: #export (apply poly) - (All [a] (-> (Poly a) (Poly a))) - (do p.monad - [headT any - #let [[funcT paramsT] (type.flatten-application (type.un-name headT))]] - (if (n/= 0 (list.size paramsT)) - (p.fail (ex.construct not-application headT)) - (local (#.Cons funcT paramsT) poly)))) - -(template [<name> <test>] - [(def: #export (<name> expected) - (-> Type (Poly Any)) - (do p.monad - [actual any] - (if (<test> expected actual) - (wrap []) - (p.fail (ex.construct types-do-not-match [expected actual])))))] - - [exactly type;=] - [sub check.checks?] - [super (function.flip check.checks?)] - ) - -(def: (adjusted-idx env idx) - (-> Env Nat Nat) - (let [env-level (n// 2 (dict.size env)) - parameter-level (n// 2 idx) - parameter-idx (n/% 2 idx)] - (|> env-level dec (n/- parameter-level) (n/* 2) (n/+ parameter-idx)))) - -(def: #export parameter - (Poly Code) - (do p.monad - [env ..env - headT any] - (case headT - (#.Parameter idx) - (case (dict.get (adjusted-idx env idx) env) - (#.Some [poly-type poly-code]) - (wrap poly-code) - - #.None - (p.fail (ex.construct unknown-parameter headT))) - - _ - (p.fail (ex.construct not-parameter headT))))) - -(def: #export (parameter! id) - (-> Nat (Poly Any)) - (do p.monad - [env ..env - headT any] - (case headT - (#.Parameter idx) - (if (n/= id (adjusted-idx env idx)) - (wrap []) - (p.fail (ex.construct wrong-parameter [(#.Parameter id) headT]))) - - _ - (p.fail (ex.construct not-parameter headT))))) - -(def: #export existential - (Poly Nat) - (do p.monad - [headT any] - (case headT - (#.Ex ex-id) - (wrap ex-id) - - _ - (p.fail (ex.construct not-existential headT))))) - -(def: #export named - (Poly [Name Type]) - (do p.monad - [inputT any] - (case inputT - (#.Named name anonymousT) - (wrap [name anonymousT]) - - _ - (p.fail (ex.construct not-named inputT))))) - -(def: #export (recursive poly) - (All [a] (-> (Poly a) (Poly [Code a]))) - (do p.monad - [headT any] - (case (type.un-name headT) - (#.Apply (#.Named ["lux" "Nothing"] _) (#.UnivQ _ headT')) - (do @ - [[recT _ output] (|> poly - (with-extension .Nothing) - (with-extension headT) - (local (list headT')))] - (wrap [recT output])) - - _ - (p.fail (ex.construct not-recursive headT))))) - -(def: #export recursive-self - (Poly Code) - (do p.monad - [env ..env - headT any] - (case (type.un-name headT) - (^multi (#.Apply (#.Named ["lux" "Nothing"] _) (#.Parameter funcT-idx)) - (n/= 0 (adjusted-idx env funcT-idx)) - [(dict.get 0 env) (#.Some [self-type self-call])]) - (wrap self-call) - - _ - (p.fail (ex.construct not-recursive headT))))) - -(def: #export recursive-call - (Poly Code) - (do p.monad - [env ..env - [funcT argsT] (apply (p.and any (p.many any))) - _ (local (list funcT) (..parameter! 0)) - allC (let [allT (list& funcT argsT)] - (|> allT - (monad.map @ (function.constant ..parameter)) - (local allT)))] - (wrap (` ((~+ allC)))))) - -(def: #export log - (All [a] (Poly a)) - (do p.monad - [current any - #let [_ (log! ($_ text;compose - "{" (name;encode (name-of ..log)) "} " - (%type current)))]] - (p.fail "LOGGING"))) + ["." type]]) (syntax: #export (poly: {export csr.export} {name s.local-identifier} @@ -361,10 +29,10 @@ (do macro.monad [(~ g!type) (macro.find-type-def (~ g!type))] (case (|> (~ body) - (.function ((~ g!_) (~ g!name))) + (function ((~ g!_) (~ g!name))) p.rec (do p.monad []) - (..run (~ g!type)) + ((~! <type>.run) (~ g!type)) (: (.Either .Text .Code))) (#.Left (~ g!output)) (macro.fail (~ g!output)) @@ -379,7 +47,7 @@ (def: (derivation-name poly args) (-> Text (List Text) (Maybe Text)) (if (common-poly-name? poly) - (#.Some (list;fold (text.replace-once "?") poly args)) + (#.Some (list@fold (text.replace-once "?") poly args)) #.None)) (syntax: #export (derived: {export csr.export} @@ -393,7 +61,7 @@ (wrap name) (^multi #.None - [(derivation-name (product.right poly-func) (list;map product.right poly-args)) + [(derivation-name (product.right poly-func) (list@map product.right poly-args)) (#.Some derived-name)]) (wrap derived-name) @@ -404,7 +72,7 @@ custom-impl #.None - (` ((~ (code.identifier poly-func)) (~+ (list;map code.identifier poly-args)))))]] + (` ((~ (code.identifier poly-func)) (~+ (list@map code.identifier poly-args)))))]] (wrap (.list (` (def: (~+ (csw.export export)) (~ (code.identifier ["" name])) {#.struct? #1} @@ -415,7 +83,7 @@ (case type (#.Primitive name params) (` (#.Primitive (~ (code.text name)) - (list (~+ (list;map (to-code env) params))))) + (list (~+ (list@map (to-code env) params))))) (^template [<tag>] (<tag> idx) @@ -423,15 +91,15 @@ ([#.Var] [#.Ex]) (#.Parameter idx) - (let [idx (adjusted-idx env idx)] + (let [idx (<type>.adjusted-idx env idx)] (if (n/= 0 idx) - (|> (dict.get idx env) maybe.assume product.left (to-code env)) + (|> (dictionary.get idx env) maybe.assume product.left (to-code env)) (` (.$ (~ (code.nat (dec idx))))))) (#.Apply (#.Named ["lux" "Nothing"] _) (#.Parameter idx)) - (let [idx (adjusted-idx env idx)] + (let [idx (<type>.adjusted-idx env idx)] (if (n/= 0 idx) - (|> (dict.get idx env) maybe.assume product.left (to-code env)) + (|> (dictionary.get idx env) maybe.assume product.left (to-code env)) (undefined))) (^template [<tag>] @@ -442,7 +110,7 @@ (^template [<tag> <macro> <flattener>] (<tag> left right) - (` (<macro> (~+ (list;map (to-code env) (<flattener> type)))))) + (` (<macro> (~+ (list@map (to-code env) (<flattener> type)))))) ([#.Sum | type.flatten-variant] [#.Product & type.flatten-tuple]) @@ -451,7 +119,7 @@ (^template [<tag>] (<tag> scope body) - (` (<tag> (list (~+ (list;map (to-code env) scope))) + (` (<tag> (list (~+ (list@map (to-code env) scope))) (~ (to-code env body))))) ([#.UnivQ] [#.ExQ]) )) diff --git a/stdlib/source/lux/macro/poly/equivalence.lux b/stdlib/source/lux/macro/poly/equivalence.lux index c39ad9412..50dabcd16 100644 --- a/stdlib/source/lux/macro/poly/equivalence.lux +++ b/stdlib/source/lux/macro/poly/equivalence.lux @@ -4,7 +4,8 @@ [monad (#+ Monad do)] ["/" equivalence]] [control - ["p" parser]] + ["p" parser + ["<.>" type]]] [data ["." product] ["." bit] @@ -42,8 +43,8 @@ (poly: #export equivalence (`` (do @ [#let [g!_ (code.local-identifier "_____________")] - *env* poly.env - inputT poly.peek + *env* <type>.env + inputT <type>.peek #let [@Equivalence (: (-> Type Code) (function (_ type) (` ((~! /.Equivalence) (~ (poly.to-code *env* type))))))]] @@ -55,18 +56,18 @@ (wrap (` (: (~ (@Equivalence inputT)) <eq>))))] - [(poly.exactly Any) (function ((~ g!_) (~ g!_) (~ g!_)) #1)] - [(poly.sub Bit) (~! bit.equivalence)] - [(poly.sub Nat) (~! nat.equivalence)] - [(poly.sub Int) (~! int.equivalence)] - [(poly.sub Rev) (~! rev.equivalence)] - [(poly.sub Frac) (~! frac.equivalence)] - [(poly.sub Text) (~! text.equivalence)])) + [(<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] (poly.apply (p.and (poly.exactly <name>) - equivalence))] + [[_ argC] (<type>.apply (p.and (<type>.exactly <name>) + equivalence))] (wrap (` (: (~ (@Equivalence inputT)) (<eq> (~ argC))))))] @@ -79,16 +80,16 @@ [rose.Tree (~! rose.equivalence)] )) (do @ - [[_ _ valC] (poly.apply ($_ p.and - (poly.exactly dictionary.Dictionary) - poly.any - equivalence))] + [[_ _ valC] (<type>.apply ($_ p.and + (<type>.exactly dictionary.Dictionary) + <type>.any + equivalence))] (wrap (` (: (~ (@Equivalence inputT)) ((~! dictionary.equivalence) (~ valC)))))) ## Models (~~ (template [<type> <eq>] [(do @ - [_ (poly.exactly <type>)] + [_ (<type>.exactly <type>)] (wrap (` (: (~ (@Equivalence inputT)) <eq>))))] @@ -99,13 +100,13 @@ [month.Month month.equivalence] )) (do @ - [_ (poly.apply (p.and (poly.exactly unit.Qty) - poly.any))] + [_ (<type>.apply (p.and (<type>.exactly unit.Qty) + <type>.any))] (wrap (` (: (~ (@Equivalence inputT)) unit.equivalence)))) ## Variants (do @ - [members (poly.variant (p.many equivalence)) + [members (<type>.variant (p.many equivalence)) #let [g!_ (code.local-identifier "_____________") g!left (code.local-identifier "_____________left") g!right (code.local-identifier "_____________right")]] @@ -121,7 +122,7 @@ #0)))))) ## Tuples (do @ - [g!eqs (poly.tuple (p.many equivalence)) + [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) @@ -133,29 +134,29 @@ (` ((~ g!eq) (~ g!left) (~ g!right))))))))))))) ## Type recursion (do @ - [[g!self bodyC] (poly.recursive equivalence) + [[g!self bodyC] (<type>.recursive equivalence) #let [g!_ (code.local-identifier "_____________")]] (wrap (` (: (~ (@Equivalence inputT)) ((~! /.rec) (.function ((~ g!_) (~ g!self)) (~ bodyC))))))) - poly.recursive-self + <type>.recursive-self ## Type applications (do @ - [[funcC argsC] (poly.apply (p.and equivalence (p.many equivalence)))] + [[funcC argsC] (<type>.apply (p.and equivalence (p.many equivalence)))] (wrap (` ((~ funcC) (~+ argsC))))) ## Parameters - poly.parameter + <type>.parameter ## Polymorphism (do @ - [[funcC varsC bodyC] (poly.polymorphic equivalence)] + [[funcC varsC bodyC] (<type>.polymorphic equivalence)] (wrap (` (: (All [(~+ varsC)] (-> (~+ (list@map (|>> (~) ((~! /.Equivalence)) (`)) varsC)) ((~! /.Equivalence) ((~ (poly.to-code *env* inputT)) (~+ varsC))))) (function ((~ funcC) (~+ varsC)) (~ bodyC)))))) - poly.recursive-call + <type>.recursive-call ## If all else fails... - (|> poly.any + (|> <type>.any (:: @ map (|>> %type (format "Cannot create Equivalence for: ") p.fail)) (:: @ join)) )))) diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux index 947f08ac8..4a2d44e38 100644 --- a/stdlib/source/lux/macro/poly/functor.lux +++ b/stdlib/source/lux/macro/poly/functor.lux @@ -4,7 +4,8 @@ [monad (#+ Monad do)] ["." functor]] [control - ["p" parser]] + ["p" parser + ["<.>" type]]] [data ["." product] ["." text @@ -23,10 +24,10 @@ [#let [type-funcC (code.local-identifier "____________type-funcC") funcC (code.local-identifier "____________funcC") inputC (code.local-identifier "____________inputC")] - *env* poly.env - inputT poly.peek - [polyC varsC non-functorT] (poly.local (list inputT) - (poly.polymorphic poly.any)) + *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) @@ -35,18 +36,18 @@ (let [paramsC (|> num-vars dec list.indices (list;map (|>> %n code.local-identifier)))] (` (All [(~+ paramsC)] ((~! functor.Functor) ((~ (poly.to-code *env* unwrappedT)) (~+ paramsC))))))))) - Arg<?> (: (-> Code (poly.Poly Code)) + Arg<?> (: (-> Code (<type>.Poly Code)) (function (Arg<?> valueC) ($_ p.either ## Type-var (do p.monad [#let [varI (|> num-vars (n/* 2) dec)] - _ (poly.parameter! varI)] + _ (<type>.parameter! varI)] (wrap (` ((~ funcC) (~ valueC))))) ## Variants (do @ [_ (wrap []) - membersC (poly.variant (p.many (Arg<?> valueC)))] + membersC (<type>.variant (p.many (Arg<?> valueC)))] (wrap (` (case (~ valueC) (~+ (list;join (list;map (function (_ [tag memberC]) (list (` ((~ (code.nat tag)) (~ valueC))) @@ -54,17 +55,17 @@ (list.enumerate membersC)))))))) ## Tuples (do p.monad - [pairsCC (: (poly.Poly (List [Code Code])) - (poly.tuple (loop [idx 0 - pairsCC (: (List [Code Code]) - (list))] - (p.either (let [slotC (|> idx %n (format "____________slot") code.local-identifier)] - (do @ - [_ (wrap []) - memberC (Arg<?> slotC)] - (recur (inc idx) - (list;compose pairsCC (list [slotC memberC]))))) - (wrap pairsCC)))))] + [pairsCC (: (<type>.Poly (List [Code Code])) + (<type>.tuple (loop [idx 0 + pairsCC (: (List [Code Code]) + (list))] + (p.either (let [slotC (|> idx %n (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))])))) @@ -73,7 +74,7 @@ [_ (wrap []) #let [g! (code.local-identifier "____________") outL (code.local-identifier "____________outL")] - [inT+ outC] (poly.function (p.many poly.any) + [inT+ outC] (<type>.function (p.many <type>.any) (Arg<?> outL)) #let [inC+ (|> (list.size inT+) list.indices @@ -83,15 +84,15 @@ (~ outC)))))) ## Recursion (do p.monad - [_ poly.recursive-call] + [_ <type>.recursive-call] (wrap (` ((~' map) (~ funcC) (~ valueC))))) ## Parameters (do p.monad - [_ poly.any] + [_ <type>.any] (wrap valueC)) )))] - [_ _ outputC] (: (poly.Poly [Code (List Code) Code]) - (p.either (poly.polymorphic + [_ _ outputC] (: (<type>.Poly [Code (List Code) Code]) + (p.either (<type>.polymorphic (Arg<?> inputC)) (p.fail (format "Cannot create Functor for: " (%type inputT)))))] (wrap (` (: (~ (@Functor inputT)) diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux index f397de2a2..e0e122eb1 100644 --- a/stdlib/source/lux/macro/poly/json.lux +++ b/stdlib/source/lux/macro/poly/json.lux @@ -5,7 +5,8 @@ [equivalence (#+ Equivalence)] ["." codec]] [control - ["p" parser]] + ["p" parser + ["<.>" type]]] [data ["." bit] maybe @@ -97,15 +98,15 @@ (wrap (` (: (~ (@JSON//encode inputT)) <encoder>))))] - [(poly.exactly Any) (function ((~ g!_) (~ (code.identifier ["" "0"]))) #/.Null)] - [(poly.sub Bit) (|>> #/.Boolean)] - [(poly.sub Nat) (:: (~! ..nat-codec) (~' encode))] - [(poly.sub Int) (:: (~! ..int-codec) (~' encode))] - [(poly.sub Frac) (|>> #/.Number)] - [(poly.sub Text) (|>> #/.String)]) + [(<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 @ - [_ (poly.exactly <type>)] + [_ (<type>.exactly <type>)] (wrap (` (: (~ (@JSON//encode inputT)) (|>> (:: (~! <codec>) (~' encode)) #/.String)))))] @@ -115,27 +116,27 @@ [day.Day day.codec] [month.Month month.codec])] (do @ - [*env* poly.env + [*env* <type>.env #let [@JSON//encode (: (-> Type Code) (function (_ type) (` (-> (~ (poly.to-code *env* type)) /.JSON))))] - inputT poly.peek] + inputT <type>.peek] ($_ p.either <basic> <time> (do @ - [unitT (poly.apply (p.after (poly.exactly unit.Qty) - poly.any))] + [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=] (poly.apply ($_ p.and - (poly.exactly d.Dictionary) - (poly.exactly .Text) - codec//encode))] + [_ _ =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)]) @@ -143,21 +144,21 @@ ((~! d.from-list) (~! text.hash)) #/.Object))))) (do @ - [[_ =sub=] (poly.apply ($_ p.and - (poly.exactly .Maybe) - codec//encode))] + [[_ =sub=] (<type>.apply ($_ p.and + (<type>.exactly .Maybe) + codec//encode))] (wrap (` (: (~ (@JSON//encode inputT)) ((~! ..nullable) (~ =sub=)))))) (do @ - [[_ =sub=] (poly.apply ($_ p.and - (poly.exactly .List) - codec//encode))] + [[_ =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 (poly.variant (p.many codec//encode))] + members (<type>.variant (p.many codec//encode))] (wrap (` (: (~ (@JSON//encode inputT)) (function ((~ g!_) (~ g!input)) (case (~ g!input) @@ -167,7 +168,7 @@ ((~ g!encode) (~ g!input))])))) (list.enumerate members)))))))))) (do @ - [g!encoders (poly.tuple (p.many codec//encode)) + [g!encoders (<type>.tuple (p.many codec//encode)) #let [g!_ (code.local-identifier "_______") g!members (|> (list.size g!encoders) list.indices @@ -179,19 +180,19 @@ (list.zip2 g!members g!encoders)))])))))) ## Type recursion (do @ - [[selfC non-recC] (poly.recursive codec//encode) + [[selfC non-recC] (<type>.recursive codec//encode) #let [g! (code.local-identifier "____________")]] (wrap (` (: (~ (@JSON//encode inputT)) ((~! ..rec-encode) (.function ((~ g!) (~ selfC)) (~ non-recC))))))) - poly.recursive-self + <type>.recursive-self ## Type applications (do @ - [partsC (poly.apply (p.many codec//encode))] + [partsC (<type>.apply (p.many codec//encode))] (wrap (` ((~+ partsC))))) ## Polymorphism (do @ - [[funcC varsC bodyC] (poly.polymorphic codec//encode)] + [[funcC varsC bodyC] (<type>.polymorphic codec//encode)] (wrap (` (: (All [(~+ varsC)] (-> (~+ (list@map (function (_ varC) (` (-> (~ varC) /.JSON))) varsC)) @@ -199,8 +200,8 @@ /.JSON))) (function ((~ funcC) (~+ varsC)) (~ bodyC)))))) - poly.parameter - poly.recursive-call + <type>.parameter + <type>.recursive-call ## If all else fails... (p.fail (format "Cannot create JSON encoder for: " (type.to-text inputT))) )))) @@ -213,15 +214,15 @@ (wrap (` (: (~ (@JSON//decode inputT)) (~! <decoder>)))))] - [(poly.exactly Any) /.null] - [(poly.sub Bit) /.boolean] - [(poly.sub Nat) (p.codec ..nat-codec /.any)] - [(poly.sub Int) (p.codec ..int-codec /.any)] - [(poly.sub Frac) /.number] - [(poly.sub Text) /.string]) + [(<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 @ - [_ (poly.exactly <type>)] + [_ (<type>.exactly <type>)] (wrap (` (: (~ (@JSON//decode inputT)) ((~! p.codec) (~! <codec>) (~! /.string))))))] @@ -232,38 +233,38 @@ [month.Month month.codec]) ] (do @ - [*env* poly.env + [*env* <type>.env #let [@JSON//decode (: (-> Type Code) (function (_ type) (` (/.Reader (~ (poly.to-code *env* type))))))] - inputT poly.peek] + inputT <type>.peek] ($_ p.either <basic> <time> (do @ - [unitT (poly.apply (p.after (poly.exactly unit.Qty) - poly.any))] + [unitT (<type>.apply (p.after (<type>.exactly unit.Qty) + <type>.any))] (wrap (` (: (~ (@JSON//decode inputT)) ((~! p.codec) (~! qty-codec) (~! /.any)))))) (do @ - [[_ _ valC] (poly.apply ($_ p.and - (poly.exactly d.Dictionary) - (poly.exactly .Text) - codec//decode))] + [[_ _ valC] (<type>.apply ($_ p.and + (<type>.exactly d.Dictionary) + (<type>.exactly .Text) + codec//decode))] (wrap (` (: (~ (@JSON//decode inputT)) ((~! /.dictionary) (~ valC)))))) (do @ - [[_ subC] (poly.apply (p.and (poly.exactly .Maybe) - codec//decode))] + [[_ subC] (<type>.apply (p.and (<type>.exactly .Maybe) + codec//decode))] (wrap (` (: (~ (@JSON//decode inputT)) ((~! /.nullable) (~ subC)))))) (do @ - [[_ subC] (poly.apply (p.and (poly.exactly .List) - codec//decode))] + [[_ subC] (<type>.apply (p.and (<type>.exactly .List) + codec//decode))] (wrap (` (: (~ (@JSON//decode inputT)) ((~! /.array) ((~! p.some) (~ subC))))))) (do @ - [members (poly.variant (p.many codec//decode))] + [members (<type>.variant (p.many codec//decode))] (wrap (` (: (~ (@JSON//decode inputT)) ($_ ((~! p.or)) (~+ (list@map (function (_ [tag memberC]) @@ -272,31 +273,31 @@ ((~! /.array))))) (list.enumerate members)))))))) (do @ - [g!decoders (poly.tuple (p.many codec//decode))] + [g!decoders (<type>.tuple (p.many codec//decode))] (wrap (` (: (~ (@JSON//decode inputT)) ((~! /.array) ($_ ((~! p.and)) (~+ g!decoders))))))) ## Type recursion (do @ - [[selfC bodyC] (poly.recursive codec//decode) + [[selfC bodyC] (<type>.recursive codec//decode) #let [g! (code.local-identifier "____________")]] (wrap (` (: (~ (@JSON//decode inputT)) ((~! p.rec) (.function ((~ g!) (~ selfC)) (~ bodyC))))))) - poly.recursive-self + <type>.recursive-self ## Type applications (do @ - [[funcC argsC] (poly.apply (p.and codec//decode (p.many codec//decode)))] + [[funcC argsC] (<type>.apply (p.and codec//decode (p.many codec//decode)))] (wrap (` ((~ funcC) (~+ argsC))))) ## Polymorphism (do @ - [[funcC varsC bodyC] (poly.polymorphic codec//decode)] + [[funcC varsC bodyC] (<type>.polymorphic codec//decode)] (wrap (` (: (All [(~+ varsC)] (-> (~+ (list@map (|>> (~) /.Reader (`)) varsC)) (/.Reader ((~ (poly.to-code *env* inputT)) (~+ varsC))))) (function ((~ funcC) (~+ varsC)) (~ bodyC)))))) - poly.parameter - poly.recursive-call + <type>.parameter + <type>.recursive-call ## If all else fails... (p.fail (format "Cannot create JSON decoder for: " (type.to-text inputT))) )))) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 08bc451b1..ab5d2e1d4 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -59,7 +59,9 @@ ## ["._" concatenative] ## ["._" predicate] ## [monad - ## ["._" free]]] + ## ["._" free]] + ## [parser + ## [type (#+)]]] ## [data ## ["._" env] ## ["._" trace] @@ -345,5 +347,6 @@ (program: args (<| io _.run! - (_.times 100) + ## (_.times 100) + (_.seed 8070500311708372420) ..test)) |