- Re-implemented polytypic matchers in terms of lux/control/parser.

7 files changed, 627 insertions, 640 deletions

diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 30f38897b..caf38c7b6 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -2598,7 +2598,7 @@
     (#Cons [_ (#Symbol "" name)] (#Cons body #Nil))
     (let' [body' (replace-syntax (list [name (` (#Apply (~ (make-bound +1)) (~ (make-bound +0))))])
                                  (update-bounds body))]
-          (return (list (` (#Apply Void (#UnivQ #Nil (~ body')))))))
+          (return (list (` (#Apply #;Void (#UnivQ #Nil (~ body')))))))
     
     _
     (fail "Wrong syntax for Rec")))
diff --git a/stdlib/source/lux/data/format/json/codec.lux b/stdlib/source/lux/data/format/json/codec.lux
index 98e3874fd..073d3636b 100644
--- a/stdlib/source/lux/data/format/json/codec.lux
+++ b/stdlib/source/lux/data/format/json/codec.lux
@@ -4,7 +4,7 @@
   lux
   (lux (control functor
                 applicative
-                ["M" monad #+ do Monad]
+                [monad #+ do Monad]
                 [eq #+ Eq]
                 codec
                 ["p" parser "p/" Monad<Parser>])
@@ -191,200 +191,175 @@
   (function [input]
     (non-rec (rec-encode non-rec) input)))
 
-(poly: #hidden (Codec<JSON,?>//encode env :x:)
-  (let [->Codec//encode (: (-> Code Code)
-                           (function [.type.] (` (-> (~ .type.) ..;JSON))))]
-    (with-expansions
-      [<basic> (do-template [<type> <matcher> <encoder>]
-                 [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//encode (` <type>))) <encoder>))))]
+(poly: #hidden Codec<JSON,?>//encode
+  (with-expansions
+    [<basic> (do-template [<type> <matcher> <encoder>]
+               [(do @
+                  [_ <matcher>]
+                  (wrap (` (: (~ (@JSON//encode inputT))
+                              <encoder>))))]
 
-                 [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)]
-                 [Bool poly;bool ..;boolean]
-                 [Real poly;real ..;number]
-                 [Text poly;text ..;string])]
-      ($_ macro;either
+               [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)]
+               [Bool poly;bool ..;boolean]
+               [Real poly;real ..;number]
+               [Text poly;text ..;string])]
+    (do @
+      [*env* poly;env
+       #let [@JSON//encode (: (-> Type Code)
+                              (function [type]
+                                (` (-> (~ (poly;to-ast *env* type)) ..;JSON))))]
+       inputT poly;peek]
+      ($_ p;either
           <basic>
-          (with-gensyms [g!input g!key g!val]
-            (do @
-              [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:)
-               _ (poly;text :key:)
-               .val. (Codec<JSON,?>//encode env :val:)]
-              (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
-                          (function [(~ g!input)]
-                            (|> (~ g!input)
-                                d;entries
-                                (;;_map_ (: (-> [Text (~ (poly;to-ast env :val:))]
-                                                [Text ..;JSON])
-                                            (function [[(~ g!key) (~ g!val)]]
-                                              [(~ g!key)
-                                               ((~ .val.) (~ g!val))])))
-                                (d;from-list text;Hash<Text>)
-                                #..;Object))
-                          )))))
           (do @
-            [:sub: (poly;apply-1 (ident-for ;Maybe) :x:)
-             .sub. (Codec<JSON,?>//encode env :sub:)]
-            (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
+            [#let [g!key (code;local-symbol "\u0000key")
+                   g!val (code;local-symbol "\u0000val")]
+             [_ _ .val.] (poly;apply ($_ p;seq
+                                         (poly;named (ident-for d;Dict))
+                                         poly;text
+                                         Codec<JSON,?>//encode))]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (|>. d;entries
+                             (;;_map_ (function [[(~ g!key) (~ g!val)]]
+                                        [(~ g!key) ((~ .val.) (~ g!val))]))
+                             (d;from-list text;Hash<Text>)
+                             #..;Object)))))
+          (do @
+            [[_ .sub.] (poly;apply ($_ p;seq
+                                       (poly;named (ident-for ;Maybe))
+                                       Codec<JSON,?>//encode))]
+            (wrap (` (: (~ (@JSON//encode inputT))
                         (..;nullable (~ .sub.))))))
           (do @
-            [:sub: (poly;apply-1 (ident-for ;List) :x:)
-             .sub. (Codec<JSON,?>//encode env :sub:)]
-            (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
+            [[_ .sub.] (poly;apply ($_ p;seq
+                                       (poly;named (ident-for ;List))
+                                       Codec<JSON,?>//encode))]
+            (wrap (` (: (~ (@JSON//encode inputT))
                         (|>. (;;_map_ (~ .sub.)) vector;from-list ..;array)))))
-          (with-gensyms [g!input]
-            (do @
-              [members (poly;sum+ :x:)
-               pattern-matching (M;map @
-                                       (function [[tag :case:]]
-                                         (do @
-                                           [g!encode (Codec<JSON,?>//encode env :case:)]
-                                           (wrap (list (` ((~ (code;nat tag)) (~ g!input)))
+          (do @
+            [#let [g!input (code;local-symbol "\u0000input")]
+             members (poly;variant (p;many Codec<JSON,?>//encode))]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (function [(~ g!input)]
+                          (case (~ g!input)
+                            (~@ (L/join (L/map (function [[tag g!encode]]
+                                                 (list (` ((~ (code;nat tag)) (~ g!input)))
                                                        (` (..;json [(~ (code;real (;;tag tag)))
-                                                                    ((~ g!encode) (~ g!input))]))))))
-                                       (list;enumerate members))]
-              (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
-                          (function [(~ g!input)]
-                            (case (~ g!input)
-                              (~@ (L/join pattern-matching)))))))))
+                                                                    ((~ g!encode) (~ g!input))]))))
+                                               (list;enumerate members))))))))))
           (do @
-            [members (poly;prod+ :x:)
-             #let [g!members (|> (list;size members) n.dec
+            [g!encoders (poly;tuple (p;many Codec<JSON,?>//encode))
+             #let [g!members (|> (list;size g!encoders) n.dec
                                  (list;n.range +0)
-                                 (L/map (|>. nat/encode code;local-symbol)))]
-             g!encoders (M;map @ (Codec<JSON,?>//encode env) members)]
-            (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
+                                 (L/map (|>. nat/encode code;local-symbol)))]]
+            (wrap (` (: (~ (@JSON//encode inputT))
                         (function [[(~@ g!members)]]
                           (..;json [(~@ (L/map (function [[g!member g!encode]]
                                                  (` ((~ g!encode) (~ g!member))))
-                                               (list;zip2 g!members g!encoders)))]))
-                        ))))
+                                               (list;zip2 g!members g!encoders)))]))))))
           ## Type recursion
-          (with-gensyms [g!rec]
-            (do @
-              [:non-rec: (poly;recursive :x:)
-               #let [new-env (poly;extend-env [:x: g!rec] (list [:x: (` (;undefined))]) env)]
-               .non-rec. (Codec<JSON,?>//encode new-env :non-rec:)]
-              (wrap (` (: (~ (poly;gen-type new-env ->Codec//encode g!rec (list) :x:))
-                          (;;rec-encode (;function [(~ g!rec)]
-                                          (~ .non-rec.))))))))
-          (poly;self env :x:)
-          (poly;recursion env :x:)
+          (do @
+            [[selfC non-recC] (poly;recursive Codec<JSON,?>//encode)]
+            (wrap (` (: (~ (@JSON//encode inputT))
+                        (;;rec-encode (;function [(~ selfC)]
+                                        (~ non-recC)))))))
+          poly;recursive-self
           ## Type applications
           (do @
-            [[:func: :args:] (poly;apply :x:)
-             .func. (Codec<JSON,?>//encode env :func:)
-             .args. (M;map @ (Codec<JSON,?>//encode env) :args:)]
-            (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
-                        ((~ .func.) (~@ .args.))))))
-          ## Bound type-vars
-          (poly;bound env :x:)
+            [partsC (poly;apply (p;many Codec<JSON,?>//encode))]
+            (wrap (` ((~@ partsC)))))
           ## Polymorphism
-          (with-gensyms [g!type-fun]
-            (do @
-              [[g!vars :non-poly:] (poly;polymorphic :x:)
-               #let [new-env (poly;extend-env [:x: g!type-fun]
-                                              (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
-                                              env)]
-               .non-poly. (Codec<JSON,?>//encode new-env :non-poly:)]
-              (wrap (` (: (All (~ g!type-fun) [(~@ g!vars)]
-                            (-> (~@ (L/map ->Codec//encode g!vars))
-                                (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))
-                          (function (~ g!type-fun) [(~@ g!vars)]
-                            (~ .non-poly.)))))))
+          (do @
+            [[funcC varsC bodyC] (poly;polymorphic Codec<JSON,?>//encode)]
+            (wrap (` (: (All [(~@ varsC)]
+                          (-> (~@ (L/map (function [varC] (` (->  (~ varC) ..;JSON)))
+                                         varsC))
+                              (-> ((~ (poly;to-ast *env* inputT)) (~@ varsC))
+                                  ..;JSON)))
+                        (function (~ funcC) [(~@ varsC)]
+                          (~ bodyC))))))
+          poly;bound
+          poly;recursive-call
           ## If all else fails...
-          (macro;fail ($_ text/append "Cannot create JSON encoder for: " (type;to-text :x:)))
+          (p;fail (text/append "Cannot create JSON encoder for: " (type;to-text inputT)))
           ))))
 
-(poly: #hidden (Codec<JSON,?>//decode env :x:)
-  (let [->Codec//decode (: (-> Code Code)
-                           (function [.type.] (` (..;Reader (~ .type.)))))]
-    (with-expansions
-      [<basic> (do-template [<type> <matcher> <decoder>]
-                 [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//decode (` <type>))) <decoder>))))]
+(poly: #hidden Codec<JSON,?>//decode
+  (with-expansions
+    [<basic> (do-template [<type> <matcher> <decoder>]
+               [(do @
+                  [_ <matcher>]
+                  (wrap (` (: (~ (@JSON//decode inputT))
+                              <decoder>))))]
 
-                 [Unit poly;unit ../reader;null]
-                 [Bool poly;bool ../reader;boolean]
-                 [Real poly;real ../reader;number]
-                 [Text poly;text ../reader;string])]
-      ($_ macro;either
+               [Unit poly;unit ../reader;null]
+               [Bool poly;bool ../reader;boolean]
+               [Real poly;real ../reader;number]
+               [Text poly;text ../reader;string])]
+    (do @
+      [*env* poly;env
+       #let [@JSON//decode (: (-> Type Code)
+                              (function [type]
+                                (` (..;Reader (~ (poly;to-ast *env* type))))))]
+       inputT poly;peek]
+      ($_ p;either
           <basic>
           (do @
-            [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:)
-             _ (poly;text :key:)
-             .val. (Codec<JSON,?>//decode env :val:)]
-            (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
-                        (../reader;object (~ .val.))))))
+            [[_ _ valC] (poly;apply ($_ p;seq
+                                        (poly;named (ident-for d;Dict))
+                                        poly;text
+                                        Codec<JSON,?>//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        (../reader;object (~ valC))))))
           (do @
-            [:sub: (poly;apply-1 (ident-for ;Maybe) :x:)
-             .sub. (Codec<JSON,?>//decode env :sub:)]
-            (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
-                        (../reader;nullable (~ .sub.))))))
+            [[_ subC] (poly;apply (p;seq (poly;named (ident-for ;Maybe))
+                                         Codec<JSON,?>//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        (../reader;nullable (~ subC))))))
           (do @
-            [:sub: (poly;apply-1 (ident-for ;List) :x:)
-             .sub. (Codec<JSON,?>//decode env :sub:)]
-            (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
-                        (../reader;array (p;some (~ .sub.)))))))
+            [[_ subC] (poly;apply (p;seq (poly;named (ident-for ;List))
+                                         Codec<JSON,?>//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        (../reader;array (p;some (~ subC)))))))
           (do @
-            [members (poly;sum+ :x:)
-             pattern-matching (M;map @
-                                     (function [[tag :case:]]
-                                       (do @
-                                         [g!decode (Codec<JSON,?>//decode env :case:)]
-                                         (wrap (list (` (|> (~ g!decode)
-                                                            (p;after (../reader;number! (~ (code;real (;;tag tag)))))
-                                                            ../reader;array))))))
-                                     (list;enumerate members))]
-            (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
+            [members (poly;variant (p;many Codec<JSON,?>//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
                         ($_ p;alt
-                            (~@ (L/join pattern-matching)))))))
+                            (~@ (L/map (function [[tag memberC]]
+                                         (` (|> (~ memberC)
+                                                (p;after (../reader;number! (~ (code;real (;;tag tag)))))
+                                                ../reader;array)))
+                                       (list;enumerate members))))))))
           (do @
-            [members (poly;prod+ :x:)
-             #let [g!members (|> (list;size members) n.dec
-                                 (list;n.range +0)
-                                 (L/map (|>. nat/encode code;local-symbol)))]
-             g!decoders (M;map @ (Codec<JSON,?>//decode env) members)]
-            (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
+            [g!decoders (poly;tuple (p;many Codec<JSON,?>//decode))]
+            (wrap (` (: (~ (@JSON//decode inputT))
                         (../reader;array ($_ p;seq (~@ g!decoders)))))))
           ## Type recursion
-          (with-gensyms [g!rec]
-            (do @
-              [:non-rec: (poly;recursive :x:)
-               #let [new-env (poly;extend-env [:x: g!rec] (list [:x: (` (;undefined))]) env)]
-               .non-rec. (Codec<JSON,?>//decode new-env :non-rec:)]
-              (wrap (` (: (~ (poly;gen-type new-env ->Codec//decode g!rec (list) :x:))
-                          (p;rec (;function [(~ g!rec)]
-                                   (~ .non-rec.))))))))
-          (poly;self env :x:)
-          (poly;recursion env :x:)
-          ## Type applications
           (do @
-            [[:func: :args:] (poly;apply :x:)
-             .func. (Codec<JSON,?>//decode env :func:)
-             .args. (M;map @ (Codec<JSON,?>//decode env) :args:)]
-            (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
-                        ((~ .func.) (~@ .args.))))))
-          ## Bound type-vars
+            [[selfC bodyC] (poly;recursive Codec<JSON,?>//decode)]
+            (wrap (` (: (~ (@JSON//decode inputT))
+                        (p;rec (;function [(~ selfC)]
+                                 (~ bodyC)))))))
+          poly;recursive-self
+          ## Type applications
           (do @
-            [g!bound (poly;bound env :x:)]
-            (wrap g!bound))
+            [[funcC argsC] (poly;apply (p;seq Codec<JSON,?>//decode (p;many Codec<JSON,?>//decode)))]
+            (wrap (` ((~ funcC) (~@ argsC)))))
           ## Polymorphism
-          (with-gensyms [g!type-fun]
-            (do @
-              [[g!vars :non-poly:] (poly;polymorphic :x:)
-               #let [new-env (poly;extend-env [:x: g!type-fun]
-                                              (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
-                                              env)]
-               .non-poly. (Codec<JSON,?>//decode new-env :non-poly:)]
-              (wrap (` (: (All (~ g!type-fun) [(~@ g!vars)]
-                            (-> (~@ (L/map ->Codec//decode g!vars))
-                                (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))
-                          (function (~ g!type-fun) [(~@ g!vars)]
-                            (~ .non-poly.)))))))
+          (do @
+            [[funcC varsC bodyC] (poly;polymorphic Codec<JSON,?>//decode)]
+            (wrap (` (: (All [(~@ varsC)]
+                          (-> (~@ (L/map (|>. (~) ..;Reader (`)) varsC))
+                              (..;Reader ((~ (poly;to-ast *env* inputT)) (~@ varsC)))))
+                        (function (~ funcC) [(~@ varsC)]
+                          (~ bodyC))))))
+          poly;bound
+          poly;recursive-call
           ## If all else fails...
-          (macro;fail ($_ text/append "Cannot create JSON decoder for: " (type;to-text :x:)))
+          (p;fail (text/append "Cannot create JSON decoder for: " (type;to-text inputT)))
           ))))
 
-(syntax: #export (Codec<JSON,?> :x:)
+(syntax: #export (Codec<JSON,?> inputT)
   {#;doc (doc "A macro for automatically producing JSON codecs."
               (type: Variant
                 (#Case0 Bool)
@@ -404,7 +379,7 @@
 
               (derived: (Codec<JSON,?> Record)))}
   (with-gensyms [g!inputs]
-    (wrap (list (` (: (Codec ..;JSON (~ :x:))
-                      (struct (def: (~' encode) (Codec<JSON,?>//encode (~ :x:)))
-                              (def: ((~' decode) (~ g!inputs)) (../reader;run (~ g!inputs) (Codec<JSON,?>//decode (~ :x:))))
+    (wrap (list (` (: (Codec ..;JSON (~ inputT))
+                      (struct (def: (~' encode) (Codec<JSON,?>//encode (~ inputT)))
+                              (def: ((~' decode) (~ g!inputs)) (../reader;run (~ g!inputs) (Codec<JSON,?>//decode (~ inputT))))
                               )))))))
diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux
index 7af9eefc1..995cc023a 100644
--- a/stdlib/source/lux/macro/poly.lux
+++ b/stdlib/source/lux/macro/poly.lux
@@ -1,17 +1,19 @@
 (;module:
   [lux #- function]
-  (lux (control ["M" monad #+ do Monad]
+  (lux (control [monad #+ do Monad]
                 [eq]
                 ["p" parser])
+       [function]
        (data [text "text/" Monoid<Text>]
-             (coll [list "List/" Fold<List> Monad<List>]
+             (coll [list "L/" Fold<List> Monad<List> Monoid<List>]
                    [dict #+ Dict])
-             [number]
+             [number "nat/" Codec<Text,Nat>]
              [product]
              [bool]
              [maybe]
-             [ident "Ident/" Eq<Ident> Codec<Text,Ident>])
-       [macro #+ with-gensyms "Lux/" Monad<Lux>]
+             [ident "Ident/" Eq<Ident> Codec<Text,Ident>]
+             ["R" result])
+       [macro #+ with-gensyms]
        (macro [code]
               ["s" syntax #+ syntax: Syntax]
               (syntax ["cs" common]
@@ -20,168 +22,229 @@
        [type]
        ))
 
-## [Types]
-(type: #export (Matcher a)
-  (-> Type (Lux a)))
-
 (type: #export Env (Dict Nat [Type Code]))
 
-## [Combinators]
+(type: #export (Poly a)
+  (p;Parser [Env (List Type)] a))
+
+(def: #export fresh Env (dict;new number;Hash<Nat>))
+
+(def: (run' env types poly)
+  (All [a] (-> Env (List Type) (Poly a) (R;Result a)))
+  (case (p;run [env types] poly)
+    (#R;Error error)
+    (#R;Error error)
+
+    (#R;Success [[env' remaining] output])
+    (case remaining
+      #;Nil
+      (#R;Success output)
+
+      _
+      (#R;Error (|> remaining
+                    (L/map type;to-text)
+                    (text;join-with ", ")
+                    (text/append "Unconsumed types: "))))))
+
+(def: #export (run type poly)
+  (All [a] (-> Type (Poly a) (R;Result a)))
+  (run' fresh (list type) poly))
+
+(def: #export env
+  (Poly Env)
+  (;function [[env inputs]]
+    (#R;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)
+      (#R;Error error)
+      (#R;Error error)
+
+      (#R;Success [[_ remaining] output])
+      (#R;Success [[env remaining] output]))))
+
+(def: #export peek
+  (Poly Type)
+  (;function [[env inputs]]
+    (case inputs
+      #;Nil
+      (#R;Error "Empty stream of types.")
+
+      (#;Cons headT tail)
+      (#R;Success [[env inputs] headT]))))
+
+(def: #export any
+  (Poly Type)
+  (;function [[env inputs]]
+    (case inputs
+      #;Nil
+      (#R;Error "Empty stream of types.")
+
+      (#;Cons headT tail)
+      (#R;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)
+      (#R;Error error)
+      (#R;Error error)
+
+      (#R;Success output)
+      (#R;Success [[env pass-through] output]))))
+
+(def: (label idx)
+  (-> Nat Code)
+  (code;local-symbol (text/append "label\u0000" (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)
+        (#R;Error error)
+        (#R;Error error)
+
+        (#R;Success [[_ inputs'] output])
+        (#R;Success [[env inputs'] [g!var output]])))))
+
 (do-template [<combinator> <name> <type>]
   [(def: #export <combinator>
-     (Matcher Unit)
-     (;function [:type:]
-       (case (type;un-name :type:)
+     (Poly Unit)
+     (do p;Monad<Parser>
+       [headT any]
+       (case (type;un-name headT)
          <type>
-         (Lux/wrap [])
+         (wrap [])
 
          _
-         (macro;fail ($_ text/append "Not " <name> " type: " (type;to-text :type:))))))]
+         (p;fail ($_ text/append "Not " <name> " type: " (type;to-text headT))))))]
 
   [void "Void" #;Void]
   [unit "Unit" #;Unit]
-  )
-
-(do-template [<combinator> <name>]
-  [(def: #export <combinator>
-     (Matcher Unit)
-     (;function [:type:]
-       (case (type;un-alias :type:)
-         (#;Named ["lux" <name>] _)
-         (Lux/wrap [])
-
-         _
-         (macro;fail ($_ text/append "Not " <name> " type: " (type;to-text :type:))))))]
-
-  [bool "Bool"]
-  [nat  "Nat"]
-  [int  "Int"]
-  [deg  "Deg"]
-  [real "Real"]
-  [text "Text"]
+  [bool "Bool" (#;Host "#Bool" #;Nil)]
+  [nat  "Nat"  (#;Host "#Nat" #;Nil)]
+  [int  "Int"  (#;Host "#Int" #;Nil)]
+  [deg  "Deg"  (#;Host "#Deg" #;Nil)]
+  [real "Real" (#;Host "#Real" #;Nil)]
+  [text "Text" (#;Host "#Text" #;Nil)]
   )
 
 (def: #export primitive
-  (Matcher Type)
-  (;function [:type:]
-    (with-expansions
-      [<primitives> (do-template [<parser> <type>]
-                      [(do macro;Monad<Lux>
-                         [_ (<parser> :type:)]
-                         (wrap <type>))]
-
-                      [void Void]
-                      [unit Unit]
-                      [bool Bool]
-                      [nat  Nat]
-                      [int  Int]
-                      [deg  Deg]
-                      [real Real]
-                      [text Text])]
-      ($_ macro;either
-          <primitives>))))
-
-(do-template [<single> <multi> <flattener> <tag>]
-  [(def: #export <single>
-     (Matcher [Type Type])
-     (;function [:type:]
-       (case (type;un-name :type:)
-         (<tag> :left: :right:)
-         (Lux/wrap [:left: :right:])
-
-         _
-         (macro;fail ($_ text/append "Not a " (Ident/encode (ident-for <tag>)) " type: " (type;to-text :type:))))))
-
-   (def: #export <multi>
-     (Matcher (List Type))
-     (;function [:type:]
-       (let [members (<flattener> (type;un-name :type:))]
+  (Poly Type)
+  (do p;Monad<Parser>
+    [headT any]
+    (case (run headT ($_ p;either
+                         void
+                         unit
+                         bool
+                         nat
+                         int
+                         deg
+                         real
+                         text))
+      (#R;Error error)
+      (p;fail error)
+
+      (#R;Success _)
+      (wrap headT))))
+
+(do-template [<name> <flattener> <tag>]
+  [(def: #export (<name> poly)
+     (All [a] (-> (Poly a) (Poly a)))
+     (do p;Monad<Parser>
+       [headT any]
+       (let [members (<flattener> (type;un-name headT))]
          (if (n.> +1 (list;size members))
-           (Lux/wrap members)
-           (macro;fail ($_ text/append "Not a " (Ident/encode (ident-for <tag>)) " type: " (type;to-text :type:)))))))]
+           (local members poly)
+           (p;fail ($_ text/append "Not a " (Ident/encode (ident-for <tag>)) " type: " (type;to-text headT)))))))]
 
-  [sum    sum+    type;flatten-variant #;Sum]
-  [prod   prod+   type;flatten-tuple   #;Product]
+  [variant type;flatten-variant #;Sum]
+  [tuple   type;flatten-tuple   #;Product]
   )
 
-(def: #export polymorphic
-  (Matcher [(List Code) Type])
-  (;function [:type:]
-    (let [:type: (type;un-name :type:)]
-      (case :type:
-        (#;UnivQ _)
-        (loop [:type: :type:]
-          (case :type:
-            (#;UnivQ _ :type:')
-            (do macro;Monad<Lux>
-              [[g!tail :type:''] (recur :type:')
-               g!head (macro;gensym "type-var")]
-              (wrap [(list& g!head g!tail)
-                     :type:'']))
-
-            _
-            (Lux/wrap [(;list) :type:])))
-
-        _
-        (macro;fail ($_ text/append "Non-polymorphic type: " (type;to-text :type:)))))))
-
-(def: #export function
-  (Matcher [(List Type) Type])
-  (;function [:type:]
-    (:: macro;Monad<Lux> wrap (type;flatten-function (type;un-name :type:)))))
-
-(def: #export apply
-  (Matcher [Type (List Type)])
-  (;function [:type:]
-    (do macro;Monad<Lux>
-      [#let [[:func: :args:] (loop [:type: (type;un-name :type:)]
-                               (case :type:
-                                 (#;Apply :arg: :func:)
-                                 (let [[:func:' :args:] (recur :func:)]
-                                   [:func:' (list& :arg: :args:)])
-
-                                 _
-                                 [:type: (;list)]))]]
-      (case :args:
-        #;Nil
-        (macro;fail "Not a type application.")
-
-        _
-        (wrap [:func: (list;reverse :args:)])))))
-
-(def: #export (apply-1 name)
-  (-> Ident (Matcher Type))
-  (;function [:type:]
-    (case (type;un-name :type:)
-      (^multi (#;Apply :arg: :quant:)
-              [(type;un-alias :quant:) (#;Named actual _)]
-              (Ident/= name actual))
-      (Lux/wrap :arg:)
-
-      _
-      (macro;fail ($_ text/append "Not " (Ident/encode name) " type: " (type;to-text :type:))))))
-
-(def: #export (apply-2 name)
-  (-> Ident (Matcher [Type Type]))
-  (;function [:type:]
-    (case (type;un-name :type:)
-      (^multi (#;Apply :arg1: (#;Apply :arg0: :quant:))
-              [(type;un-alias :quant:) (#;Named actual _)]
-              (Ident/= name actual))
-      (Lux/wrap [:arg0: :arg1:])
-
-      _
-      (macro;fail ($_ text/append "Not " (Ident/encode name) " type: " (type;to-text :type:))))))
-
-(def: #export recursive
-  (Matcher Type)
-  (;function [:type:]
-    (case (type;un-name :type:)
-      (#;Apply #;Void (#;UnivQ _ :type:'))
-      (Lux/wrap :type:')
+(def: polymorphic'
+  (Poly [Nat Type])
+  (do p;Monad<Parser>
+    [headT any
+     #let [[num-arg bodyT] (type;flatten-univ-q (type;un-name headT))]]
+    (if (n.= +0 num-arg)
+      (p;fail ($_ text/append "Non-polymorphic type: " (type;to-text headT)))
+      (wrap [num-arg bodyT]))))
+
+(def: #export (polymorphic poly)
+  (All [a] (-> (Poly a) (Poly [Code (List Code) a])))
+  (do p;Monad<Parser>
+    [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 (n.inc funcI))]
+                                    (recur (n.inc current-arg)
+                                           (|> env'
+                                               (dict;put funcI [headT funcL])
+                                               (dict;put (n.inc funcI) [(#;Bound (n.inc funcI)) varL]))
+                                           (#;Cons varL all-varsL)))
+                                  (let [partialI (|> current-arg (n.* +2) (n.+ funcI))
+                                        partial-varI (n.inc partialI)
+                                        partial-varL (label partial-varI)
+                                        partialC (` ((~ funcL) (~@ (|> (list;n.range +0 (n.dec num-args))
+                                                                       (L/map (|>. (n.* +2) n.inc (n.+ funcI) label))
+                                                                       list;reverse))))]
+                                    (recur (n.inc current-arg)
+                                           (|> env'
+                                               (dict;put partialI [;Void partialC])
+                                               (dict;put partial-varI [(#;Bound 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<Parser>
+    [headT any
+     #let [[inputsT outputT] (type;flatten-function (type;un-name headT))]]
+    (if (n.> +0 (list;size inputsT))
+      (p;seq (local inputsT in-poly)
+             (local (list outputT) out-poly))
+      (p;fail ($_ text/append "Non-function type: " (type;to-text headT))))))
+
+(def: #export (apply poly)
+  (All [a] (-> (Poly a) (Poly a)))
+  (do p;Monad<Parser>
+    [headT any
+     #let [[funcT paramsT] (type;flatten-application (type;un-name headT))]]
+    (if (n.= +0 (list;size paramsT))
+      (p;fail ($_ text/append "Non-application type: " (type;to-text headT)))
+      (local (#;Cons funcT paramsT) poly))))
+
+(def: #export (named expected)
+  (-> Ident (Poly Unit))
+  (do p;Monad<Parser>
+    [headT any]
+    (case (type;un-alias headT)
+      (#;Named actual _)
+      (if (Ident/= expected actual)
+        (wrap [])
+        (p;fail ($_ text/append "Not " (Ident/encode expected) " type: " (type;to-text headT))))
 
       _
-      (macro;fail ($_ text/append "Not a recursive type: " (type;to-text :type:))))))
+      (p;fail ($_ text/append "Not a named type: " (type;to-text headT))))))
 
 (def: (adjusted-idx env idx)
   (-> Env Nat Nat)
@@ -190,110 +253,110 @@
         bound-idx (n.% +2 idx)]
     (|> env-level n.dec (n.- bound-level) (n.* +2) (n.+ bound-idx))))
 
-(def: #export (bound env)
-  (-> Env (Matcher Code))
-  (;function [:type:]
-    (case :type:
+(def: #export bound
+  (Poly Code)
+  (do p;Monad<Parser>
+    [env ;;env
+     headT any]
+    (case headT
       (#;Bound idx)
       (case (dict;get (adjusted-idx env idx) env)
         (#;Some [poly-type poly-ast])
-        (Lux/wrap poly-ast)
+        (wrap poly-ast)
 
         #;None
-        (macro;fail ($_ text/append "Unknown bound type: " (type;to-text :type:))))
+        (p;fail ($_ text/append "Unknown bound type: " (type;to-text headT))))
 
       _
-      (macro;fail ($_ text/append "Not a bound type: " (type;to-text :type:))))))
-
-(def: #export (recursion env)
-  (-> Env (Matcher Code))
-  (;function [:type:]
-    (do macro;Monad<Lux>
-      [[t-func t-args] (apply :type:)]
-      (case t-func
-        (^multi (#;Bound t-func-idx)
-                (n.= +0 (adjusted-idx env t-func-idx))
-                [(do maybe;Monad<Maybe>
-                   [=func (dict;get +0 env)
-                    =args (M;map @ (;function [t-arg]
-                                     (case t-arg
-                                       (#;Bound idx)
-                                       (dict;get (adjusted-idx env idx) env)
-
-                                       _
-                                       #;None))
-                                 t-args)]
-                   (wrap (` ((~ (product;right =func)) (~@ (List/map product;right =args))))))
-                 (#;Some call)])
-        (wrap call)
-
-        _
-        (macro;fail ($_ text/append "Type is not a recursive instance: " (type;to-text :type:))))
-      )))
-
-(def: #export (self env)
-  (-> Env (Matcher Code))
-  (;function [:type:]
-    (case :type:
-      (^multi (#;Apply #;Void (#;Bound t-func-idx))
-              (n.= +0 (adjusted-idx env t-func-idx))
-              [(dict;get +0 env)
-               (#;Some [self-type self-call])])
-      (Lux/wrap self-call)
+      (p;fail ($_ text/append "Not a bound type: " (type;to-text headT))))))
+
+(def: #export (var id)
+  (-> Nat (Poly Unit))
+  (do p;Monad<Parser>
+    [env ;;env
+     headT any]
+    (case headT
+      (#;Bound idx)
+      (if (n.= id (adjusted-idx env idx))
+        (wrap [])
+        (p;fail ($_ text/append "Wrong bound type.\n"
+                    "Expected: " (nat/encode id) "\n"
+                    "  Actual: " (nat/encode idx))))
 
       _
-      (macro;fail ($_ text/append "Type is not a recursive self-call: " (type;to-text :type:))))))
+      (p;fail ($_ text/append "Not a bound type: " (type;to-text headT))))))
+
+(def: #export (recursive poly)
+  (All [a] (-> (Poly a) (Poly [Code a])))
+  (do p;Monad<Parser>
+    [headT any]
+    (case (type;un-name headT)
+      (#;Apply #;Void (#;UnivQ _ headT'))
+      (do @
+        [[recT _ output] (|> poly
+                             (with-extension #;Void)
+                             (with-extension headT)
+                             (local (list headT')))]
+        (wrap [recT output]))
 
-(def: #export (var env var-id)
-  (-> Env Nat (Matcher Unit))
-  (;function [:type:]
-    (case :type:
-      (^multi (#;Bound idx)
-              (n.= var-id (adjusted-idx env idx)))
-      (Lux/wrap [])
+      _
+      (p;fail ($_ text/append "Not a recursive type: " (type;to-text headT))))))
+
+(def: #export recursive-self
+  (Poly Code)
+  (do p;Monad<Parser>
+    [env ;;env
+     headT any]
+    (case (type;un-name headT)
+      (^multi (#;Apply #;Void (#;Bound funcT-idx))
+              (n.= +0 (adjusted-idx env funcT-idx))
+              [(dict;get +0 env) (#;Some [self-type self-call])])
+      (wrap self-call)
 
       _
-      (macro;fail ($_ text/append "Not a bound type: " (type;to-text :type:))))))
+      (p;fail ($_ text/append "Not a recursive type: " (type;to-text headT))))))
+
+(def: #export recursive-call
+  (Poly Code)
+  (do p;Monad<Parser>
+    [env ;;env
+     [funcT argsT] (apply (p;seq any (p;many any)))
+     _ (local (list funcT) (var +0))
+     allC (let [allT (list& funcT argsT)]
+            (|> allT
+                (monad;map @ (function;const bound))
+                (local allT)))]
+    (wrap (` ((~@ allC))))))
+
+(def: #export log
+  (All [a] (Poly a))
+  (do p;Monad<Parser>
+    [current any
+     #let [_ (log! ($_ text/append
+                       "{" (Ident/encode (ident-for ;;log)) "} "
+                       (type;to-text current)))]]
+    (p;fail "LOGGING")))
 
 ## [Syntax]
-(def: #export (extend-env [funcT funcA] type-vars env)
-  (-> [Type Code] (List [Type Code]) Env Env)
-  (case type-vars
-    #;Nil
-    env
-    
-    (#;Cons [varT varA] type-vars')
-    (let [current-size (dict;size env)]
-      (|> env
-          (dict;put current-size [funcT funcA])
-          (dict;put (n.inc current-size) [varT varA])
-          (extend-env [(#;Apply varT funcT) (` (#;Apply (~ varA) (~ funcA)))]
-                      type-vars')
-          ))))
-
-(syntax: #export (poly: [_ex-lev csr;export]
-                   [[name env inputs] (s;form ($_ p;seq
-                                                  s;local-symbol
-                                                  s;local-symbol
-                                                  (p;many s;local-symbol)))]
+(syntax: #export (poly: [export csr;export]
+                   [name s;local-symbol]
                    body)
-  (with-gensyms [g!body]
-    (let [g!inputs (List/map (|>. [""] code;symbol) inputs)
-          g!name (code;symbol ["" name])
-          g!env (code;symbol ["" env])]
-      (wrap (;list (` (syntax: (~@ (csw;export _ex-lev)) ((~ g!name) (~@ (List/map (;function [g!input] (` [(~ g!input) s;symbol]))
-                                                                                   g!inputs)))
+  (with-gensyms [g!type g!output]
+    (let [g!name (code;symbol ["" name])]
+      (wrap (;list (` (syntax: (~@ (csw;export export)) ((~ g!name) [(~ g!type) s;symbol])
                         (do macro;Monad<Lux>
-                          [(~@ (List/join (List/map (;function [g!input] (;list g!input (` (macro;find-type-def (~ g!input)))))
-                                                    g!inputs)))
-                           (~' #let) [(~ g!env) (: Env (dict;new number;Hash<Nat>))]
-                           (~ g!body) (: (Lux Code)
-                                         (loop [(~ g!env) (~ g!env)
-                                                (~@ (List/join (List/map (;function [g!input] (;list g!input g!input))
-                                                                         g!inputs)))]
-                                           (let [(~ g!name) (~' recur)]
-                                             (~ body))))]
-                          ((~' wrap) (;list (~ g!body)))))))))))
+                          [(~ g!type) (macro;find-type-def (~ g!type))]
+                          (case (|> (~ body)
+                                    (;function [(~ g!name)])
+                                    p;rec
+                                    (do p;Monad<Parser> [])
+                                    (;;run (~ g!type))
+                                    (: (;Either ;Text ;Code)))
+                            (#;Left (~ g!output))
+                            (macro;fail (~ g!output))
+
+                            (#;Right (~ g!output))
+                            ((~' wrap) (;list (~ g!output))))))))))))
 
 (def: (common-poly-name? poly-func)
   (-> Text Bool)
@@ -302,33 +365,33 @@
 (def: (derivation-name poly args)
   (-> Text (List Text) (Maybe Text))
   (if (common-poly-name? poly)
-    (#;Some (List/fold (text;replace-once "?") poly args))
+    (#;Some (L/fold (text;replace-once "?") poly args))
     #;None))
 
-(syntax: #export (derived: [_ex-lev csr;export]
+(syntax: #export (derived: [export csr;export]
                    [?name (p;opt s;local-symbol)]
                    [[poly-func poly-args] (s;form (p;seq s;symbol (p;many s;symbol)))]
                    [?custom-impl (p;opt s;any)])
   (do @
-    [poly-args (M;map @ macro;normalize poly-args)
+    [poly-args (monad;map @ macro;normalize poly-args)
      name (case ?name
             (#;Some name)
             (wrap name)
 
             (^multi #;None
-                    [(derivation-name (product;right poly-func) (List/map product;right poly-args))
+                    [(derivation-name (product;right poly-func) (L/map product;right poly-args))
                      (#;Some derived-name)])
             (wrap derived-name)
 
             _
-            (macro;fail "derived: was given no explicit name, and cannot generate one from given information."))
+            (p;fail "derived: was given no explicit name, and cannot generate one from given information."))
      #let [impl (case ?custom-impl
                   (#;Some custom-impl)
                   custom-impl
 
                   #;None
-                  (` ((~ (code;symbol poly-func)) (~@ (List/map code;symbol poly-args)))))]]
-    (wrap (;list (` (def: (~@ (csw;export _ex-lev))
+                  (` ((~ (code;symbol poly-func)) (~@ (L/map code;symbol poly-args)))))]]
+    (wrap (;list (` (def: (~@ (csw;export export))
                       (~ (code;symbol ["" name]))
                       {#;struct? true}
                       (~ impl)))))))
@@ -339,7 +402,7 @@
   (case type
     (#;Host name params)
     (` (#;Host (~ (code;text name))
-               (list (~@ (List/map (to-ast env) params)))))
+               (list (~@ (L/map (to-ast env) params)))))
 
     (^template [<tag>]
       <tag>
@@ -371,7 +434,7 @@
 
     (^template [<tag> <macro> <flattener>]
       (<tag> left right)
-      (` (<macro> (~@ (List/map (to-ast env) (<flattener> type))))))
+      (` (<macro> (~@ (L/map (to-ast env) (<flattener> type))))))
     ([#;Sum  | type;flatten-variant]
      [#;Product & type;flatten-tuple])
 
@@ -380,23 +443,7 @@
 
     (^template [<tag>]
       (<tag> scope body)
-      (` (<tag> (list (~@ (List/map (to-ast env) scope)))
+      (` (<tag> (list (~@ (L/map (to-ast env) scope)))
                 (~ (to-ast env body)))))
     ([#;UnivQ] [#;ExQ])
     ))
-
-(def: #export (gen-type env converter type-fun tvars type)
-  (-> Env (-> Code Code) Code (List Code) Type Code)
-  (let [type' (to-ast env type)]
-    (case tvars
-      #;Nil
-      (converter type')
-
-      _
-      (` (All (~ type-fun) [(~@ tvars)]
-           (-> (~@ (List/map converter tvars))
-               (~ (converter (` ((~ type') (~@ tvars)))))))))))
-
-(def: #export (type-var-indices num-vars)
-  (-> Nat (List Type))
-  (|> num-vars list;indices (List/map (|>. #;Bound))))
diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux
index 9de2a8784..20bda8be7 100644
--- a/stdlib/source/lux/macro/poly/eq.lux
+++ b/stdlib/source/lux/macro/poly/eq.lux
@@ -1,7 +1,8 @@
 (;module:
   lux
   (lux (control [monad #+ do Monad]
-                [eq])
+                [eq]
+                ["p" parser])
        (data [text "text/" Monoid<Text>]
              text/format
              (coll [list "L/" Monad<List>]
@@ -25,109 +26,108 @@
        ))
 
 ## [Derivers]
-(poly: #export (Eq<?> env :x:)
-  (let [->Eq (: (-> Code Code)
-                (function [.type.] (` (eq;Eq (~ .type.)))))]
-    (with-expansions
-      [<basic> (do-template [<type> <matcher> <eq>]
-                 [(do @
-                    [_ (<matcher> :x:)]
-                    (wrap (` (: (~ (->Eq (` <type>)))
-                                <eq>))))]
+(poly: #export Eq<?>
+  (with-expansions
+    [<basic> (do-template [<type> <matcher> <eq>]
+               [(do @
+                  [[primT _] (p;seq poly;peek <matcher>)]
+                  (wrap (` (: (~ (@Eq primT))
+                              <eq>))))]
 
-                 [Unit poly;unit (function [(~' test) (~' input)] true)]
-                 [Bool poly;bool bool;Eq<Bool>]
-                 [Nat  poly;nat  number;Eq<Nat>]
-                 [Int  poly;int  number;Eq<Int>]
-                 [Deg  poly;deg  number;Eq<Deg>]
-                 [Real poly;real number;Eq<Real>]
-                 [Text poly;text text;Eq<Text>])
-       <composites> (do-template [<name> <eq>]
-                      [(do @
-                         [:arg: (poly;apply-1 (ident-for <name>) :x:)
-                          g!arg (Eq<?> env :arg:)]
-                         (wrap (` (: (~ (->Eq (type;to-ast :x:)))
-                                     (<eq> (~ g!arg))))))]
+               [Unit poly;unit (function [(~' test) (~' input)] true)]
+               [Bool poly;bool bool;Eq<Bool>]
+               [Nat  poly;nat  number;Eq<Nat>]
+               [Int  poly;int  number;Eq<Int>]
+               [Deg  poly;deg  number;Eq<Deg>]
+               [Real poly;real number;Eq<Real>]
+               [Text poly;text text;Eq<Text>])
+     <composites> (do-template [<name> <eq>]
+                    [(do @
+                       [[collT [_ argC]] (p;seq poly;peek
+                                                (poly;apply (p;seq (poly;named (ident-for <name>))
+                                                                   Eq<?>)))]
+                       (wrap (` (: (~ (@Eq collT))
+                                   (<eq> (~ argC))))))]
 
-                      [list;List     list;Eq<List>]
-                      [vector;Vector vector;Eq<Vector>]
-                      [array;Array   array;Eq<Array>]
-                      [queue;Queue   queue;Eq<Queue>]
-                      [set;Set       set;Eq<Set>]
-                      [seq;Seq       seq;Eq<Seq>]
-                      [rose;Tree     rose;Eq<Tree>]
-                      )]
-      ($_ macro;either
+                    ## [;Maybe        maybe;Eq<Maybe>]
+                    ## [;List         list;Eq<List>]
+                    [vector;Vector vector;Eq<Vector>]
+                    [array;Array   array;Eq<Array>]
+                    [queue;Queue   queue;Eq<Queue>]
+                    [set;Set       set;Eq<Set>]
+                    [seq;Seq       seq;Eq<Seq>]
+                    [rose;Tree     rose;Eq<Tree>]
+                    )]
+    (do @
+      [*env* poly;env
+       #let [@Eq (: (-> Type Code)
+                    (function [type]
+                      (` (eq;Eq (~ (poly;to-ast *env* type))))))]]
+      ($_ p;either
           ## Primitive types
           <basic>
           ## Composite types
           <composites>
           (do @
-            [[:key: :val:] (poly;apply-2 (ident-for dict;Dict) :x:)
-             g!val (Eq<?> env :val:)]
-            (wrap (` (: (~ (->Eq (type;to-ast :x:)))
-                        (dict;Eq<Dict> (~ g!val))))))
+            [[collT [_ _ valC]] (p;seq poly;peek
+                                       (poly;apply ($_ p;seq
+                                                       (poly;named (ident-for dict;Dict))
+                                                       poly;any
+                                                       Eq<?>)))]
+            (wrap (` (: (~ (@Eq collT))
+                        (dict;Eq<Dict> (~ valC))))))
           ## Variants
-          (with-gensyms [g!left g!right]
-            (do @
-              [members (poly;sum+ :x:)
-               pattern-matching (monad;map @
-                                           (function [[tag :case:]]
-                                             (do @
-                                               [g!eq (Eq<?> env :case:)]
-                                               (wrap (list (` [((~ (code;nat tag)) (~ g!left))
-                                                               ((~ (code;nat tag)) (~ g!right))])
-                                                           (` ((~ g!eq) (~ g!left) (~ g!right)))))))
-                                           (list;enumerate members))]
-              (wrap (` (: (~ (->Eq (poly;to-ast env :x:)))
-                          (function [(~ g!left) (~ g!right)]
-                            (case [(~ g!left) (~ g!right)]
-                              (~@ (L/join pattern-matching)))))))))
+          (do @
+            [[variantT members] (p;seq poly;peek
+                                       (poly;variant (p;many Eq<?>)))
+             #let [g!left (code;local-symbol "\u0000left")
+                   g!right (code;local-symbol "\u0000right")]]
+            (wrap (` (: (~ (@Eq variantT))
+                        (function [(~ g!left) (~ g!right)]
+                          (case [(~ g!left) (~ g!right)]
+                            (~@ (L/join (L/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))))))))))
           ## Tuples
           (do @
-            [:members: (poly;prod+ :x:)
-             #let [indices (|> (list;size :members:) n.dec (list;n.range +0))
+            [[tupleT g!eqs] (p;seq poly;peek
+                                   (poly;tuple (p;many Eq<?>)))
+             #let [indices (|> (list;size g!eqs) n.dec (list;n.range +0))
                    g!lefts (L/map (|>. nat/encode (text/append "left") code;local-symbol) indices)
-                   g!rights (L/map (|>. nat/encode (text/append "right") code;local-symbol) indices)]
-             g!eqs (monad;map @ (Eq<?> env) :members:)]
-            (wrap (` (: (~ (->Eq (poly;to-ast env :x:)))
+                   g!rights (L/map (|>. nat/encode (text/append "right") code;local-symbol) indices)]]
+            (wrap (` (: (~ (@Eq tupleT))
                         (function [[(~@ g!lefts)] [(~@ g!rights)]]
                           (and (~@ (|> (list;zip3 g!eqs g!lefts g!rights)
                                        (L/map (function [[g!eq g!left g!right]]
                                                 (` ((~ g!eq) (~ g!left) (~ g!right)))))))))))))
           ## Type recursion
-          (with-gensyms [g!rec]
-            (do @
-              [:non-rec: (poly;recursive :x:)
-               #let [new-env (poly;extend-env [:x: g!rec] (list [Bottom (` (;undefined))]) env)]
-               .non-rec. (Eq<?> new-env :non-rec:)]
-              (wrap (` (: (~ (poly;gen-type new-env ->Eq g!rec (list) :x:))
-                          (eq;rec (;function [(~ g!rec)]
-                                    (~ .non-rec.))))))))
-          (poly;self env :x:)
-          (poly;recursion env :x:)
+          (do @
+            [[recT [g!self bodyC]] (p;seq poly;peek
+                                          (poly;recursive Eq<?>))]
+            (wrap (` (: (~ (@Eq recT))
+                        (eq;rec (;function [(~ g!self)]
+                                  (~ bodyC)))))))
+          poly;recursive-self
           ## Type applications
           (do @
-            [[:func: :args:] (poly;apply :x:)
-             .func. (Eq<?> env :func:)
-             .args. (monad;map @ (Eq<?> env) :args:)]
-            (wrap (` (: (~ (->Eq (type;to-ast :x:)))
-                        ((~ .func.) (~@ .args.))))))
+            [[funcC argsC] (poly;apply (p;seq Eq<?> (p;many Eq<?>)))]
+            (wrap (` ((~ funcC) (~@ argsC)))))
           ## Bound type-vars
-          (poly;bound env :x:)
+          poly;bound
           ## Polymorphism
-          (with-gensyms [g!type-fun]
-            (do @
-              [[g!vars :non-poly:] (poly;polymorphic :x:)
-               #let [new-env (poly;extend-env [:x: g!type-fun]
-                                              (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
-                                              env)]
-               .non-poly. (Eq<?> new-env :non-poly:)]
-              (wrap (` (: (All (~ g!type-fun) [(~@ g!vars)]
-                            (-> (~@ (L/map ->Eq g!vars))
-                                (~ (->Eq (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))
-                          (function (~ g!type-fun) [(~@ g!vars)]
-                            (~ .non-poly.)))))))
+          (do @
+            [[polyT [funcC varsC bodyC]] (p;seq poly;peek
+                                                (poly;polymorphic Eq<?>))]
+            (wrap (` (: (All [(~@ varsC)]
+                          (-> (~@ (L/map (|>. (~) eq;Eq (`)) varsC))
+                              (eq;Eq ((~ (poly;to-ast *env* polyT)) (~@ varsC)))))
+                        (function (~ funcC) [(~@ varsC)]
+                          (~ bodyC))))))
+          poly;recursive-call
           ## If all else fails...
-          (macro;fail (format "Cannot create Eq for: " (%type :x:)))
+          (|> poly;any
+              (:: @ map (|>. %type (format "Cannot create Eq for: ") p;fail))
+              (:: @ join))
           ))))
diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux
index 0acd49a8e..cc6007220 100644
--- a/stdlib/source/lux/macro/poly/functor.lux
+++ b/stdlib/source/lux/macro/poly/functor.lux
@@ -1,16 +1,12 @@
 (;module:
   lux
-  (lux (control ["M" monad #+ do Monad]
-                [functor])
+  (lux (control [monad #+ do Monad]
+                [functor]
+                ["p" parser])
        (data [text]
              text/format
-             (coll [list "List/" Monad<List>]
-                   [dict #+ Dict])
-             [number]
-             [product]
-             [bool]
-             [maybe]
-             [ident "Ident/" Codec<Text,Ident>])
+             (coll [list "L/" Monad<List> Monoid<List>])
+             [product])
        [macro #+ Monad<Lux> with-gensyms]
        (macro [code]
               [syntax #+ syntax: Syntax]
@@ -19,107 +15,81 @@
        [type]
        ))
 
-## [Derivers]
-(poly: #export (Functor<?> env :input:)
-  (with-gensyms [g!type-fun g!func g!input]
-    (do @
-      [[g!vars :x:] (poly;polymorphic :input:)
-       #let [num-vars (list;size g!vars)
-             new-env (poly;extend-env [:input: g!type-fun]
-                                      (list;zip2 (poly;type-var-indices num-vars) g!vars)
-                                      env)]]
-      (let [->Functor (: (-> Code Code)
-                         (function [.type.]
-                           (if (n.= +1 num-vars)
-                             (` (functor;Functor (~ .type.)))
-                             (let [type-params (|> num-vars n.dec list;indices (List/map (|>. %n code;local-symbol)))]
-                               (` (All [(~@ type-params)] (functor;Functor ((~ .type.) (~@ type-params)))))))))
-            Arg<?> (: (-> Code (poly;Matcher Code))
-                      (function Arg<?> [value :type:]
-                        ($_ macro;either
-                            ## Nothing to do.
-                            (do @
-                              [_ (poly;primitive :type:)]
-                              (wrap value))
-                            ## Type-var
-                            (do @
-                              [_ (poly;var new-env (|> num-vars (n.* +2) n.dec) :type:)]
-                              (wrap (` ((~ g!func) (~ value)))))
-                            ## Bound type-variables
-                            (do @
-                              [_ (poly;bound new-env :type:)]
-                              (wrap value))
-                            ## Tuples/records
-                            (do @
-                              [members (poly;prod+ :type:)
-                               pm (M;map @
-                                         (function [:slot:]
-                                           (do @
-                                             [g!slot (macro;gensym "g!slot")
-                                              body (Arg<?> g!slot :slot:)]
-                                             (wrap [g!slot body])))
-                                         members)]
-                              (wrap (` (case (~ value)
-                                         [(~@ (List/map product;left pm))]
-                                         [(~@ (List/map product;right pm))])
-                                       )))
-                            ## Recursion
-                            (do @
-                              [_ (poly;recursion new-env :type:)]
-                              (wrap (` ((~' map) (~ g!func) (~ value)))))
-                            )))]
-        ($_ macro;either
-            ## Variants
-            (do @
-              [cases (poly;sum+ :x:)
-               pattern-matching (M;map @
-                                       (function [[tag :case:]]
-                                         (do @
-                                           [synthesis (Arg<?> g!input :case:)]
-                                           (wrap (list (` ((~ (code;nat tag)) (~ g!input)))
-                                                       (` ((~ (code;nat tag)) (~ synthesis)))))))
-                                       (list;enumerate cases))]
-              (wrap (` (: (~ (->Functor (type;to-ast :input:)))
-                          (struct (def: ((~' map) (~ g!func) (~ g!input))
-                                    (case (~ g!input)
-                                      (~@ (List/join pattern-matching)))))
-                          ))))
-            ## Tuples/Records
-            (do @
-              [members (poly;prod+ :x:)
-               pm (M;map @
-                         (function [:slot:]
+(poly: #export Functor<?>
+  (do @
+    [#let [type-funcC (code;local-symbol "\u0000type-funcC")
+           funcC (code;local-symbol "\u0000funcC")
+           inputC (code;local-symbol "\u0000inputC")]
+     *env* poly;env
+     inputT poly;peek
+     [polyC varsC non-functorT] (poly;local (list inputT)
+                                            (poly;polymorphic poly;any))
+     #let [num-vars (list;size varsC)]
+     #let [@Functor (: (-> Type Code)
+                       (function [unwrappedT]
+                         (if (n.= +1 num-vars)
+                           (` (functor;Functor (~ (poly;to-ast *env* unwrappedT))))
+                           (let [paramsC (|> num-vars n.dec list;indices (L/map (|>. %n code;local-symbol)))]
+                             (` (All [(~@ paramsC)]
+                                  (functor;Functor ((~ (poly;to-ast *env* unwrappedT)) (~@ paramsC)))))))))
+           Arg<?> (: (-> Code (poly;Poly Code))
+                     (function Arg<?> [valueC]
+                       ($_ p;either
+                           ## Type-var
+                           (do p;Monad<Parser>
+                             [#let [varI (|> num-vars (n.* +2) n.dec)]
+                              _ (poly;var varI)]
+                             (wrap (` ((~ funcC) (~ valueC)))))
+                           ## Variants
                            (do @
-                             [g!slot (macro;gensym "g!slot")
-                              body (Arg<?> g!slot :slot:)]
-                             (wrap [g!slot body])))
-                         members)]
-              (wrap (` (: (~ (->Functor (type;to-ast :input:)))
-                          (struct (def: ((~' map) (~ g!func) (~ g!input))
-                                    (case (~ g!input)
-                                      [(~@ (List/map product;left pm))]
-                                      [(~@ (List/map product;right pm))])))
-                          ))))
-            ## Functions
-            (with-gensyms [g!out]
-              (do @
-                [[:ins: :out:] (poly;function :x:)
-                 .out. (Arg<?> g!out :out:)
-                 g!envs (M;seq @
-                               (list;repeat (list;size :ins:)
-                                            (macro;gensym "g!envs")))]
-                (wrap (` (: (~ (->Functor (type;to-ast :input:)))
-                            (struct (def: ((~' map) (~ g!func) (~ g!input))
-                                      (function [(~@ g!envs)]
-                                        (let [(~ g!out) ((~ g!input) (~@ g!envs))]
-                                          (~ .out.))))))))))
-            ## No structure (as you'd expect from Identity)
-            (do @
-              [_ (poly;var new-env num-vars :x:)]
-              (wrap (` (: (~ (->Functor (type;to-ast :input:)))
-                          (struct (def: ((~' map) (~ g!func) (~ g!input))
-                                    ((~ g!func) (~ g!input))))))))
-            ## Failure...
-            (macro;fail (format "Cannot create Functor for: " (%type :x:)))
-            ))
-      )))
+                             [_ (wrap [])
+                              membersC (poly;variant (p;many (Arg<?> valueC)))]
+                             (wrap (` (case (~ valueC)
+                                        (~@ (L/join (L/map (function [[tag memberC]]
+                                                             (list (` ((~ (code;nat tag)) (~ valueC)))
+                                                                   (` ((~ (code;nat tag)) (~ memberC)))))
+                                                           (list;enumerate membersC))))))))
+                           ## Tuples
+                           (do p;Monad<Parser>
+                             [pairsCC (: (poly;Poly (List [Code Code]))
+                                         (poly;tuple (loop [idx +0
+                                                            pairsCC (: (List [Code Code])
+                                                                       (list))]
+                                                       (p;either (let [slotC (|> idx %n (format "\u0000slot") code;local-symbol)]
+                                                                   (do @
+                                                                     [_ (wrap [])
+                                                                      memberC (Arg<?> slotC)]
+                                                                     (recur (n.inc idx)
+                                                                            (L/append pairsCC (list [slotC memberC])))))
+                                                                 (wrap pairsCC)))))]
+                             (wrap (` (case (~ valueC)
+                                        [(~@ (L/map product;left pairsCC))]
+                                        [(~@ (L/map product;right pairsCC))]))))
+                           ## Functions
+                           (do @
+                             [_ (wrap [])
+                              #let [outL (code;local-symbol "\u0000outL")]
+                              [inT+ outC] (poly;function (p;many poly;any)
+                                            (Arg<?> outL))
+                              #let [inC+ (|> (list;size inT+) n.dec
+                                             (list;n.range +0)
+                                             (L/map (|>. %n (format "\u0000inC") code;local-symbol)))]]
+                             (wrap (` (function [(~@ inC+)]
+                                        (let [(~ outL) ((~ valueC) (~@ inC+))]
+                                          (~ outC))))))
+                           ## Recursion
+                           (do p;Monad<Parser>
+                             [_ poly;recursive-call]
+                             (wrap (` ((~' map) (~ funcC) (~ valueC)))))
+                           ## Bound type-variables
+                           (do p;Monad<Parser>
+                             [_ poly;any]
+                             (wrap valueC))
+                           )))]
+     [_ _ outputC] (: (poly;Poly [Code (List Code) Code])
+                      (p;either (poly;polymorphic
+                                 (Arg<?> inputC))
+                                (p;fail (format "Cannot create Functor for: " (%type inputT)))))]
+    (wrap (` (: (~ (@Functor inputT))
+                (struct (def: ((~' map) (~ funcC) (~ inputC))
+                          (~ outputC))))))))
diff --git a/stdlib/test/test/lux/macro/poly/eq.lux b/stdlib/test/test/lux/macro/poly/eq.lux
index 44ecbff1e..367ac1674 100644
--- a/stdlib/test/test/lux/macro/poly/eq.lux
+++ b/stdlib/test/test/lux/macro/poly/eq.lux
@@ -6,7 +6,9 @@
        (data text/format
              [bool]
              [number "i/" Number<Int>]
-             [text])
+             [text]
+             [maybe]
+             (coll [list]))
        ["r" math/random]
        [macro]
        (macro [poly #+ derived:]
diff --git a/stdlib/test/test/lux/macro/poly/functor.lux b/stdlib/test/test/lux/macro/poly/functor.lux
index 11cdcf824..45e54bae7 100644
--- a/stdlib/test/test/lux/macro/poly/functor.lux
+++ b/stdlib/test/test/lux/macro/poly/functor.lux
@@ -3,11 +3,13 @@
   (lux [io]
        (control [monad #+ do Monad]
                 [functor]
-                [eq #+ Eq])
+                [eq #+ Eq]
+                [state])
        (data text/format
              [bool]
              [number "i/" Number<Int>]
-             [text])
+             [text]
+             [identity])
        ["r" math/random]
        [macro]
        (macro [poly #+ derived:]
@@ -15,23 +17,14 @@
   lux/test)
 
 ## [Utils]
-(type: (My-Maybe a)
-  #My-None
-  (#My-Some a))
+(derived: (&;Functor<?> ;Maybe))
 
-(type: (My-List a)
-  #My-Nil
-  (#My-Cons [a (My-List a)]))
+(derived: (&;Functor<?> ;List))
 
-(type: (My-State s a)
-  (-> s [s a]))
+(derived: (&;Functor<?> state;State))
 
-(derived: (&;Functor<?> My-Maybe))
-
-(derived: (&;Functor<?> My-List))
-
-(derived: (&;Functor<?> My-State))
+(derived: (&;Functor<?> identity;Identity))
 
 ## [Tests]
-(context: "Functor polytypism"
+(context: "Functor polytypism."
   (test "" true))