Allow PartialTypeSignatures in standalone deriving contexts

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

1 files changed, 114 insertions, 37 deletions

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 294b42c530..152292d5b1 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -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))