Allow PartialTypeSignatures in standalone deriving contexts
authorRyan Scott <ryan.gl.scott@gmail.com>
Fri, 23 Mar 2018 16:06:04 +0000 (12:06 -0400)
committerRyan Scott <ryan.gl.scott@gmail.com>
Fri, 23 Mar 2018 16:06:05 +0000 (12:06 -0400)
Summary:
At its core, this patch is a simple tweak that allows a user
to write:

```lang=haskell
deriving instance _ => Eq (Foo a)
```

Which is functionally equivalent to:

```lang=haskell
data Foo a = ...
  deriving Eq
```

But with the added flexibility that `StandaloneDeriving` gives you
(namely, the ability to use it anywhere, not just in the same module
that `Foo` was declared in). This fixes #13324, and should hopefully
address a use case brought up in #10607.

Currently, only the use of a single, extra-constraints wildcard is
permitted in a standalone deriving declaration. Any other wildcard
is rejected, so things like
`deriving instance (Eq a, _) => Eq (Foo a)` are currently forbidden.

There are quite a few knock-on changes brought on by this change:

* The `HsSyn` type used to represent standalone-derived instances
  was previously `LHsSigType`, which isn't sufficient to hold
  wildcard types. This needed to be changed to `LHsSigWcType` as a
  result.

* Previously, `DerivContext` was a simple type synonym for
  `Maybe ThetaType`, under the assumption that you'd only ever be in
  the `Nothing` case if you were in a `deriving` clause. After this
  patch, that assumption no longer holds true, as you can also be
  in this situation with standalone deriving when an
  extra-constraints wildcard is used.

  As a result, I changed `DerivContext` to be a proper datatype that
  reflects the new wrinkle that this patch adds, and plumbed this
  through the relevant parts of `TcDeriv` and friends.

* Relatedly, the error-reporting machinery in `TcErrors` also assumed
  that if you have any unsolved constraints in a derived instance,
  then you should be able to fix it by switching over to standalone
  deriving. This was always sound advice before, but with this new
  feature, it's possible to have unsolved constraints even when
  you're standalone-deriving something!

  To rectify this, I tweaked some constructors of `CtOrigin` a bit
  to reflect this new subtlety.

This requires updating the Haddock submodule. See my fork at
https://github.com/RyanGlScott/haddock/commit/067d52fd4be15a1842cbb05f42d9d482de0ad3a7

Test Plan: ./validate

Reviewers: simonpj, goldfire, bgamari

Reviewed By: simonpj

Subscribers: goldfire, rwbarton, thomie, mpickering, carter

GHC Trac Issues: #13324

Differential Revision: https://phabricator.haskell.org/D4383

21 files changed:
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsDecls.hs
compiler/parser/Parser.y
compiler/rename/RnSource.hs
compiler/rename/RnTypes.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcDerivInfer.hs
compiler/typecheck/TcDerivUtils.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcRnTypes.hs
docs/users_guide/8.6.1-notes.rst
docs/users_guide/glasgow_exts.rst
testsuite/tests/partial-sigs/should_compile/T13324_compile.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/all.T
testsuite/tests/partial-sigs/should_fail/T13324_fail1.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/T13324_fail1.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/T13324_fail2.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/T13324_fail2.stderr [new file with mode: 0644]
testsuite/tests/partial-sigs/should_fail/all.T
utils/haddock

index 5029f9d..b74fa08 100644 (file)
@@ -488,7 +488,7 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
                    ; repDeriv strat' cxt' inst_ty' }
        ; return (loc, dec) }
   where
-    (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
+    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
 
 repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
 repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
index 6440758..3bb61e0 100644 (file)
@@ -351,7 +351,7 @@ cvtDec (TH.StandaloneDerivD ds cxt ty)
        ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
        ; returnJustL $ DerivD $
          DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds
-                   , deriv_type = mkLHsSigType inst_ty'
+                   , deriv_type = mkLHsSigWcType inst_ty'
                    , deriv_overlap_mode = Nothing } }
 
 cvtDec (TH.DefaultSigD nm typ)
index 475e31e..a3fe5a7 100644 (file)
@@ -1659,7 +1659,18 @@ type LDerivDecl pass = Located (DerivDecl pass)
 
 -- | Deriving Declaration
 data DerivDecl pass = DerivDecl
-        { deriv_type         :: LHsSigType pass
+        { deriv_type         :: LHsSigWcType pass
+          -- ^ The instance type to derive.
+          --
+          -- It uses an 'LHsSigWcType' because the context is allowed to be a
+          -- single wildcard:
+          --
+          -- > deriving instance _ => Eq (Foo a)
+          --
+          -- Which signifies that the context should be inferred.
+
+          -- See Note [Inferring the instance context] in TcDerivInfer.
+
         , deriv_strategy     :: Maybe (Located DerivStrategy)
         , deriv_overlap_mode :: Maybe (Located OverlapMode)
          -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',
index 898ed3c..12413f2 100644 (file)
@@ -1376,7 +1376,8 @@ stand_alone_deriving :: { LDerivDecl GhcPs }
   : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type
                 {% do { let { err = text "in the stand-alone deriving instance"
                                     <> colon <+> quotes (ppr $5) }
-                      ; ams (sLL $1 (hsSigType $>) (DerivDecl $5 $2 $4))
+                      ; ams (sLL $1 (hsSigType $>)
+                                 (DerivDecl (mkHsWildCardBndrs $5) $2 $4))
                             [mj AnnDeriving $1, mj AnnInstance $3] } }
 
 -----------------------------------------------------------------------------
index 447871a..d0ff527 100644 (file)
@@ -945,7 +945,7 @@ rnSrcDerivDecl (DerivDecl ty deriv_strat overlap)
        ; unless standalone_deriv_ok (addErr standaloneDerivErr)
        ; failIfTc (isJust deriv_strat && not deriv_strats_ok) $
            illegalDerivStrategyErr $ fmap unLoc deriv_strat
-       ; (ty', fvs) <- rnLHsInstType (text "a deriving declaration") ty
+       ; (ty', fvs) <- rnHsSigWcType DerivDeclCtx ty
        ; return (DerivDecl ty' deriv_strat overlap, fvs) }
 
 standaloneDerivErr :: SDoc
index b2dafb2..55b9fd5 100644 (file)
@@ -170,7 +170,7 @@ rnWcBody ctxt nwc_rdrs hs_ty
       , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
       = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
            ; wc' <- setSrcSpan lx $
-                    do { checkExtraConstraintWildCard env wc
+                    do { checkExtraConstraintWildCard env hs_ctxt1 wc
                        ; rnAnonWildCard wc }
            ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
            ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
@@ -188,26 +188,46 @@ rnWcBody ctxt nwc_rdrs hs_ty
     rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
 
 
-checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs
-                             -> RnM ()
+checkExtraConstraintWildCard
+  :: RnTyKiEnv -> HsContext GhcPs -> HsWildCardInfo GhcPs -> RnM ()
 -- Rename the extra-constraint spot in a type signature
 --    (blah, _) => type
 -- Check that extra-constraints are allowed at all, and
 -- if so that it's an anonymous wildcard
-checkExtraConstraintWildCard env wc
+checkExtraConstraintWildCard env hs_ctxt wc
   = checkWildCard env mb_bad
   where
     mb_bad | not (extraConstraintWildCardsAllowed env)
-           = Just (text "Extra-constraint wildcard" <+> quotes (ppr wc)
-                   <+> text "not allowed")
+           = Just base_msg
+             -- Currently, we do not allow wildcards in their full glory in
+             -- standalone deriving declarations. We only allow a single
+             -- extra-constraints wildcard à la:
+             --
+             --   deriving instance _ => Eq (Foo a)
+             --
+             -- i.e., we don't support things like
+             --
+             --   deriving instance (Eq a, _) => Eq (Foo a)
+           | DerivDeclCtx {} <- rtke_ctxt env
+           , not (null hs_ctxt)
+           = Just deriv_decl_msg
            | otherwise
            = Nothing
 
+    base_msg = text "Extra-constraint wildcard" <+> quotes (ppr wc)
+                   <+> text "not allowed"
+
+    deriv_decl_msg
+      = hang base_msg
+           2 (vcat [ text "except as the sole constraint"
+                   , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])
+
 extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
 extraConstraintWildCardsAllowed env
   = case rtke_ctxt env of
       TypeSigCtx {}       -> True
       ExprWithTySigCtx {} -> True
+      DerivDeclCtx {}     -> True
       _                   -> False
 
 -- | Finds free type and kind variables in a type,
@@ -324,7 +344,7 @@ rnImplicitBndrs bind_free_tvs doc
          thing_inside vars }
 
 rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
--- Rename the type in an instance or standalone deriving decl
+-- Rename the type in an instance.
 -- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma"
 -- Do not try to decompose the inst_ty in case it is malformed
 rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty
index 294b42c..152292d 100644 (file)
@@ -613,10 +613,11 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
        ; let deriv_strat = fmap unLoc deriv_strat'
        ; traceTc "Deriving strategy (standalone deriving)" $
            vcat [ppr deriv_strat, ppr deriv_ty]
-       ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
+       ; (tvs, deriv_ctxt, cls, inst_tys)
+           <- tcStandaloneDerivInstType deriv_ty
        ; traceTc "Standalone deriving;" $ vcat
               [ text "tvs:" <+> ppr tvs
-              , text "theta:" <+> ppr theta
+              , text "deriv_ctxt:" <+> ppr deriv_ctxt
               , text "cls:" <+> ppr cls
               , text "tys:" <+> ppr inst_tys ]
                 -- C.f. TcInstDcls.tcLocalInstDecl1
@@ -641,13 +642,58 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
               | otherwise
               -> Just <$> mkEqnHelp (fmap unLoc overlap_mode)
                                     tvs cls cls_tys tc tc_args
-                                    (Just theta) deriv_strat
+                                    deriv_ctxt deriv_strat
 
            _  -> -- Complain about functions, primitive types, etc,
                  bale_out $
                  text "The last argument of the instance must be a data or newtype application"
         }
 
+-- Typecheck the type in a standalone deriving declaration.
+--
+-- This may appear dense, but it's mostly huffing and puffing to recognize
+-- the special case of a type with an extra-constraints wildcard context, e.g.,
+--
+--   deriving instance _ => Eq (Foo a)
+--
+-- If there is such a wildcard, we typecheck this as if we had written
+-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@,
+-- as the 'DerivContext', where loc is the location of the wildcard used for
+-- error reporting. This indicates that we should infer the context as if we
+-- were deriving Eq via a deriving clause
+-- (see Note [Inferring the instance context] in TcDerivInfer).
+--
+-- If there is no wildcard, then proceed as normal, and instead return
+-- @'SupplyContext' theta@, where theta is the typechecked context.
+--
+-- Note that this will never return @'InferContext' 'Nothing'@, as that can
+-- only happen with @deriving@ clauses.
+tcStandaloneDerivInstType
+  :: LHsSigWcType GhcRn
+  -> TcM ([TyVar], DerivContext, Class, [Type])
+tcStandaloneDerivInstType
+    (HsWC { hswc_body = deriv_ty@(HsIB { hsib_vars   = vars
+                                       , hsib_closed = closed
+                                       , hsib_body   = deriv_ty_body })})
+  | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body
+  , L _ [wc_pred] <- theta
+  , L _ (HsWildCardTy (AnonWildCard (L wc_span _))) <- ignoreParens wc_pred
+  = do (deriv_tvs, _deriv_theta, deriv_cls, deriv_inst_tys)
+         <- tc_hs_cls_inst_ty $
+            HsIB { hsib_vars = vars
+                 , hsib_closed = closed
+                 , hsib_body
+                     = L (getLoc deriv_ty_body) $
+                       HsForAllTy { hst_bndrs = tvs
+                                  , hst_body  = rho }}
+       pure (deriv_tvs, InferContext (Just wc_span), deriv_cls, deriv_inst_tys)
+  | otherwise
+  = do (deriv_tvs, deriv_theta, deriv_cls, deriv_inst_tys)
+         <- tc_hs_cls_inst_ty deriv_ty
+       pure (deriv_tvs, SupplyContext deriv_theta, deriv_cls, deriv_inst_tys)
+  where
+    tc_hs_cls_inst_ty = tcHsClsInstType TcType.InstDeclCtxt
+
 warnUselessTypeable :: TcM ()
 warnUselessTypeable
   = do { warn <- woptM Opt_WarnDerivingTypeable
@@ -659,7 +705,7 @@ warnUselessTypeable
 deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
                                              --   Can be a data instance, hence [Type] args
              -> Maybe DerivStrategy          -- The optional deriving strategy
-             -> LHsSigType GhcRn             -- The deriving predicate
+             -> LHsSigType GhcRn           -- The deriving predicate
              -> TcM (Maybe EarlyDerivSpec)
 -- The deriving clause of a data or newtype declaration
 -- I.e. not standalone deriving
@@ -667,7 +713,8 @@ deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
 -- This returns a Maybe because the user might try to derive Typeable, which is
 -- a no-op nowadays.
 deriveTyData tvs tc tc_args deriv_strat deriv_pred
-  = setSrcSpan (getLoc (hsSigType deriv_pred)) $  -- Use loc of the 'deriving' item
+  = setSrcSpan (getLoc (hsSigType deriv_pred)) $
+    -- Use loc of the 'deriving' item
     do  { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
                 <- tcExtendTyVarEnv tvs $
                    tcHsDeriv deriv_pred
@@ -754,7 +801,7 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
 
         ; spec <- mkEqnHelp Nothing tkvs
                             cls final_cls_tys tc final_tc_args
-                            Nothing deriv_strat
+                            (InferContext Nothing) deriv_strat
         ; traceTc "derivTyData" (ppr spec)
         ; return $ Just spec } }
 
@@ -932,8 +979,10 @@ mkEqnHelp :: Maybe OverlapMode
           -> [TyVar]
           -> Class -> [Type]
           -> TyCon -> [Type]
-          -> DerivContext       -- Just    => context supplied (standalone deriving)
-                                -- Nothing => context inferred (deriving on data decl)
+          -> DerivContext
+               -- SupplyContext => context supplied (standalone deriving)
+               -- InferContext  => context inferred (deriving on data decl, or
+               --                  standalone deriving decl with a wildcard)
           -> Maybe DerivStrategy
           -> TcRn EarlyDerivSpec
 -- Make the EarlyDerivSpec for an instance
@@ -941,7 +990,7 @@ mkEqnHelp :: Maybe OverlapMode
 -- where the 'theta' is optional (that's the Maybe part)
 -- Assumes that this declaration is well-kinded
 
-mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat
+mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args deriv_ctxt deriv_strat
   = do {      -- Find the instance of a data family
               -- Note [Looking up family instances for deriving]
          fam_envs <- tcGetFamInstEnvs
@@ -963,7 +1012,7 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat
                          , denv_tc_args      = tc_args
                          , denv_rep_tc       = rep_tc
                          , denv_rep_tc_args  = rep_tc_args
-                         , denv_mtheta       = mtheta
+                         , denv_ctxt         = deriv_ctxt
                          , denv_strat        = deriv_strat }
        ; flip runReaderT deriv_env $
          if isNewTyCon rep_tc then mkNewTypeEqn else mkDataTypeEqn }
@@ -1063,14 +1112,14 @@ mk_data_eqn mechanism
                 , denv_rep_tc       = rep_tc
                 , denv_cls          = cls
                 , denv_cls_tys      = cls_tys
-                , denv_mtheta       = mtheta } <- ask
+                , denv_ctxt         = deriv_ctxt } <- ask
        let inst_ty  = mkTyConApp tc tc_args
            inst_tys = cls_tys ++ [inst_ty]
        doDerivInstErrorChecks1 mechanism
        loc       <- lift getSrcSpanM
        dfun_name <- lift $ newDFunName' cls tc
-       case mtheta of
-        Nothing -> -- Infer context
+       case deriv_ctxt of
+        InferContext wildcard ->
           do { (inferred_constraints, tvs', inst_tys')
                  <- inferConstraints mechanism
              ; return $ InferTheta $ DS
@@ -1080,9 +1129,10 @@ mk_data_eqn mechanism
                    , ds_tc = rep_tc
                    , ds_theta = inferred_constraints
                    , ds_overlap = overlap_mode
+                   , ds_standalone_wildcard = wildcard
                    , ds_mechanism = mechanism } }
 
-        Just theta -> do -- Specified context
+        SupplyContext theta ->
             return $ GivenTheta $ DS
                    { ds_loc = loc
                    , ds_name = dfun_name, ds_tvs = tvs
@@ -1090,6 +1140,7 @@ mk_data_eqn mechanism
                    , ds_tc = rep_tc
                    , ds_theta = theta
                    , ds_overlap = overlap_mode
+                   , ds_standalone_wildcard = Nothing
                    , ds_mechanism = mechanism }
 
 mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
@@ -1100,9 +1151,9 @@ mk_eqn_stock go_for_it bale_out
                 , denv_rep_tc  = rep_tc
                 , denv_cls     = cls
                 , denv_cls_tys = cls_tys
-                , denv_mtheta  = mtheta } <- ask
+                , denv_ctxt    = deriv_ctxt } <- ask
        dflags <- getDynFlags
-       case checkSideConditions dflags mtheta cls cls_tys tc rep_tc of
+       case checkSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc of
          CanDerive gen_fn        -> go_for_it $ DerivSpecStock gen_fn
          DerivableClassError msg -> bale_out msg
          _                       -> bale_out (nonStdErr cls)
@@ -1124,7 +1175,7 @@ mk_eqn_no_mechanism go_for_it bale_out
                 , denv_rep_tc  = rep_tc
                 , denv_cls     = cls
                 , denv_cls_tys = cls_tys
-                , denv_mtheta  = mtheta } <- ask
+                , denv_ctxt    = deriv_ctxt } <- ask
        dflags <- getDynFlags
 
            -- See Note [Deriving instances for classes themselves]
@@ -1136,7 +1187,7 @@ mk_eqn_no_mechanism go_for_it bale_out
              | otherwise
              = nonStdErr cls $$ msg
 
-       case checkSideConditions dflags mtheta cls cls_tys tc rep_tc of
+       case checkSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc of
            -- NB: pass the *representation* tycon to checkSideConditions
            NonDerivableClass   msg -> bale_out (dac_error msg)
            DerivableClassError msg -> bale_out msg
@@ -1162,8 +1213,9 @@ mkNewTypeEqn
                 , denv_rep_tc_args  = rep_tc_args
                 , denv_cls          = cls
                 , denv_cls_tys      = cls_tys
-                , denv_mtheta       = mtheta
+                , denv_ctxt         = deriv_ctxt
                 , denv_strat        = mb_strat } <- ask
+       sa_wildcard <- isStandaloneWildcardDeriv
        dflags <- getDynFlags
 
        let newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags
@@ -1175,22 +1227,24 @@ mkNewTypeEqn
              doDerivInstErrorChecks1 mechanism
              dfun_name <- lift $ newDFunName' cls tycon
              loc       <- lift getSrcSpanM
-             case mtheta of
-              Just theta -> return $ GivenTheta $ DS
+             case deriv_ctxt of
+              SupplyContext theta -> return $ GivenTheta $ DS
                   { ds_loc = loc
                   , ds_name = dfun_name, ds_tvs = tvs
                   , ds_cls = cls, ds_tys = inst_tys
                   , ds_tc = rep_tycon
                   , ds_theta = theta
                   , ds_overlap = overlap_mode
+                  , ds_standalone_wildcard = Nothing
                   , ds_mechanism = mechanism }
-              Nothing -> return $ InferTheta $ DS
+              InferContext wildcard -> return $ InferTheta $ DS
                   { ds_loc = loc
                   , ds_name = dfun_name, ds_tvs = tvs
                   , ds_cls = cls, ds_tys = inst_tys
                   , ds_tc = rep_tycon
                   , ds_theta = all_thetas
                   , ds_overlap = overlap_mode
+                  , ds_standalone_wildcard = wildcard
                   , ds_mechanism = mechanism }
            bale_out        = bale_out' newtype_deriving
            bale_out' b msg = do err <- derivingThingErrM b msg
@@ -1250,7 +1304,7 @@ mkNewTypeEqn
            rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
            rep_tys     = cls_tys ++ [rep_inst_ty]
            rep_pred    = mkClassPred cls rep_tys
-           rep_pred_o  = mkPredOrigin DerivOrigin TypeLevel rep_pred
+           rep_pred_o  = mkPredOrigin deriv_origin TypeLevel rep_pred
                    -- rep_pred is the representation dictionary, from where
                    -- we are gong to get all the methods for the newtype
                    -- dictionary
@@ -1261,9 +1315,10 @@ mkNewTypeEqn
            cls_tyvars = classTyVars cls
            inst_ty    = mkTyConApp tycon tc_args
            inst_tys   = cls_tys ++ [inst_ty]
-           sc_preds   = map (mkPredOrigin DerivOrigin TypeLevel) $
+           sc_preds   = map (mkPredOrigin deriv_origin TypeLevel) $
                         substTheta (zipTvSubst cls_tyvars inst_tys) $
                         classSCTheta cls
+           deriv_origin = mkDerivOrigin sa_wildcard
 
            -- Next we collect constraints for the class methods
            -- If there are no methods, we don't need any constraints
@@ -1275,8 +1330,8 @@ mkNewTypeEqn
                                         -- (Trac #12814)
                       | otherwise = rep_pred_o : coercible_constraints
            coercible_constraints
-             = [ mkPredOrigin (DerivOriginCoerce meth t1 t2) TypeLevel
-                              (mkReprPrimEqPred t1 t2)
+             = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)
+                              TypeLevel (mkReprPrimEqPred t1 t2)
                | meth <- meths
                , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs
                                             inst_tys rep_inst_ty meth ]
@@ -1367,7 +1422,7 @@ mkNewTypeEqn
                   || std_class_via_coercible cls)
           -> go_for_it_gnd
            | otherwise
-          -> case checkSideConditions dflags mtheta cls cls_tys
+          -> case checkSideConditions dflags deriv_ctxt cls cls_tys
                                       tycon rep_tycon of
                DerivableClassError msg
                  -- There's a particular corner case where
@@ -1629,13 +1684,14 @@ genInst :: DerivSpec theta
 -- See Note [Staging of tcDeriving]
 genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
                  , ds_mechanism = mechanism, ds_tys = tys
-                 , ds_cls = clas, ds_loc = loc })
+                 , ds_cls = clas, ds_loc = loc
+                 , ds_standalone_wildcard = wildcard })
   = do (meth_binds, deriv_stuff, unusedNames)
          <- set_span_and_ctxt $
             genDerivStuff mechanism loc clas rep_tycon tys tvs
        let mk_inst_info theta = set_span_and_ctxt $ do
              inst_spec <- newDerivClsInst theta spec
-             doDerivInstErrorChecks2 clas inst_spec mechanism
+             doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism
              traceTc "newder" (ppr inst_spec)
              return $ InstInfo
                        { iSpec   = inst_spec
@@ -1662,14 +1718,14 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
 doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
 doDerivInstErrorChecks1 mechanism = do
     DerivEnv { denv_tc      = tc
-             , denv_rep_tc  = rep_tc
-             , denv_mtheta  = mtheta } <- ask
+             , denv_rep_tc  = rep_tc } <- ask
+    standalone <- isStandaloneDeriv
     let anyclass_strategy = isDerivSpecAnyClass mechanism
         bale_out msg = do err <- derivingThingErrMechanism mechanism msg
                           lift $ failWithTc err
 
-    -- For standalone deriving (mtheta /= Nothing),
-    -- check that all the data constructors are in scope...
+    -- For standalone deriving, check that all the data constructors are in
+    -- scope...
     rdr_env <- lift getGlobalRdrEnv
     let data_con_names = map dataConName (tyConDataCons rep_tc)
         hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
@@ -1682,13 +1738,28 @@ doDerivInstErrorChecks1 mechanism = do
     -- ...however, we don't perform this check if we're using DeriveAnyClass,
     -- since it doesn't generate any code that requires use of a data
     -- constructor.
-    unless (anyclass_strategy || isNothing mtheta || not hidden_data_cons) $
+    unless (anyclass_strategy || not standalone || not hidden_data_cons) $
            bale_out $ derivingHiddenErr tc
 
-doDerivInstErrorChecks2 :: Class -> ClsInst -> DerivSpecMechanism -> TcM ()
-doDerivInstErrorChecks2 clas clas_inst mechanism
+doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
+                        -> DerivSpecMechanism -> TcM ()
+doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism
   = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)
        ; dflags <- getDynFlags
+       ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures
+       ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures
+
+         -- Error if PartialTypeSignatures isn't enabled when a user tries
+         -- to write @deriving instance _ => Eq (Foo a)@. Or, if that
+         -- extension is enabled, give a warning if -Wpartial-type-signatures
+         -- is enabled.
+       ; case wildcard of
+           Nothing -> pure ()
+           Just span -> setSrcSpan span $ do
+             checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion)
+             warnTc (Reason Opt_WarnPartialTypeSignatures)
+                    wpartial_sigs partial_sig_msg
+
          -- Check for Generic instances that are derived with an exotic
          -- deriving strategy like DAC
          -- See Note [Deriving strategies]
@@ -1700,6 +1771,12 @@ doDerivInstErrorChecks2 clas clas_inst mechanism
       DerivSpecStock{} -> False
       _                -> True
 
+    partial_sig_msg = text "Found type wildcard" <+> quotes (char '_')
+                  <+> text "standing for" <+> quotes (pprTheta theta)
+
+    pts_suggestion
+      = text "To use the inferred type, enable PartialTypeSignatures"
+
     gen_inst_err = text "Generic instances can only be derived in"
                <+> text "Safe Haskell using the stock strategy."
 
@@ -1951,6 +2028,6 @@ derivingHiddenErr tc
   = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
        2 (text "so you cannot derive an instance for it")
 
-standaloneCtxt :: LHsSigType GhcRn -> SDoc
+standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
 standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
                        2 (quotes (ppr ty))
index efad80f..ebabc0f 100644 (file)
@@ -73,6 +73,7 @@ inferConstraints mechanism
                   , denv_tc_args     = tc_args
                   , denv_cls         = main_cls
                   , denv_cls_tys     = cls_tys } <- ask
+       ; wildcard <- isStandaloneWildcardDeriv
        ; let is_anyclass = isDerivSpecAnyClass mechanism
              infer_constraints
                | is_anyclass = inferConstraintsDAC inst_tys
@@ -86,7 +87,8 @@ inferConstraints mechanism
              cls_tvs  = classTyVars main_cls
              sc_constraints = ASSERT2( equalLength cls_tvs inst_tys
                                      , ppr main_cls <+> ppr inst_tys )
-                              [ mkThetaOrigin DerivOrigin TypeLevel [] [] $
+                              [ mkThetaOrigin (mkDerivOrigin wildcard)
+                                              TypeLevel [] [] $
                                 substTheta cls_subst (classSCTheta main_cls) ]
              cls_subst = ASSERT( equalLength cls_tvs inst_tys )
                          zipTvSubst cls_tvs inst_tys
@@ -110,6 +112,7 @@ inferConstraintsDataConArgs inst_ty inst_tys
                 , denv_rep_tc_args = rep_tc_args
                 , denv_cls         = main_cls
                 , denv_cls_tys     = cls_tys } <- ask
+       wildcard <- isStandaloneWildcardDeriv
 
        let tc_binders = tyConBinders rep_tc
            choose_level bndr
@@ -134,7 +137,7 @@ inferConstraintsDataConArgs inst_ty inst_tys
                        -- No constraints for unlifted types
                        -- See Note [Deriving and unboxed types]
                      , not (isUnliftedType arg_ty)
-                     , let orig = DerivOriginDC data_con arg_n
+                     , let orig = DerivOriginDC data_con arg_n wildcard
                      , preds_and_mbSubst
                          <- get_arg_constraints orig arg_t_or_k arg_ty
                      ]
@@ -213,7 +216,7 @@ inferConstraintsDataConArgs inst_ty inst_tys
 
                -- Stupid constraints
            stupid_constraints
-             = [ mkThetaOrigin DerivOrigin TypeLevel [] [] $
+             = [ mkThetaOrigin deriv_origin TypeLevel [] [] $
                  substTheta tc_subst (tyConStupidTheta rep_tc) ]
            tc_subst = -- See the comment with all_rep_tc_args for an
                       -- explanation of this assertion
@@ -233,7 +236,7 @@ inferConstraintsDataConArgs inst_ty inst_tys
                constrs
                  | main_cls `hasKey` dataClassKey
                  , all (isLiftedTypeKind . typeKind) rep_tc_args
-                 = [ mk_cls_pred DerivOrigin t_or_k main_cls ty
+                 = [ mk_cls_pred deriv_origin t_or_k main_cls ty
                    | (t_or_k, ty) <- zip t_or_ks rep_tc_args]
                  | otherwise
                  = []
@@ -247,6 +250,8 @@ inferConstraintsDataConArgs inst_ty inst_tys
 
                     | otherwise   = cls_tys
 
+           deriv_origin = mkDerivOrigin wildcard
+
        if    -- Generic constraints are easy
           |  is_generic
            -> return ([], tvs, inst_tys)
@@ -292,6 +297,7 @@ inferConstraintsDAC :: [TcType] -> DerivM ([ThetaOrigin], [TyVar], [TcType])
 inferConstraintsDAC inst_tys
   = do { DerivEnv { denv_tvs = tvs
                   , denv_cls = cls } <- ask
+       ; wildcard <- isStandaloneWildcardDeriv
 
        ; let gen_dms = [ (sel_id, dm_ty)
                        | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
@@ -322,8 +328,9 @@ inferConstraintsDAC inst_tys
 
                     ; let dm_theta' = substTheta subst dm_theta
                           tau_eq = mkPrimEqPred meth_tau (substTy subst dm_tau)
-                    ; return (mkThetaOrigin DerivOrigin TypeLevel
-                                meth_tvs meth_theta (tau_eq:dm_theta')) }
+                    ; return (mkThetaOrigin (mkDerivOrigin wildcard)
+                                TypeLevel meth_tvs meth_theta
+                                (tau_eq:dm_theta')) }
 
        ; theta_origins <- lift $ pushTcLevelM_ (mapM do_one_meth gen_dms)
             -- Yuk: the pushTcLevel is to match the one wrapping the call
@@ -334,20 +341,28 @@ inferConstraintsDAC inst_tys
 
 {- Note [Inferring the instance context]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are two sorts of 'deriving':
+There are two sorts of 'deriving', as represented by the two constructors
+for DerivContext:
+
+  * InferContext mb_wildcard: This can either be:
+    - The deriving clause for a data type.
+        (e.g, data T a = T1 a deriving( Eq ))
+      In this case, mb_wildcard = Nothing.
+    - A standalone declaration with an extra-constraints wildcard
+        (e.g., deriving instance _ => Eq (Foo a))
+      In this case, mb_wildcard = Just loc, where loc is the location
+      of the extra-constraints wildcard.
 
-  * InferTheta: the deriving clause for a data type
-      data T a = T1 a deriving( Eq )
     Here we must infer an instance context,
     and generate instance declaration
       instance Eq a => Eq (T a) where ...
 
-  * CheckTheta: standalone deriving
+  * SupplyContext theta: standalone deriving
       deriving instance Eq a => Eq (T a)
     Here we only need to fill in the bindings;
-    the instance context is user-supplied
+    the instance context (theta) is user-supplied
 
-For a deriving clause (InferTheta) we must figure out the
+For the InferContext case, we must figure out the
 instance context (inferConstraintsDataConArgs). Suppose we are inferring
 the instance context for
     C t1 .. tn (T s1 .. sm)
@@ -539,8 +554,8 @@ See also Note [nonDetCmpType nondeterminism]
 
 simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]]
                          -> TcM [DerivSpec ThetaType]
--- Used only for deriving clauses (InferTheta)
--- not for standalone deriving
+-- Used only for deriving clauses or standalone deriving with an
+-- extra-constraints wildcard (InferContext)
 -- See Note [Simplifying the instance context]
 
 simplifyInstanceContexts [] = return []
index c9804ba..ef9e832 100644 (file)
@@ -12,7 +12,8 @@ module TcDerivUtils (
         DerivM, DerivEnv(..),
         DerivSpec(..), pprDerivSpec, DerivSpecMechanism(..),
         isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass,
-        DerivContext, DerivStatus(..),
+        DerivContext(..), DerivStatus(..),
+        isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin,
         PredOrigin(..), ThetaOrigin(..), mkPredOrigin,
         mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,
         checkSideConditions, hasStockDeriving,
@@ -51,6 +52,7 @@ import Util
 import VarSet
 
 import Control.Monad.Trans.Reader
+import Data.Maybe
 import qualified GHC.LanguageExtensions as LangExt
 import ListSetOps (assocMaybe)
 
@@ -59,6 +61,31 @@ import ListSetOps (assocMaybe)
 -- is a simple reader around 'TcRn'.
 type DerivM = ReaderT DerivEnv TcRn
 
+-- | Is GHC processing a stanalone deriving declaration?
+isStandaloneDeriv :: DerivM Bool
+isStandaloneDeriv = asks (go . denv_ctxt)
+  where
+    go :: DerivContext -> Bool
+    go (InferContext wildcard) = isJust wildcard
+    go (SupplyContext {})      = True
+
+-- | Is GHC processing a standalone deriving declaration with an
+-- extra-constraints wildcard as the context?
+-- (e.g., @deriving instance _ => Eq (Foo a)@)
+isStandaloneWildcardDeriv :: DerivM Bool
+isStandaloneWildcardDeriv = asks (go . denv_ctxt)
+  where
+    go :: DerivContext -> Bool
+    go (InferContext wildcard) = isJust wildcard
+    go (SupplyContext {})      = False
+
+-- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True',
+-- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting.
+mkDerivOrigin :: Bool -> CtOrigin
+mkDerivOrigin standalone_wildcard
+  | standalone_wildcard = StandAloneDerivOrigin
+  | otherwise           = DerivClauseOrigin
+
 -- | Contains all of the information known about a derived instance when
 -- determining what its @EarlyDerivSpec@ should be.
 data DerivEnv = DerivEnv
@@ -81,9 +108,12 @@ data DerivEnv = DerivEnv
   , denv_rep_tc_args  :: [Type]
     -- ^ The representation types for 'denv_tc_args'
     --   (for data family instances)
-  , denv_mtheta       :: DerivContext
-    -- ^ 'Just' the context of the instance, for standalone deriving.
-    --   'Nothing' for @deriving@ clauses.
+  , denv_ctxt         :: DerivContext
+    -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the
+    --   context of the instance).
+    --   'InferContext' for @deriving@ clauses, or for standalone deriving that
+    --   uses a wildcard constraint.
+    --   See @Note [Inferring the instance context]@.
   , denv_strat        :: Maybe DerivStrategy
     -- ^ 'Just' if user requests a particular deriving strategy.
     --   Otherwise, 'Nothing'.
@@ -98,7 +128,7 @@ instance Outputable DerivEnv where
                 , denv_tc_args      = tc_args
                 , denv_rep_tc       = rep_tc
                 , denv_rep_tc_args  = rep_tc_args
-                , denv_mtheta       = mtheta
+                , denv_ctxt         = ctxt
                 , denv_strat        = mb_strat })
     = hang (text "DerivEnv")
          2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode
@@ -109,18 +139,21 @@ instance Outputable DerivEnv where
                  , text "denv_tc_args"      <+> ppr tc_args
                  , text "denv_rep_tc"       <+> ppr rep_tc
                  , text "denv_rep_tc_args"  <+> ppr rep_tc_args
-                 , text "denv_mtheta"       <+> ppr mtheta
+                 , text "denv_ctxt"         <+> ppr ctxt
                  , text "denv_strat"        <+> ppr mb_strat ])
 
-data DerivSpec theta = DS { ds_loc       :: SrcSpan
-                          , ds_name      :: Name         -- DFun name
-                          , ds_tvs       :: [TyVar]
-                          , ds_theta     :: theta
-                          , ds_cls       :: Class
-                          , ds_tys       :: [Type]
-                          , ds_tc        :: TyCon
-                          , ds_overlap   :: Maybe OverlapMode
-                          , ds_mechanism :: DerivSpecMechanism }
+data DerivSpec theta = DS { ds_loc                 :: SrcSpan
+                          , ds_name                :: Name         -- DFun name
+                          , ds_tvs                 :: [TyVar]
+                          , ds_theta               :: theta
+                          , ds_cls                 :: Class
+                          , ds_tys                 :: [Type]
+                          , ds_tc                  :: TyCon
+                          , ds_overlap             :: Maybe OverlapMode
+                          , ds_standalone_wildcard :: Maybe SrcSpan
+                              -- See Note [Inferring the instance context]
+                              -- in TcDerivInfer
+                          , ds_mechanism           :: DerivSpecMechanism }
         -- This spec implies a dfun declaration of the form
         --       df :: forall tvs. theta => C tys
         -- The Name is the name for the DFun we'll build
@@ -150,15 +183,17 @@ Example:
 
 pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,
-                   ds_tys = tys, ds_theta = rhs, ds_mechanism = mech })
+                   ds_tys = tys, ds_theta = rhs,
+                   ds_standalone_wildcard = wildcard, ds_mechanism = mech })
   = hang (text "DerivSpec")
-       2 (vcat [ text "ds_loc       =" <+> ppr l
-               , text "ds_name      =" <+> ppr n
-               , text "ds_tvs       =" <+> ppr tvs
-               , text "ds_cls       =" <+> ppr c
-               , text "ds_tys       =" <+> ppr tys
-               , text "ds_theta     =" <+> ppr rhs
-               , text "ds_mechanism =" <+> ppr mech ])
+       2 (vcat [ text "ds_loc                  =" <+> ppr l
+               , text "ds_name                 =" <+> ppr n
+               , text "ds_tvs                  =" <+> ppr tvs
+               , text "ds_cls                  =" <+> ppr c
+               , text "ds_tys                  =" <+> ppr tys
+               , text "ds_theta                =" <+> ppr rhs
+               , text "ds_standalone_wildcard  =" <+> ppr wildcard
+               , text "ds_mechanism            =" <+> ppr mech ])
 
 instance Outputable theta => Outputable (DerivSpec theta) where
   ppr = pprDerivSpec
@@ -209,9 +244,29 @@ mechanismToStrategy (DerivSpecAnyClass{}) = AnyclassStrategy
 instance Outputable DerivSpecMechanism where
   ppr = ppr . mechanismToStrategy
 
-type DerivContext = Maybe ThetaType
-   -- Nothing    <=> Vanilla deriving; infer the context of the instance decl
-   -- Just theta <=> Standalone deriving: context supplied by programmer
+-- | Whether GHC is processing a @deriving@ clause or a standalone deriving
+-- declaration.
+data DerivContext
+  = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either:
+                                 --
+                                 -- * A @deriving@ clause (in which case
+                                 --   @mb_wildcard@ is 'Nothing').
+                                 --
+                                 -- * A standalone deriving declaration with
+                                 --   an extra-constraints wildcard as the
+                                 --   context (in which case @mb_wildcard@ is
+                                 --   @'Just' loc@, where @loc@ is the location
+                                 --   of the wildcard.
+                                 --
+                                 -- GHC should infer the context.
+
+  | SupplyContext ThetaType      -- ^ @'SupplyContext' theta@ is a standalone
+                                 -- deriving declaration, where @theta@ is the
+                                 -- context supplied by the user.
+
+instance Outputable DerivContext where
+  ppr (InferContext standalone) = text "InferContext"  <+> ppr standalone
+  ppr (SupplyContext theta)     = text "SupplyContext" <+> ppr theta
 
 data DerivStatus = CanDerive                 -- Stock class, can derive
                      (SrcSpan -> TyCon -> [Type]
@@ -421,8 +476,8 @@ getDataConFixityFun tc
 checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
                     -> TyCon -> TyCon
                     -> DerivStatus
-checkSideConditions dflags mtheta cls cls_tys tc rep_tc
-  | Just cond <- sideConditions mtheta cls
+checkSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc
+  | Just cond <- sideConditions deriv_ctxt cls
   = case (cond dflags tc rep_tc) of
         NotValid err -> DerivableClassError err  -- Class-specific error
         IsValid  | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
@@ -451,7 +506,7 @@ classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is n
 -- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
 -- class for which stock deriving isn't possible.
 sideConditions :: DerivContext -> Class -> Maybe Condition
-sideConditions mtheta cls
+sideConditions deriv_ctxt cls
   | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
   | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
   | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)
@@ -485,10 +540,10 @@ sideConditions mtheta cls
   | otherwise                      = Nothing
   where
     cls_key = getUnique cls
-    cond_std     = cond_stdOK mtheta False  -- Vanilla data constructors, at least one,
-                                            --    and monotype arguments
-    cond_vanilla = cond_stdOK mtheta True   -- Vanilla data constructors but
-                                            --   allow no data cons or polytype arguments
+    cond_std     = cond_stdOK deriv_ctxt False
+      -- Vanilla data constructors, at least one, and monotype arguments
+    cond_vanilla = cond_stdOK deriv_ctxt True
+      -- Vanilla data constructors but allow no data cons or polytype arguments
 
 canDeriveAnyClass :: DynFlags -> Validity
 -- IsValid: we can (try to) derive it via an empty instance declaration
@@ -542,8 +597,9 @@ andCond c1 c2 dflags tc rep_tc
 --
 -- 5. The data type cannot have fields with higher-rank types.
 cond_stdOK
-  :: DerivContext -- ^ 'Just' if this is standalone deriving, 'Nothing' if not.
-                  -- If it is standalone, we relax some of the validity checks
+  :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a
+                  -- user-supplied context, 'InferContext' if not.
+                  -- If it is the former, we relax some of the validity checks
                   -- we would otherwise perform (i.e., "just go for it").
 
   -> Bool         -- ^ 'True' <=> allow higher rank arguments and empty data
@@ -551,7 +607,7 @@ cond_stdOK
                   -- the -XEmptyDataDeriving extension.
 
   -> Condition
-cond_stdOK mtheta permissive dflags tc rep_tc
+cond_stdOK deriv_ctxt permissive dflags tc rep_tc
   = valid_ADT `andValid` valid_misc
   where
     valid_ADT, valid_misc :: Validity
@@ -565,25 +621,29 @@ cond_stdOK mtheta permissive dflags tc rep_tc
                <+> text "data or newtype application"
 
     valid_misc
-      = case mtheta of
-         Just _ -> IsValid
+      = case deriv_ctxt of
+         SupplyContext _ -> IsValid
                 -- Don't check these conservative conditions for
                 -- standalone deriving; just generate the code
                 -- and let the typechecker handle the result
-         Nothing
+         InferContext wildcard
            | null data_cons -- 1.
            , not permissive
            -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid`
               NotValid (no_cons_why rep_tc $$ empty_data_suggestion)
            | not (null con_whys)
-           -> NotValid (vcat con_whys $$ standalone_suggestion)
+           -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard)
            | otherwise
            -> IsValid
 
     empty_data_suggestion =
       text "Use EmptyDataDeriving to enable deriving for empty data types"
-    standalone_suggestion =
-      text "Possible fix: use a standalone deriving declaration instead"
+    possible_fix_suggestion wildcard
+      = case wildcard of
+          Just _ ->
+            text "Possible fix: fill in the wildcard constraint yourself"
+          Nothing ->
+            text "Possible fix: use a standalone deriving declaration instead"
     data_cons  = tyConDataCons rep_tc
     con_whys   = getInvalids (map check_con data_cons)
 
index 1dba42d..0700d02 100644 (file)
@@ -2779,13 +2779,18 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
                = empty
 
     drv_fixes = case orig of
-                   DerivOrigin      -> [drv_fix]
-                   DerivOriginDC {} -> [drv_fix]
-                   DerivOriginCoerce {} -> [drv_fix]
+                   DerivClauseOrigin                  -> [drv_fix False]
+                   StandAloneDerivOrigin              -> [drv_fix True]
+                   DerivOriginDC _ _       standalone -> [drv_fix standalone]
+                   DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone]
                    _                -> []
 
-    drv_fix = hang (text "use a standalone 'deriving instance' declaration,")
-                 2 (text "so you can specify the instance context yourself")
+    drv_fix standalone_wildcard
+      | standalone_wildcard
+      = text "fill in the wildcard constraint yourself"
+      | otherwise
+      = hang (text "use a standalone 'deriving instance' declaration,")
+           2 (text "so you can specify the instance context yourself")
 
     -- Normal overlap error
     overlap_msg
index 27482b1..a2afe43 100644 (file)
@@ -3359,13 +3359,24 @@ data CtOrigin
                         --    then TypeSize = sizeTypes [ty1, .., tyn]
                         -- See Note [Solving superclass constraints] in TcInstDcls
 
-  | DerivOrigin         -- Typechecking deriving
-  | DerivOriginDC DataCon Int
-                        -- Checking constraints arising from this data con and field index
-  | DerivOriginCoerce Id Type Type
+  | DerivClauseOrigin   -- Typechecking a deriving clause (as opposed to
+                        -- standalone deriving).
+  | DerivOriginDC DataCon Int Bool
+      -- Checking constraints arising from this data con and field index. The
+      -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if
+      -- standalong deriving (with a wildcard constraint) is being used. This
+      -- is used to inform error messages on how to recommended fixes (e.g., if
+      -- the argument is True, then don't recommend "use standalone deriving",
+      -- but rather "fill in the wildcard constraint yourself").
+      -- See Note [Inferring the instance context] in TcDerivInfer
+  | DerivOriginCoerce Id Type Type Bool
                         -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from
                         -- `ty1` to `ty2`.
-  | StandAloneDerivOrigin -- Typechecking stand-alone deriving
+  | StandAloneDerivOrigin -- Typechecking stand-alone deriving. Useful for
+                          -- constraints coming from a wildcard constraint,
+                          -- e.g., deriving instance _ => Eq (Foo a)
+                          -- See Note [Inferring the instance context]
+                          -- in TcDerivInfer
   | DefaultOrigin       -- Typechecking a default decl
   | DoOrigin            -- Arising from a do expression
   | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in
@@ -3558,14 +3569,14 @@ pprCtOrigin (KindEqOrigin t1 Nothing _ _)
 pprCtOrigin (UnboundOccurrenceOf name)
   = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name)
 
-pprCtOrigin (DerivOriginDC dc n)
+pprCtOrigin (DerivOriginDC dc n _)
   = hang (ctoHerald <+> text "the" <+> speakNth n
           <+> text "field of" <+> quotes (ppr dc))
        2 (parens (text "type" <+> quotes (ppr ty)))
   where
     ty = dataConOrigArgTys dc !! (n-1)
 
-pprCtOrigin (DerivOriginCoerce meth ty1 ty2)
+pprCtOrigin (DerivOriginCoerce meth ty1 ty2 _)
   = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth))
        2 (sep [ text "from type" <+> quotes (ppr ty1)
               , nest 2 $ text "to type" <+> quotes (ppr ty2) ])
@@ -3627,7 +3638,7 @@ pprCtO TupleOrigin           = text "a tuple"
 pprCtO NegateOrigin          = text "a use of syntactic negation"
 pprCtO (ScOrigin n)          = text "the superclasses of an instance declaration"
                                <> whenPprDebug (parens (ppr n))
-pprCtO DerivOrigin           = text "the 'deriving' clause of a data type declaration"
+pprCtO DerivClauseOrigin     = text "the 'deriving' clause of a data type declaration"
 pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration"
 pprCtO DefaultOrigin         = text "a 'default' declaration"
 pprCtO DoOrigin              = text "a do statement"
index 1e3f509..04ff09c 100644 (file)
@@ -21,6 +21,16 @@ Full details
 
 Language
 ~~~~~~~~
+- GHC now permits the use of a wildcard type as the context of a standalone
+  ``deriving`` declaration with the use of the
+  :extension:`PartialTypeSignatures` language extension. For instance, this
+  declaration: ::
+
+    deriving instance _ => Eq (Foo a)
+
+  Denotes a derived ``Eq (Foo a)`` instance, where the context is inferred in
+  much the same way as ordinary ``deriving`` clauses do.
+  See :ref:`partial-type-signatures`.
 
 - Data declarations with empty ``where`` clauses are no longer valid without the
   extension :extension:`GADTSyntax` enabled. For instance, consider the
index 1717cbb..0cb8a6a 100644 (file)
@@ -3908,11 +3908,21 @@ number of important ways:
    module as the data type declaration. (But be aware of the dangers of
    orphan instances (:ref:`orphan-modules`).
 
--  You must supply an explicit context (in the example the context is
-   ``(Eq a)``), exactly as you would in an ordinary instance
+-  In most cases, you must supply an explicit context (in the example the
+   context is ``(Eq a)``), exactly as you would in an ordinary instance
    declaration. (In contrast, in a ``deriving`` clause attached to a
    data type declaration, the context is inferred.)
 
+   The exception to this rule is that the context of a standalone deriving
+   declaration can infer its context when a single, extra-wildcards constraint
+   is used as the context, such as in: ::
+
+         deriving instance _ => Eq (Foo a)
+
+   This is essentially the same as if you had written ``deriving Foo`` after
+   the declaration for ``data Foo a``. Using this feature requires the use of
+   :extension:`PartialTypeSignatures` (:ref:`partial-type-signatures`).
+
 -  Unlike a ``deriving`` declaration attached to a ``data`` declaration,
    the instance can be more specific than the data type (assuming you
    also use :extension:`FlexibleInstances`, :ref:`instance-rules`). Consider
@@ -11568,6 +11578,15 @@ Anonymous wildcards are also allowed in visible type applications
 argument to ``wurble``, then you can say ``wurble @_ @Int`` where the first
 argument is a wildcard.
 
+Standalone ``deriving`` declarations permit the use of a single,
+extra-constraints wildcard, like so: ::
+
+   deriving instance _ => Eq (Foo a)
+
+This denotes a derived ``Eq (Foo a)`` instance where the context is inferred,
+in much the same way that ordinary ``deriving`` clauses do. Any other use of
+wildcards in a standalone ``deriving`` declaration is prohibited.
+
 In all other contexts, type wildcards are disallowed, and a named wildcard is treated
 as an ordinary type variable.  For example: ::
 
diff --git a/testsuite/tests/partial-sigs/should_compile/T13324_compile.hs b/testsuite/tests/partial-sigs/should_compile/T13324_compile.hs
new file mode 100644 (file)
index 0000000..670744e
--- /dev/null
@@ -0,0 +1,7 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module T13324_compile where
+
+data Option a = None | Some a
+
+deriving instance _ => Show (Option a)
index ebf6338..0a0483b 100644 (file)
@@ -69,6 +69,7 @@ test('T12156', normal, compile_fail, ['-fdefer-typed-holes'])
 test('T12531', normal, compile, ['-fdefer-typed-holes'])
 test('T12845', normal, compile, [''])
 test('T12844', normal, compile, [''])
+test('T13324_compile', normal, compile, ['-Wno-partial-type-signatures'])
 test('T13482', normal, compile, [''])
 test('T14217', normal, compile_fail, [''])
 test('T14643', normal, compile, [''])
diff --git a/testsuite/tests/partial-sigs/should_fail/T13324_fail1.hs b/testsuite/tests/partial-sigs/should_fail/T13324_fail1.hs
new file mode 100644 (file)
index 0000000..a177cbd
--- /dev/null
@@ -0,0 +1,8 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module T13324_fail1 where
+
+data Option a = None | Some a
+
+deriving instance (Eq a, _) => Eq (Option a)
+deriving instance (Show _) => Show (Option a)
diff --git a/testsuite/tests/partial-sigs/should_fail/T13324_fail1.stderr b/testsuite/tests/partial-sigs/should_fail/T13324_fail1.stderr
new file mode 100644 (file)
index 0000000..dd3a994
--- /dev/null
@@ -0,0 +1,10 @@
+
+T13324_fail1.hs:7:26: error:
+    Extra-constraint wildcard ‘_’ not allowed
+      except as the sole constraint
+        e.g., deriving instance _ => Eq (Foo a)
+      in a deriving declaration
+
+T13324_fail1.hs:8:25: error:
+    Wildcard ‘_’ not allowed
+      in a deriving declaration
diff --git a/testsuite/tests/partial-sigs/should_fail/T13324_fail2.hs b/testsuite/tests/partial-sigs/should_fail/T13324_fail2.hs
new file mode 100644 (file)
index 0000000..41f36c7
--- /dev/null
@@ -0,0 +1,11 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module T13324_fail2 where
+
+newtype Foo f a = Foo (f (f a))
+deriving instance _ => Eq (Foo f a)
+
+data T a where
+    MkT :: T Int
+deriving instance _ => Eq (T a)
diff --git a/testsuite/tests/partial-sigs/should_fail/T13324_fail2.stderr b/testsuite/tests/partial-sigs/should_fail/T13324_fail2.stderr
new file mode 100644 (file)
index 0000000..75e4829
--- /dev/null
@@ -0,0 +1,12 @@
+
+T13324_fail2.hs:7:1: error:
+    • No instance for (Eq (f (f a)))
+        arising from a 'deriving' declaration
+      Possible fix: fill in the wildcard constraint yourself
+    • When deriving the instance for (Eq (Foo f a))
+
+T13324_fail2.hs:11:1: error:
+    • Can't make a derived instance of ‘Eq (T a)’:
+        Constructor ‘MkT’ is a GADT
+        Possible fix: fill in the wildcard constraint yourself
+    • In the stand-alone deriving instance for ‘_ => Eq (T a)’
index 0f7496d..2439f64 100644 (file)
@@ -64,6 +64,8 @@ test('PatBind3', normal, compile_fail, [''])
 test('T12039', normal, compile_fail, [''])
 test('T12634', normal, compile_fail, [''])
 test('T12732', normal, compile_fail, ['-fobject-code -fdefer-typed-holes'])
+test('T13324_fail1', normal, compile_fail, [''])
+test('T13324_fail2', normal, compile_fail, [''])
 test('T14040a', normal, compile_fail, [''])
 test('T14449', normal, compile_fail, [''])
 test('T14479', normal, compile_fail, [''])
index 4804e39..067d52f 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 4804e39144dc0ded9b38dbb3442b6016ac719a1a
+Subproject commit 067d52fd4be15a1842cbb05f42d9d482de0ad3a7