Refactor some cruft in TcDeriv

* `mk_eqn_stock`, `mk_eqn_anyclass`, and `mk_eqn_no_mechanism` all
  took a continuation of type
  `DerivSpecMechanism -> DerivM EarlyDerivSpec` to represent its
  primary control flow. However, in practice this continuation was
  always instantiated with the `mk_originative_eqn` function, so
  there's not much point in making this be a continuation in the
  first place.

  This patch removes these continuations in favor of invoking
  `mk_originative_eqn` directly, which is simpler.
* There were several parts of `TcDeriv` that took different code
  paths if compiling an `.hs-boot` file. But this is silly, because
  ever since 101a8c770b9d3abd57ff289bffea3d838cf25c80 we simply error
  eagerly whenever attempting to derive any instances in an
  `.hs-boot` file.

  This patch removes all of the unnecessary `.hs-boot` code paths,
  leaving only one (which errors out).
* Remove various error continuation arguments from `mk_eqn_stock`
  and related functions.

1 files changed, 52 insertions, 79 deletions

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index d74b38c9fd..5e68f2e587 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -99,10 +99,6 @@ data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])
         --                  by the programmer; it is ds_theta
         -- See Note [Inferring the instance context] in TcDerivInfer
 
-earlyDSLoc :: EarlyDerivSpec -> SrcSpan
-earlyDSLoc (InferTheta spec) = ds_loc spec
-earlyDSLoc (GivenTheta spec) = ds_loc spec
-
 splitEarlyDerivSpec :: [EarlyDerivSpec]
                     -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
 splitEarlyDerivSpec [] = ([],[])
@@ -216,13 +212,10 @@ tcDeriving  :: [DerivInfo]       -- All `deriving` clauses
 tcDeriving deriv_infos deriv_decls
   = recoverM (do { g <- getGblEnv
                  ; return (g, emptyBag, emptyValBindsOut)}) $
-    do  {       -- Fish the "deriving"-related information out of the TcEnv
-                -- And make the necessary "equations".
-          is_boot <- tcIsHsBootOrSig
-        ; traceTc "tcDeriving" (ppr is_boot)
-
-        ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
-        ; traceTc "tcDeriving 1" (ppr early_specs)
+    do  { -- Fish the "deriving"-related information out of the TcEnv
+          -- And make the necessary "equations".
+          early_specs <- makeDerivSpecs deriv_infos deriv_decls
+        ; traceTc "tcDeriving" (ppr early_specs)
 
         ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
         ; insts1 <- mapM genInst given_specs
@@ -260,8 +253,7 @@ tcDeriving deriv_infos deriv_decls
         ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs
         ; let inst_infos = inst_infos1 ++ inst_infos2
 
-        ; (inst_info, rn_binds, rn_dus) <-
-            renameDeriv is_boot inst_infos binds
+        ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds
 
         ; unless (isEmptyBag inst_info) $
              liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
@@ -297,19 +289,10 @@ pprRepTy fi@(FamInst { fi_tys = lhs })
       equals <+> ppr rhs
   where rhs = famInstRHS fi
 
-renameDeriv :: Bool
-            -> [InstInfo GhcPs]
+renameDeriv :: [InstInfo GhcPs]
             -> Bag (LHsBind GhcPs, LSig GhcPs)
             -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-renameDeriv is_boot inst_infos bagBinds
-  | is_boot     -- If we are compiling a hs-boot file, don't generate any derived bindings
-                -- The inst-info bindings will all be empty, but it's easier to
-                -- just use rn_inst_info to change the type appropriately
-  = do  { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
-        ; return ( listToBag rn_inst_infos
-                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
-
-  | otherwise
+renameDeriv inst_infos bagBinds
   = discardWarnings $
     -- Discard warnings about unused bindings etc
     setXOptM LangExt.EmptyCase $
@@ -489,11 +472,10 @@ in derived code.
 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
 -}
 
-makeDerivSpecs :: Bool
-               -> [DerivInfo]
+makeDerivSpecs :: [DerivInfo]
                -> [LDerivDecl GhcRn]
                -> TcM [EarlyDerivSpec]
-makeDerivSpecs is_boot deriv_infos deriv_decls
+makeDerivSpecs deriv_infos deriv_decls
   = do  { eqns1 <- sequenceA
                      [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt
                      | DerivInfo { di_rep_tc = rep_tc
@@ -505,17 +487,7 @@ makeDerivSpecs is_boot deriv_infos deriv_decls
                          <- clauses
                      ]
         ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
-        ; let eqns = concat eqns1 ++ catMaybes eqns2
-
-        ; if is_boot then   -- No 'deriving' at all in hs-boot files
-              do { unless (null eqns) (add_deriv_err (head eqns))
-                 ; return [] }
-          else return eqns }
-  where
-    add_deriv_err eqn
-       = setSrcSpan (earlyDSLoc eqn) $
-         addErr (hang (text "Deriving not permitted in hs-boot file")
-                    2 (text "Use an instance declaration instead"))
+        ; return $ concat eqns1 ++ catMaybes eqns2 }
 
 ------------------------------------------------------------------
 -- | Process the derived classes in a single @deriving@ clause.
@@ -1336,17 +1308,15 @@ See Note [Eta reduction for data families] in FamInstEnv
 mkDataTypeEqn :: DerivM EarlyDerivSpec
 mkDataTypeEqn
   = do mb_strat <- asks denv_strat
-       let bale_out msg = do err <- derivingThingErrM False msg
-                             lift $ failWithTc err
        case mb_strat of
-         Just StockStrategy    -> mk_eqn_stock    mk_originative_eqn bale_out
-         Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out
+         Just StockStrategy    -> mk_eqn_stock
+         Just AnyclassStrategy -> mk_eqn_anyclass
          Just (ViaStrategy ty) -> mk_eqn_via ty
          -- GeneralizedNewtypeDeriving makes no sense for non-newtypes
-         Just NewtypeStrategy  -> bale_out gndNonNewtypeErr
+         Just NewtypeStrategy  -> derivingThingFailWith False gndNonNewtypeErr
          -- Lacking a user-requested deriving strategy, we will try to pick
          -- between the stock or anyclass strategies
-         Nothing -> mk_eqn_no_mechanism mk_originative_eqn bale_out
+         Nothing               -> mk_eqn_no_mechanism
 
 -- Derive an instance by way of an originative deriving strategy
 -- (stock or anyclass).
@@ -1460,9 +1430,7 @@ mk_coerce_based_eqn mk_mechanism coerced_ty
        lift $ traceTc "newtype deriving:" $
          ppr tycon <+> ppr (rep_tys coerced_ty) <+> ppr inferred_thetas
        let mechanism = mk_mechanism coerced_ty
-           bale_out msg = do err <- derivingThingErrMechanism mechanism msg
-                             lift $ failWithTc err
-       atf_coerce_based_error_checks cls bale_out
+       atf_coerce_based_error_checks mechanism cls
        doDerivInstErrorChecks1 mechanism
        dfun_name <- lift $ newDFunName' cls tycon
        loc       <- lift getSrcSpanM
@@ -1491,11 +1459,13 @@ mk_coerce_based_eqn mk_mechanism coerced_ty
 --
 -- See Note [GND and associated type families]
 atf_coerce_based_error_checks
-  :: Class
-  -> (SDoc -> DerivM ())
-  -> DerivM ()
-atf_coerce_based_error_checks cls bale_out
-  = let cls_tyvars = classTyVars cls
+  :: DerivSpecMechanism
+  -> Class -> DerivM ()
+atf_coerce_based_error_checks mechanism cls
+  = let bale_out msg = do err <- derivingThingErrMechanism mechanism msg
+                          lift $ failWithTc err
+
+        cls_tyvars = classTyVars cls
 
         ats_look_sensible
            =  -- Check (a) from Note [GND and associated type families]
@@ -1540,10 +1510,8 @@ atf_coerce_based_error_checks cls bale_out
            <+> text "in a kind, which is not (yet) allowed")
     in unless ats_look_sensible $ bale_out cant_derive_err
 
-mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
-             -> (SDoc -> DerivM EarlyDerivSpec)
-             -> DerivM EarlyDerivSpec
-mk_eqn_stock go_for_it bale_out
+mk_eqn_stock :: DerivM EarlyDerivSpec
+mk_eqn_stock
   = do DerivEnv { denv_tc      = tc
                 , denv_rep_tc  = rep_tc
                 , denv_cls     = cls
@@ -1552,18 +1520,16 @@ mk_eqn_stock go_for_it bale_out
        dflags <- getDynFlags
        case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
                                            tc rep_tc of
-         CanDeriveStock gen_fn -> go_for_it $ DerivSpecStock gen_fn
-         StockClassError msg   -> bale_out msg
-         _                     -> bale_out (nonStdErr cls)
-
-mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
-                -> (SDoc -> DerivM EarlyDerivSpec)
-                -> DerivM EarlyDerivSpec
-mk_eqn_anyclass go_for_it bale_out
+         CanDeriveStock gen_fn -> mk_originative_eqn $ DerivSpecStock gen_fn
+         StockClassError msg   -> derivingThingFailWith False msg
+         _                     -> derivingThingFailWith False (nonStdErr cls)
+
+mk_eqn_anyclass :: DerivM EarlyDerivSpec
+mk_eqn_anyclass
   = do dflags <- getDynFlags
        case canDeriveAnyClass dflags of
-         IsValid      -> go_for_it DerivSpecAnyClass
-         NotValid msg -> bale_out msg
+         IsValid      -> mk_originative_eqn DerivSpecAnyClass
+         NotValid msg -> derivingThingFailWith False msg
 
 mk_eqn_newtype :: Type -- The newtype's representation type
                -> DerivM EarlyDerivSpec
@@ -1573,10 +1539,8 @@ mk_eqn_via :: Type -- The @via@ type
            -> DerivM EarlyDerivSpec
 mk_eqn_via = mk_coerce_based_eqn DerivSpecVia
 
-mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
-                    -> (SDoc -> DerivM EarlyDerivSpec)
-                    -> DerivM EarlyDerivSpec
-mk_eqn_no_mechanism go_for_it bale_out
+mk_eqn_no_mechanism :: DerivM EarlyDerivSpec
+mk_eqn_no_mechanism
   = do DerivEnv { denv_tc      = tc
                 , denv_rep_tc  = rep_tc
                 , denv_cls     = cls
@@ -1597,10 +1561,10 @@ mk_eqn_no_mechanism go_for_it bale_out
                                            tc rep_tc of
            -- NB: pass the *representation* tycon to
            -- checkOriginativeSideConditions
-           NonDerivableClass   msg -> bale_out (dac_error msg)
-           StockClassError msg     -> bale_out msg
-           CanDeriveStock gen_fn   -> go_for_it $ DerivSpecStock gen_fn
-           CanDeriveAnyClass       -> go_for_it DerivSpecAnyClass
+           NonDerivableClass   msg -> derivingThingFailWith False (dac_error msg)
+           StockClassError msg     -> derivingThingFailWith False msg
+           CanDeriveStock gen_fn   -> mk_originative_eqn $ DerivSpecStock gen_fn
+           CanDeriveAnyClass       -> mk_originative_eqn DerivSpecAnyClass
 
 {-
 ************************************************************************
@@ -1625,9 +1589,8 @@ mkNewTypeEqn
 
        let newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags
            deriveAnyClass    = xopt LangExt.DeriveAnyClass             dflags
-           bale_out        = bale_out' newtype_deriving
-           bale_out' b msg = do err <- derivingThingErrM b msg
-                                lift $ failWithTc err
+
+           bale_out = derivingThingFailWith newtype_deriving
 
            non_std     = nonStdErr cls
            suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's"
@@ -1705,8 +1668,8 @@ mkNewTypeEqn
 
        MASSERT( cls_tys `lengthIs` (classArity cls - 1) )
        case mb_strat of
-         Just StockStrategy    -> mk_eqn_stock    mk_originative_eqn bale_out
-         Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out
+         Just StockStrategy    -> mk_eqn_stock
+         Just AnyclassStrategy -> mk_eqn_anyclass
          Just NewtypeStrategy  ->
            -- Since the user explicitly asked for GeneralizedNewtypeDeriving,
            -- we don't need to perform all of the checks we normally would,
@@ -2094,6 +2057,16 @@ doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism
     gen_inst_err = text "Generic instances can only be derived in"
                <+> text "Safe Haskell using the stock strategy."
 
+derivingThingFailWith :: Bool -- If True, add a snippet about how not even
+                              -- GeneralizedNewtypeDeriving would make this
+                              -- declaration work. This only kicks in when
+                              -- an explicit deriving strategy is not given.
+                      -> SDoc -- The error message
+                      -> DerivM a
+derivingThingFailWith newtype_deriving msg = do
+  err <- derivingThingErrM newtype_deriving msg
+  lift $ failWithTc err
+
 genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
               -> TyCon -> [Type] -> [TyVar]
               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])