TH: wrapGenSyns, don't split the element type too much

The invariant which allowed the pervious method of splitting the type of
the body to find the type of the elements didn't work in the new
overloaded quotation world as the type can be something like
`WriterT () m a` rather than `Q a` like before.

Fixes #17839

2 files changed, 65 insertions, 0 deletions

diff --git a/testsuite/tests/th/overloaded/T17839.hs b/testsuite/tests/th/overloaded/T17839.hs
new file mode 100644
index 0000000000..9946811d90
--- /dev/null
+++ b/testsuite/tests/th/overloaded/T17839.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module T17839 where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import qualified Data.Map as Map
+import Control.Monad.State
+import Control.Monad.Writer
+import Language.Haskell.TH
+import qualified Control.Monad.Writer as W
+import Data.Functor.Identity
+
+
+type LetT m a = WriterT [Locus] m a
+
+type Code m a = m (TExp a)
+
+type LetCode m a = LetT m (TExp a)
+
+data Locus = Locus
+
+instance (Monoid w, Quote m) => Quote (WriterT w m) where
+  newName x = W.lift (newName x)
+
+instance (Monoid w, Quote m) => Quote (StateT w m) where
+  newName x = W.lift (newName x)
+
+
+locus :: (Locus -> LetCode m a) -> Code m a
+locus = undefined
+
+newTypedName :: Quote m => m (TExp a)
+newTypedName = do
+  n <- newName "n"
+  return (TExp (VarE n))
+
+
+gen :: Quote m => Locus -> (Code Identity (a -> b) -> LetCode m a -> LetCode m b) -> LetCode m (a -> b)
+gen l f = do
+  n <- newTypedName
+  [|| \a -> $$(f (Identity n) [|| a ||]) ||]
+
+
+mrfix :: forall a b m r . (Monad m, Ord a, Quote m)
+      => (forall m . (a -> Code m (b -> r)) -> (a -> Code m b -> Code m r))
+      -> (a -> Code m (b -> r))
+mrfix f x =
+  flip evalStateT Map.empty $
+    locus $ \locus -> do
+      m <- get
+      let loop :: a -> LetT (StateT (Map.Map a (Identity (TExp (b -> r)))) m) (TExp (b -> r))
+          loop n =
+            case Map.lookup n m of
+              Just (Identity v) -> return v
+              Nothing -> do
+                gen locus (\g y -> do
+                  modify (Map.insert n g)
+                  f loop n y)
+      loop x
+
+
diff --git a/testsuite/tests/th/overloaded/all.T b/testsuite/tests/th/overloaded/all.T
index e5c9194ee2..1cb1eb1424 100644
--- a/testsuite/tests/th/overloaded/all.T
+++ b/testsuite/tests/th/overloaded/all.T
@@ -21,3 +21,4 @@ test('TH_overloaded_constraints', normal, compile, ['-v0'])
 test('TH_overloaded_constraints_fail', normal, compile_fail, ['-v0'])
 test('TH_overloaded_no_instance', normal, compile_fail, ['-v0'])
 test('TH_overloaded_csp', normal, compile_and_run, ['-v0'])
+test('T17839', normal, compile, ['-v0 -package mtl -package containers'])