From eb770f4473a904285ea559279331a93cdb5b7ded Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Thu, 19 Oct 2017 13:40:34 -0400
Subject: - Implemented an more comfortable alternative to "with-expansions".

---
 stdlib/source/lux.lux                        |  65 +++++++-
 stdlib/source/lux/data/coll/ordered/dict.lux |  34 ++--
 stdlib/source/lux/meta/poly/eq.lux           | 228 +++++++++++++--------------
 3 files changed, 189 insertions(+), 138 deletions(-)

(limited to 'stdlib/source')

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))
+            ))))
-- 
cgit v1.2.3