Commit 674c969c authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Fix #8631.

This patch allows turning on ImpredicativeTypes while type-checking
the code generated by GeneralizedNewtypeDeriving. It does this
by adding a field ib_extensions to InstBindings, informing the
type-checker what extensions should be enabled while type-checking
the instance.
parent 4f6a0f48
......@@ -469,11 +469,13 @@ renameDeriv is_boot inst_infos bagBinds
where
rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
rn_inst_info inst_info@(InstInfo { iSpec = inst
, iBinds = InstBindings
{ ib_binds = binds
, ib_pragmas = sigs
, ib_standalone_deriving = sa } })
rn_inst_info
inst_info@(InstInfo { iSpec = inst
, iBinds = InstBindings
{ ib_binds = binds
, ib_pragmas = sigs
, ib_extensions = exts -- only for type-checking
, ib_standalone_deriving = sa } })
= -- Bring the right type variables into
-- scope (yuk), and rename the method binds
ASSERT( null sigs )
......@@ -481,6 +483,7 @@ renameDeriv is_boot inst_infos bagBinds
do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds
; let binds' = InstBindings { ib_binds = rn_binds
, ib_pragmas = []
, ib_extensions = exts
, ib_standalone_deriving = sa }
; return (inst_info { iBinds = binds' }, fvs) }
where
......@@ -1966,6 +1969,7 @@ genInst standalone_deriv oflag comauxs
, iBinds = InstBindings
{ ib_binds = gen_Newtype_binds loc clas tvs tys rhs_ty
, ib_pragmas = []
, ib_extensions = [Opt_ImpredicativeTypes]
, ib_standalone_deriving = standalone_deriv } }
, emptyBag
, Just $ getName $ head $ tyConDataCons rep_tycon ) }
......@@ -1981,6 +1985,7 @@ genInst standalone_deriv oflag comauxs
, iBinds = InstBindings
{ ib_binds = meth_binds
, ib_pragmas = []
, ib_extensions = []
, ib_standalone_deriving = standalone_deriv } }
; return ( inst_info, deriv_stuff, Nothing ) }
where
......
......@@ -715,6 +715,10 @@ data InstBindings a
{ ib_binds :: (LHsBinds a) -- Bindings for the instance methods
, ib_pragmas :: [LSig a] -- User pragmas recorded for generating
-- specialised instances
, ib_extensions :: [ExtensionFlag] -- any extra extensions that should
-- be enabled when type-checking this
-- instance; needed for
-- GeneralizedNewtypeDeriving
, ib_standalone_deriving :: Bool
-- True <=> This code came from a standalone deriving clause
......
......@@ -141,6 +141,7 @@ metaTyConsToDerivStuff tc metaDts =
d_inst = mk_inst dClas d_metaTycon d_dfun_name
d_binds = InstBindings { ib_binds = dBinds
, ib_pragmas = []
, ib_extensions = []
, ib_standalone_deriving = False }
d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
......@@ -150,6 +151,7 @@ metaTyConsToDerivStuff tc metaDts =
| (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
c_binds = [ InstBindings { ib_binds = c
, ib_pragmas = []
, ib_extensions = []
, ib_standalone_deriving = False }
| c <- cBinds ]
c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs })
......@@ -161,6 +163,7 @@ metaTyConsToDerivStuff tc metaDts =
(myZip2 s_metaTycons s_dfun_names)
s_binds = [ [ InstBindings { ib_binds = s
, ib_pragmas = []
, ib_extensions = []
, ib_standalone_deriving = False }
| s <- ss ] | ss <- sBinds ]
s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is
......
......@@ -572,6 +572,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
, iBinds = InstBindings
{ ib_binds = binds
, ib_pragmas = uprags
, ib_extensions = []
, ib_standalone_deriving = False } }
; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) }
......@@ -1175,13 +1176,17 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
(spec_inst_prags, prag_fn)
op_items (InstBindings { ib_binds = binds
, ib_pragmas = sigs
, ib_extensions = exts
, ib_standalone_deriving
= standalone_deriv })
= do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
; let hs_sig_fn = mkHsSigFun sigs
; checkMinimalDefinition
; mapAndUnzipM (tc_item hs_sig_fn) op_items }
; set_exts exts $ mapAndUnzipM (tc_item hs_sig_fn) op_items }
where
set_exts :: [ExtensionFlag] -> TcM a -> TcM a
set_exts es thing = foldr setXOptM thing es
----------------------
tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, (Origin, LHsBind Id))
tc_item sig_fn (sel_id, dm_info)
......
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module T8631 where
import Control.Monad.Trans.Cont
import Control.Monad.Trans.State.Lazy
newtype AnyContT m a = AnyContT { unAnyContT :: forall r . ContT r m a }
class MonadAnyCont b m where
anyContToM :: (forall r . (a -> b r) -> b r) -> m a
instance MonadAnyCont b (AnyContT m) where
anyContToM _ = error "foo"
data DecodeState = DecodeState
newtype DecodeAST a = DecodeAST { unDecodeAST :: AnyContT (StateT DecodeState IO) a }
deriving (MonadAnyCont IO)
\ No newline at end of file
......@@ -36,4 +36,4 @@ test('T5628', exit_code(1), compile_and_run, [''])
test('T5712', normal, compile_and_run, [''])
test('T7931', normal, compile_and_run, [''])
test('T8280', normal, compile_and_run, [''])
test('T8631', normal, compile, [''])
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