diff options
| -rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/th/overloaded/T17839.hs | 64 | ||||
| -rw-r--r-- | testsuite/tests/th/overloaded/all.T | 1 |
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']) |