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

3 files changed, 70 insertions, 3 deletions

diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 07ab2959ba..292cb4dca0 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -2122,10 +2122,12 @@ wrapGenSyms binds body@(MkC b)
   = do  { var_ty <- lookupType nameTyConName
         ; go var_ty binds }
   where
-    (_, [elt_ty]) = tcSplitAppTys (exprType b)
+    (_, elt_ty) = tcSplitAppTy (exprType b)
         -- b :: m a, so we can get the type 'a' by looking at the
-        -- argument type. NB: this relies on Q being a data/newtype,
-        -- not a type synonym
+        -- argument type. Need to use `tcSplitAppTy` here as since
+        -- the overloaded quotations patch the type of the expression can
+        -- be something more complicated than just `Q a`.
+        -- See #17839 for when this went wrong with the type `WriterT () m a`
 
     go _ [] = return body
     go var_ty ((name,id) : binds)
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'])