Commit 0482f58a authored by Matthew Pickering's avatar Matthew Pickering Committed by Marge Bot

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
parent 0a4c89b2
......@@ -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)
......
{-# 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
......@@ -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'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment