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.

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

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

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

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)

testsuite/tests/deriving/should_run/T8631.hs

+{-# 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

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, [''])