diff options
| -rw-r--r-- | compiler/typecheck/TcDeriv.lhs | 15 | ||||
| -rw-r--r-- | compiler/typecheck/TcEnv.lhs | 4 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenGenerics.lhs | 3 | ||||
| -rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 7 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_run/T8631.hs | 22 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_run/all.T | 2 |
6 files changed, 46 insertions, 7 deletions
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index db79061e2f..f9f7c0ac00 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -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 diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index a2df338140..f3d754640f 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -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 diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 564cd9ef9b..d9d92ba2ea 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -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 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 21af9a6e82..f701b30db8 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -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) diff --git a/testsuite/tests/deriving/should_run/T8631.hs b/testsuite/tests/deriving/should_run/T8631.hs new file mode 100644 index 0000000000..41c70f9d86 --- /dev/null +++ b/testsuite/tests/deriving/should_run/T8631.hs @@ -0,0 +1,22 @@ +{-# 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 diff --git a/testsuite/tests/deriving/should_run/all.T b/testsuite/tests/deriving/should_run/all.T index 572f95bacd..15fa39bc31 100644 --- a/testsuite/tests/deriving/should_run/all.T +++ b/testsuite/tests/deriving/should_run/all.T @@ -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, ['']) |