diff options
Diffstat (limited to 'stdlib/source/lux/macro/poly/equality.lux')
| -rw-r--r-- | stdlib/source/lux/macro/poly/equality.lux | 150 |
1 files changed, 150 insertions, 0 deletions
diff --git a/stdlib/source/lux/macro/poly/equality.lux b/stdlib/source/lux/macro/poly/equality.lux new file mode 100644 index 000000000..4cf8b2de0 --- /dev/null +++ b/stdlib/source/lux/macro/poly/equality.lux @@ -0,0 +1,150 @@ +(.module: + lux + (lux (control [monad #+ do Monad] + ["eq" equality] + ["p" parser]) + (data [text "text/" Monoid<Text>] + text/format + (coll [list "list/" Monad<List>] + [sequence] + [array] + [queue] + (set ["set" unordered]) + (dictionary ["dict" unordered #+ Dict]) + (tree [rose])) + [number "nat/" Codec<Text,Nat>] + [product] + [bool] + [maybe]) + (time ["du" duration] + ["da" date] + ["i" instant]) + [macro] + (macro [code] + [syntax #+ syntax: Syntax] + (syntax [common]) + [poly #+ poly:]) + (type [unit]) + (lang [type]) + )) + +## [Derivers] +(poly: #export Eq<?> + (`` (do @ + [#let [g!_ (code.local-symbol "_____________")] + *env* poly.env + inputT poly.peek + #let [@Eq (: (-> Type Code) + (function (_ type) + (` (eq.Eq (~ (poly.to-code *env* type))))))]] + ($_ p.either + ## Basic types + (~~ (do-template [<matcher> <eq>] + [(do @ + [_ <matcher>] + (wrap (` (: (~ (@Eq inputT)) + <eq>))))] + + [(poly.this Top) (function ((~ g!_) (~ g!_) (~ g!_)) true)] + [(poly.like Bool) bool.Eq<Bool>] + [(poly.like Nat) number.Eq<Nat>] + [(poly.like Int) number.Eq<Int>] + [(poly.like Deg) number.Eq<Deg>] + [(poly.like Frac) number.Eq<Frac>] + [(poly.like Text) text.Eq<Text>])) + ## Composite types + (~~ (do-template [<name> <eq>] + [(do @ + [[_ argC] (poly.apply (p.seq (poly.this <name>) + Eq<?>))] + (wrap (` (: (~ (@Eq inputT)) + (<eq> (~ argC))))))] + + [.Maybe maybe.Eq<Maybe>] + [.List list.Eq<List>] + [sequence.Sequence sequence.Eq<Sequence>] + [.Array array.Eq<Array>] + [queue.Queue queue.Eq<Queue>] + [set.Set set.Eq<Set>] + [rose.Tree rose.Eq<Tree>] + )) + (do @ + [[_ _ valC] (poly.apply ($_ p.seq + (poly.this dict.Dict) + poly.any + Eq<?>))] + (wrap (` (: (~ (@Eq inputT)) + (dict.Eq<Dict> (~ valC)))))) + ## Models + (~~ (do-template [<type> <eq>] + [(do @ + [_ (poly.this <type>)] + (wrap (` (: (~ (@Eq inputT)) + <eq>))))] + + [du.Duration du.Eq<Duration>] + [i.Instant i.Eq<Instant>] + [da.Date da.Eq<Date>] + [da.Day da.Eq<Day>] + [da.Month da.Eq<Month>])) + (do @ + [_ (poly.apply (p.seq (poly.this unit.Qty) + poly.any))] + (wrap (` (: (~ (@Eq inputT)) + unit.Eq<Qty>)))) + ## Variants + (do @ + [members (poly.variant (p.many Eq<?>)) + #let [g!_ (code.local-symbol "_____________") + g!left (code.local-symbol "_____________left") + g!right (code.local-symbol "_____________right")]] + (wrap (` (: (~ (@Eq 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!_) + false)))))) + ## Tuples + (do @ + [g!eqs (poly.tuple (p.many Eq<?>)) + #let [g!_ (code.local-symbol "_____________") + indices (|> (list.size g!eqs) dec (list.n/range +0)) + g!lefts (list/map (|>> nat/encode (text/compose "left") code.local-symbol) indices) + g!rights (list/map (|>> nat/encode (text/compose "right") code.local-symbol) indices)]] + (wrap (` (: (~ (@Eq 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] (poly.recursive Eq<?>) + #let [g!_ (code.local-symbol "_____________")]] + (wrap (` (: (~ (@Eq inputT)) + (eq.rec (.function ((~ g!_) (~ g!self)) + (~ bodyC))))))) + poly.recursive-self + ## Type applications + (do @ + [[funcC argsC] (poly.apply (p.seq Eq<?> (p.many Eq<?>)))] + (wrap (` ((~ funcC) (~+ argsC))))) + ## Bound type-vars + poly.bound + ## Polymorphism + (do @ + [[funcC varsC bodyC] (poly.polymorphic Eq<?>)] + (wrap (` (: (All [(~+ varsC)] + (-> (~+ (list/map (|>> (~) eq.Eq (`)) varsC)) + (eq.Eq ((~ (poly.to-code *env* inputT)) (~+ varsC))))) + (function ((~ funcC) (~+ varsC)) + (~ bodyC)))))) + poly.recursive-call + ## If all else fails... + (|> poly.any + (:: @ map (|>> %type (format "Cannot create Eq for: ") p.fail)) + (:: @ join)) + )))) |