Scrub various partiality involving lists (again).

Lets us avoid some use of `head` and `tail`, and some panics.

6 files changed, 29 insertions, 26 deletions

diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 49d97e81e1..e51eee9841 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1403,7 +1403,6 @@ gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc})
   where
     data_cons  = tyConDataCons rep_tc
     n_cons     = length data_cons
-    one_constr = n_cons == 1
 
         ------------ gfoldl
     gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons)
@@ -1420,11 +1419,11 @@ gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc})
         ------------ gunfold
     gunfold_bind = mkSimpleGeneratedFunBind loc
                      gunfold_RDR
-                     [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]
+                     [k_Pat, z_Pat, if n_cons == 1 then nlWildPat else c_Pat]
                      gunfold_rhs
 
     gunfold_rhs
-        | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
+        | [con] <- data_cons = mk_unfold_rhs con   -- No need for case
         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
                                 (map gunfold_alt data_cons)
 
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index b47d6cd632..d35bac99a4 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -21,7 +21,7 @@ module GHC.Tc.Deriv.Generics
    )
 where
 
-import GHC.Prelude
+import GHC.Prelude hiding (head, init, last, tail)
 
 import GHC.Hs
 import GHC.Core.Type
@@ -62,6 +62,9 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
 import Control.Monad (mplus)
 import Data.List (zip4, partition)
+import qualified Data.List as Partial (last)
+import Data.List.NonEmpty (nonEmpty)
+import qualified Data.List.NonEmpty as NE
 import Data.Maybe (isJust)
 
 {-
@@ -291,9 +294,9 @@ canDoGenerics1 dit@(DerivInstTys{dit_rep_tc = rep_tc}) =
       , ft_var = caseVar, ft_co_var = caseVar
 
       -- (component_0,component_1,...,component_n)
-      , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)
-                                  then bmbad con
-                                  else foldr bmplus bmzero components
+      , ft_tup = \_ components -> case nonEmpty components of
+            Just components' | any _ccdg1_hasParam (NE.init components') -> bmbad con
+            _ -> foldr bmplus bmzero components
 
       -- (dom -> rng), where the head of ty is not a tuple tycon
       , ft_fun = \dom rng -> -- cf #8516
@@ -344,7 +347,7 @@ gk2gkDC Gen1 dc tc_args = Gen1_DC $ assert (isTyVarTy last_dc_inst_univ)
   where
     dc_inst_univs = dataConInstUnivs dc tc_args
     last_dc_inst_univ = assert (not (null dc_inst_univs)) $
-                        last dc_inst_univs
+                        Partial.last dc_inst_univs
 
 
 -- Bindings for the Generic instance
diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs
index 15f2bdd440..9027337b83 100644
--- a/compiler/GHC/Tc/Gen/Default.hs
+++ b/compiler/GHC/Tc/Gen/Default.hs
@@ -26,9 +26,10 @@ import GHC.Builtin.Names
 import GHC.Types.Error
 import GHC.Types.SrcLoc
 import GHC.Utils.Outputable
-import GHC.Utils.Panic
 import qualified GHC.LanguageExtensions as LangExt
 
+import Data.List.NonEmpty ( NonEmpty (..) )
+
 tcDefaults :: [LDefaultDecl GhcRn]
            -> TcM (Maybe [Type])    -- Defaulting types to heave
                                     -- into Tc monad for later use
@@ -67,9 +68,9 @@ tcDefaults [L locn (DefaultDecl _ mono_tys)]
 
         ; return (Just tau_tys) }
 
-tcDefaults decls@(L locn (DefaultDecl _ _) : _)
+tcDefaults (decl@(L locn (DefaultDecl _ _)) : decls)
   = setSrcSpan (locA locn) $
-    failWithTc (dupDefaultDeclErr decls)
+    failWithTc (dupDefaultDeclErr (decl:|decls))
 
 
 tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type
@@ -103,7 +104,6 @@ check_instance ty cls
 defaultDeclCtxt :: SDoc
 defaultDeclCtxt = text "When checking the types in a default declaration"
 
-dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> TcRnMessage
-dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)
+dupDefaultDeclErr :: NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
+dupDefaultDeclErr (L _ (DefaultDecl _ _) :| dup_things)
   = TcRnMultipleDefaultDeclarations dup_things
-dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index b649891d04..19ea11f2d4 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -75,7 +75,7 @@ module GHC.Tc.Gen.HsType (
         funAppCtxt, addTyConFlavCtxt
    ) where
 
-import GHC.Prelude
+import GHC.Prelude hiding ( head, init, last, tail )
 
 import GHC.Hs
 import GHC.Rename.Utils
@@ -130,7 +130,8 @@ import GHC.Data.Maybe
 import GHC.Data.Bag( unitBag )
 
 import Data.Function ( on )
-import Data.List.NonEmpty as NE( NonEmpty(..), nubBy )
+import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
+import qualified Data.List.NonEmpty as NE
 import Data.List ( find, mapAccumL )
 import Control.Monad
 import Data.Tuple( swap )
@@ -3169,19 +3170,19 @@ tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed
 -- Push level, capture constraints, and emit an implication constraint.
 -- The implication constraint has a ForAllSkol ic_info,
 --   so that it is subject to a telescope test.
-tcExplicitTKBndrsX skol_mode bndrs thing_inside
-  | null bndrs
-  = do { res <- thing_inside
+tcExplicitTKBndrsX skol_mode bndrs thing_inside = case nonEmpty bndrs of
+    Nothing -> do
+       { res <- thing_inside
        ; return ([], res) }
 
-  | otherwise
-  = do { (tclvl, wanted, (skol_tvs, res))
+    Just bndrs1 -> do
+       { (tclvl, wanted, (skol_tvs, res))
              <- pushLevelAndCaptureConstraints $
                 bindExplicitTKBndrsX skol_mode bndrs $
                 thing_inside
 
        -- Set up SkolemInfo for telescope test
-       ; let bndr_1 = head bndrs; bndr_n = last bndrs
+       ; let bndr_1 = NE.head bndrs1; bndr_n = NE.last bndrs1
        ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn  (unLoc <$> bndrs)))
          -- Notice that we use ForAllSkol here, ignoring the enclosing
          -- skol_info unlike tcImplicitTKBndrs, because the bad-telescope
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index d290045f62..68728cd3d7 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -891,9 +891,9 @@ checkHiBootIface'
       | name `elem` boot_dfun_names = return ()
 
         -- Check that the actual module exports the same thing
-      | not (null missing_names)
-      = addErrAt (nameSrcSpan (head missing_names))
-                 (missingBootThing True (head missing_names) "exported by")
+      | missing_name:_ <- missing_names
+      = addErrAt (nameSrcSpan missing_name)
+                 (missingBootThing True missing_name "exported by")
 
         -- If the boot module does not *define* the thing, we are done
         -- (it simply re-exports it, and names match, so nothing further to do)
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 31da54dca7..ac5e336e65 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -4669,7 +4669,7 @@ checkValidClass cls
         -- Test case: rep-poly/RepPolyClassMethod.
 
         ; unless constrained_class_methods $
-          mapM_ check_constraint (tail (cls_pred:op_theta))
+          mapM_ check_constraint op_theta
 
         ; check_dm ctxt sel_id cls_pred tau2 dm
         }