aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux.lux65
-rw-r--r--stdlib/source/lux/data/coll/ordered/dict.lux34
-rw-r--r--stdlib/source/lux/meta/poly/eq.lux228
3 files changed, 189 insertions, 138 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 205f1a543..fd8948164 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -4556,8 +4556,8 @@
## =>
(function [<arg>]
(fold text/compose \"\"
- (interpose \" \"
- (map int/encode <arg>))))"}
+ (interpose \" \"
+ (map int/encode <arg>))))"}
(do Monad<Meta>
[g!arg (gensym "arg")]
(return (list (` (function [(~ g!arg)] (|> (~ g!arg) (~@ tokens))))))))
@@ -4568,8 +4568,8 @@
## =>
(function [<arg>]
(fold text/compose \"\"
- (interpose \" \"
- (map int/encode <arg>))))"}
+ (interpose \" \"
+ (map int/encode <arg>))))"}
(do Monad<Meta>
[g!arg (gensym "arg")]
(return (list (` (function [(~ g!arg)] (<| (~@ tokens) (~ g!arg))))))))
@@ -5906,3 +5906,60 @@
_
(fail "Wrong syntax for 'for'"))))
+
+(do-template [<name> <type> <output>]
+ [(def: (<name> xy)
+ (All [a b] (-> [a b] <type>))
+ (let [[x y] xy]
+ <output>))]
+
+ [left a x]
+ [right b y])
+
+(def: (label-code code)
+ (-> Code (Meta [(List [Code Code]) Code]))
+ (case code
+ (^ [ann (#Form (list [_ (#Symbol ["" "~~"])] expansion))])
+ (do Monad<Meta>
+ [g!expansion (gensym "g!expansion")]
+ (wrap [(list [g!expansion expansion]) g!expansion]))
+
+ (^template [<tag>]
+ [ann (<tag> parts)]
+ (do Monad<Meta>
+ [=parts (mapM Monad<Meta> label-code parts)]
+ (wrap [(fold list/compose (list) (map left =parts))
+ [ann (<tag> (map right =parts))]])))
+ ([#Form] [#Tuple])
+
+ [ann (#Record kvs)]
+ (do Monad<Meta>
+ [=kvs (mapM Monad<Meta>
+ (function [[key val]]
+ (do Monad<Meta>
+ [=key (label-code key)
+ =val (label-code val)
+ #let [[key-labels key-labelled] =key
+ [val-labels val-labelled] =val]]
+ (wrap [(list/compose key-labels val-labels) [key-labelled val-labelled]])))
+ kvs)]
+ (wrap [(fold list/compose (list) (map left =kvs))
+ [ann (#Record (map right =kvs))]]))
+
+ _
+ (:: Monad<Meta> wrap [(list) code])))
+
+(macro: #export (`` tokens)
+ (case tokens
+ (^ (list raw))
+ (do Monad<Meta>
+ [=raw (label-code raw)
+ #let [[labels labelled] =raw]]
+ (wrap (list (` (with-expansions [(~@ (|> labels
+ (map (function [[label expansion]] (list label expansion)))
+ list/join))]
+ (~ labelled))))))
+
+ _
+ (fail "Wrong syntax for ``")
+ ))
diff --git a/stdlib/source/lux/data/coll/ordered/dict.lux b/stdlib/source/lux/data/coll/ordered/dict.lux
index 21cd20eb8..1151a018b 100644
--- a/stdlib/source/lux/data/coll/ordered/dict.lux
+++ b/stdlib/source/lux/data/coll/ordered/dict.lux
@@ -251,24 +251,22 @@
(#;Some root)
(let [reference (get@ #key root)]
- (with-expansions
- [<sides> (do-template [<comp> <tag> <add>]
- [(<comp> reference key)
- (let [side-root (get@ <tag> root)
- outcome (recur side-root)]
- (if (is side-root outcome)
- ?root
- (#;Some (<add> (maybe;assume outcome)
- root))))]
-
- [T/< #left add-left]
- [T/> #right add-right]
- )]
- (cond <sides>
-
- ## (T/= reference key)
- ?root
- )))
+ (`` (cond (~~ (do-template [<comp> <tag> <add>]
+ [(<comp> reference key)
+ (let [side-root (get@ <tag> root)
+ outcome (recur side-root)]
+ (if (is side-root outcome)
+ ?root
+ (#;Some (<add> (maybe;assume outcome)
+ root))))]
+
+ [T/< #left add-left]
+ [T/> #right add-right]
+ ))
+
+ ## (T/= reference key)
+ ?root
+ )))
))]
(set@ #root root' dict)))
diff --git a/stdlib/source/lux/meta/poly/eq.lux b/stdlib/source/lux/meta/poly/eq.lux
index 86a373a4c..c2ecd5988 100644
--- a/stdlib/source/lux/meta/poly/eq.lux
+++ b/stdlib/source/lux/meta/poly/eq.lux
@@ -30,122 +30,118 @@
## [Derivers]
(poly: #export Eq<?>
- (with-expansions
- [<basic> (do-template [<matcher> <eq>]
- [(do @
- [_ <matcher>]
- (wrap (` (: (~ (@Eq inputT))
- <eq>))))]
+ (`` (do @
+ [#let [g!_ (code;local-symbol "\u0000_")]
+ *env* poly;env
+ inputT poly;peek
+ #let [@Eq (: (-> Type Code)
+ (function [type]
+ (` (eq;Eq (~ (poly;to-ast *env* type))))))]]
+ ($_ p;either
+ ## Primitive types
+ (~~ (do-template [<matcher> <eq>]
+ [(do @
+ [_ <matcher>]
+ (wrap (` (: (~ (@Eq inputT))
+ <eq>))))]
- [poly;unit (function [(~ g!_) (~ g!_)] true)]
- [poly;bool bool;Eq<Bool>]
- [poly;nat number;Eq<Nat>]
- [poly;int number;Eq<Int>]
- [poly;deg number;Eq<Deg>]
- [poly;frac number;Eq<Frac>]
- [poly;text text;Eq<Text>])
- <time> (do-template [<type> <eq>]
- [(do @
- [_ (poly;this <type>)]
- (wrap (` (: (~ (@Eq inputT))
- <eq>))))]
+ [poly;unit (function [(~ g!_) (~ g!_)] true)]
+ [poly;bool bool;Eq<Bool>]
+ [poly;nat number;Eq<Nat>]
+ [poly;int number;Eq<Int>]
+ [poly;deg number;Eq<Deg>]
+ [poly;frac number;Eq<Frac>]
+ [poly;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))))))]
- [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>])
- <composites> (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>))))]
- [;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 @
- [#let [g!_ (code;local-symbol "\u0000_")]
- *env* poly;env
- inputT poly;peek
- #let [@Eq (: (-> Type Code)
- (function [type]
- (` (eq;Eq (~ (poly;to-ast *env* type))))))]]
- ($_ p;either
- ## Primitive types
- <basic>
- ## Composite types
- <composites>
- (do @
- [[_ _ valC] (poly;apply ($_ p;seq
- (poly;this dict;Dict)
- poly;any
- Eq<?>))]
- (wrap (` (: (~ (@Eq inputT))
- (dict;Eq<Dict> (~ valC))))))
- ## Models
- <time>
- (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!left (code;local-symbol "\u0000left")
- g!right (code;local-symbol "\u0000right")]]
- (wrap (` (: (~ (@Eq inputT))
- (function [(~ 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 [indices (|> (list;size g!eqs) n.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!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<?>)]
- (wrap (` (: (~ (@Eq inputT))
- (eq;rec (;function [(~ 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-ast *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))
- ))))
+ [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!left (code;local-symbol "\u0000left")
+ g!right (code;local-symbol "\u0000right")]]
+ (wrap (` (: (~ (@Eq inputT))
+ (function [(~ 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 [indices (|> (list;size g!eqs) n.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!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<?>)]
+ (wrap (` (: (~ (@Eq inputT))
+ (eq;rec (;function [(~ 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-ast *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))
+ ))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-10 00:51:16 +0000