Scrub various partiality involving empty lists.

Avoids some uses of `head` and `tail`, and some panics when an argument is null.

15 files changed, 64 insertions, 64 deletions

diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs
index d8b1e43aa0..47930b2e99 100644
--- a/compiler/GHC/Cmm/Node.hs
+++ b/compiler/GHC/Cmm/Node.hs
@@ -45,6 +45,7 @@ import GHC.Cmm.Dataflow.Block
 import GHC.Cmm.Dataflow.Graph
 import GHC.Cmm.Dataflow.Collections
 import GHC.Cmm.Dataflow.Label
+import Data.Foldable (toList)
 import Data.Functor.Classes (liftCompare)
 import Data.Maybe
 import Data.List (tails,sortBy)
@@ -247,7 +248,7 @@ pprNode platform node = pp_node <+> pp_debug
             (cases, mbdef) = switchTargetsFallThrough ids
             ppCase (is,l) = hsep
                             [ text "case"
-                            , commafy $ map integer is
+                            , commafy $ toList $ fmap integer is
                             , text ": goto"
                             , ppr l <> semi
                             ]
diff --git a/compiler/GHC/Cmm/Switch.hs b/compiler/GHC/Cmm/Switch.hs
index 233b95ff48..b674ee0697 100644
--- a/compiler/GHC/Cmm/Switch.hs
+++ b/compiler/GHC/Cmm/Switch.hs
@@ -12,7 +12,7 @@ module GHC.Cmm.Switch (
      createSwitchPlan,
   ) where
 
-import GHC.Prelude
+import GHC.Prelude hiding (head)
 
 import GHC.Utils.Outputable
 import GHC.Driver.Backend
@@ -20,7 +20,7 @@ import GHC.Utils.Panic
 import GHC.Cmm.Dataflow.Label (Label)
 
 import Data.Maybe
-import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty (..), groupWith, head)
 import qualified Data.Map as M
 
 -- Note [Cmm Switches, the general plan]
@@ -200,11 +200,11 @@ switchTargetsToList (SwitchTargets _ _ mbdef branches)
 
 -- | Groups cases with equal targets, suitable for pretty-printing to a
 -- c-like switch statement with fall-through semantics.
-switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label)
+switchTargetsFallThrough :: SwitchTargets -> ([(NonEmpty Integer, Label)], Maybe Label)
 switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)
   where
-    groups = map (\xs -> (map fst (NE.toList xs), snd (NE.head xs))) $
-             NE.groupWith snd $
+    groups = fmap (\xs -> (fmap fst xs, snd (head xs))) $
+             groupWith snd $
              M.toList branches
 
 -- | Custom equality helper, needed for "GHC.Cmm.CommonBlockElim"
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
index 81935780b9..9fed66053a 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -78,7 +78,7 @@ module GHC.CmmToAsm
    )
 where
 
-import GHC.Prelude
+import GHC.Prelude hiding (head)
 
 import qualified GHC.CmmToAsm.X86   as X86
 import qualified GHC.CmmToAsm.PPC   as PPC
@@ -140,7 +140,7 @@ import GHC.Data.Stream (Stream)
 import qualified GHC.Data.Stream as Stream
 
 import Data.List (sortBy)
-import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (groupAllWith, head)
 import Data.Maybe
 import Data.Ord         ( comparing )
 import Control.Monad
@@ -776,8 +776,8 @@ makeImportsDoc config imports
                 | needImportedSymbols config
                 = vcat $
                         (pprGotDeclaration config :) $
-                        fmap ( pprImportedSymbol config . fst . NE.head) $
-                        NE.groupAllWith snd $
+                        fmap (pprImportedSymbol config . fst . head) $
+                        groupAllWith snd $
                         map doPpr $
                         imps
                 | otherwise
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index 6e5ac43ca6..44d4657052 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -59,6 +59,7 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import Data.Char
 import Data.List (intersperse)
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.Map (Map)
 import qualified Data.Map as Map
 import GHC.Float
@@ -347,7 +348,7 @@ pprSwitch platform e ids
     rep = typeWidth (cmmExprType platform e)
 
     -- fall through case
-    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
+    caseify (ix:|ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
         where
         do_fallthrough ix =
                  hsep [ text "case" , pprHexVal platform ix rep <> colon ,
@@ -357,8 +358,6 @@ pprSwitch platform e ids
                 hsep [ text "case" , pprHexVal platform ix rep <> colon ,
                        text "goto" , (pprBlockId ident) <> semi ]
 
-    caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"
-
     def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi
         | otherwise       = text "default: __builtin_unreachable();"
 
diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs
index 80a68e76e7..5f585ef866 100644
--- a/compiler/GHC/CmmToLlvm.hs
+++ b/compiler/GHC/CmmToLlvm.hs
@@ -11,7 +11,7 @@ module GHC.CmmToLlvm
    )
 where
 
-import GHC.Prelude
+import GHC.Prelude hiding ( head )
 
 import GHC.Llvm
 import GHC.CmmToLlvm.Base
@@ -37,6 +37,7 @@ import GHC.Utils.Logger
 import qualified GHC.Data.Stream as Stream
 
 import Control.Monad ( when, forM_ )
+import Data.List.NonEmpty ( head )
 import Data.Maybe ( fromMaybe, catMaybes )
 import System.IO
 
@@ -68,7 +69,7 @@ llvmCodeGen logger cfg h cmm_stream
            "System LLVM version: " <> text (llvmVersionStr ver) $$
            "We will try though..."
          let isS390X = platformArch (llvmCgPlatform cfg)  == ArchS390X
-         let major_ver = head . llvmVersionList $ ver
+         let major_ver = head . llvmVersionNE $ ver
          when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $
            "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>
            "You are using LLVM version: " <> text (llvmVersionStr ver)
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 6708922495..2fc6605d9e 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -63,6 +63,8 @@ import GHC.Unit.Module( Module )
 import GHC.Unit.Module.ModGuts
 import GHC.Core.Unfold
 
+import Data.List.NonEmpty ( NonEmpty (..) )
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1201,7 +1203,7 @@ specCase env scrut' case_bndr [Alt con args rhs]
   | -- See Note [Floating dictionaries out of cases]
     interestingDict scrut' (idType case_bndr)
   , not (isDeadBinder case_bndr && null sc_args')
-  = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')
+  = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args')
 
        ; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut'
              scrut_bind     = mkDB (NonRec case_bndr_flt scrut')
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 0a0eae47f0..f4430918e6 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -1200,12 +1200,9 @@ cpeApp top_env expr
           arg_ty' = cpSubstTy env arg_ty
 
       CpeApp (Coercion co)
-        -> rebuild_app' env as (App fun' (Coercion co')) floats ss' rt_ticks req_depth
+        -> rebuild_app' env as (App fun' (Coercion co')) floats (drop 1 ss) rt_ticks req_depth
         where
             co' = cpSubstCo env co
-            ss'
-              | null ss = []
-              | otherwise = tail ss
 
       CpeApp arg -> do
         let (ss1, ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make
diff --git a/compiler/GHC/Data/BooleanFormula.hs b/compiler/GHC/Data/BooleanFormula.hs
index a1ddbd44f1..bedb360875 100644
--- a/compiler/GHC/Data/BooleanFormula.hs
+++ b/compiler/GHC/Data/BooleanFormula.hs
@@ -16,9 +16,10 @@ module GHC.Data.BooleanFormula (
         pprBooleanFormula, pprBooleanFormulaNice
   ) where
 
-import GHC.Prelude
+import GHC.Prelude hiding ( init, last )
 
 import Data.List ( nub, intersperse )
+import Data.List.NonEmpty ( NonEmpty (..), init, last )
 import Data.Data
 
 import GHC.Utils.Monad
@@ -227,7 +228,7 @@ pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0
   pprAnd p = cparen (p > 1) . pprAnd'
   pprAnd' [] = empty
   pprAnd' [x,y] = x <+> text "and" <+> y
-  pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs
+  pprAnd' (x:xs) = fsep (punctuate comma (init (x:|xs))) <> text ", and" <+> last (x:|xs)
   pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs)
 
 instance (OutputableBndr a) => Outputable (BooleanFormula a) where
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index b6645db655..18ab333c08 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -1779,9 +1779,9 @@ getGccSearchDirectory logger dflags key = do
             find :: String -> String -> String
             find r x = let lst = lines x
                            val = filter (r `isPrefixOf`) lst
-                       in if null val
-                             then []
-                             else case break (=='=') (head val) of
+                       in case val of
+                              [] -> []
+                              x:_ -> case break (=='=') x of
                                      (_ , [])    -> []
                                      (_, (_:xs)) -> xs
 
diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs
index 79dccfac88..77e2ffd10d 100644
--- a/compiler/GHC/Llvm/Types.hs
+++ b/compiler/GHC/Llvm/Types.hs
@@ -181,7 +181,7 @@ getLitType :: LlvmLit -> LlvmType
 getLitType (LMIntLit   _ t) = t
 getLitType (LMFloatLit _ t) = t
 getLitType (LMVectorLit [])  = panic "getLitType"
-getLitType (LMVectorLit ls)  = LMVector (length ls) (getLitType (head ls))
+getLitType (LMVectorLit ls@(l:_))  = LMVector (length ls) (getLitType l)
 getLitType (LMNullLit    t) = t
 getLitType (LMUndefLit   t) = t
 
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index ced580d743..bac8706d33 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2513,10 +2513,10 @@ mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns
   | isRdrDataCon c
   = do
       let (fs, ps) = partitionEithers fbinds
-      if not (null ps)
-        then addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head ps)) $
-                               PsErrOverloadedRecordDotInvalid
-        else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)
+      case ps of
+          p:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $
+              PsErrOverloadedRecordDotInvalid
+          _ -> return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)
 mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns
   | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $
                                           PsErrDotsInRecordUpdate
@@ -2546,15 +2546,13 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
             [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs'
                       , isQual . rdrNameAmbiguousFieldOcc $ lbl
             ]
-      if not $ null qualifiedFields
-        then
-          addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head qualifiedFields)) $
+      case qualifiedFields of
+          qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $
             PsErrOverloadedRecordUpdateNoQualifiedFields
-        else -- This is a RecordDotSyntax update.
-          return RecordUpd {
-            rupd_ext = anns
-           , rupd_expr = exp
-           , rupd_flds = Right (toProjUpdates fbinds) }
+          _ -> return RecordUpd -- This is a RecordDotSyntax update.
+             { rupd_ext = anns
+             , rupd_expr = exp
+             , rupd_flds = Right (toProjUpdates fbinds) }
   where
     toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs]
     toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f })
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index f79beaaad0..d290045f62 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -178,6 +178,8 @@ import qualified GHC.Data.BooleanFormula as BF
 
 import Data.Functor.Classes ( liftEq )
 import Data.List ( sortBy, sort )
+import Data.List.NonEmpty ( NonEmpty (..) )
+import qualified Data.List.NonEmpty as NE
 import Data.Ord
 import Data.Data ( Data )
 import qualified Data.Set as S
@@ -2223,10 +2225,8 @@ type Plan = TcM PlanResult
 
 -- | Try the plans in order. If one fails (by raising an exn), try the next.
 -- If one succeeds, take it.
-runPlans :: [Plan] -> TcM PlanResult
-runPlans []     = panic "runPlans"
-runPlans [p]    = p
-runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p
+runPlans :: NonEmpty Plan -> Plan
+runPlans = foldr1 (flip tryTcDiscardingErrs)
 
 -- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
 -- GHCi 'environment'.
@@ -2298,30 +2298,31 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
 
               -- See Note [GHCi Plans]
 
-              it_plans = [
+              it_plans =
                     -- Plan A
                     do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
                        ; it_ty <- zonkTcType (idType it_id)
-                       ; when (isUnitTy $ it_ty) failM
-                       ; return stuff },
+                       ; when (isUnitTy it_ty) failM
+                       ; return stuff } :|
 
                         -- Plan B; a naked bind statement
-                    tcGhciStmts [bind_stmt],
+                  [ tcGhciStmts [bind_stmt]
 
                         -- Plan C; check that the let-binding is typeable all by itself.
                         -- If not, fail; if so, try to print it.
                         -- The two-step process avoids getting two errors: one from
                         -- the expression itself, and one from the 'print it' part
                         -- This two-step story is very clunky, alas
-                    do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
+                  , do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
                                 --- checkNoErrs defeats the error recovery of let-bindings
                        ; tcGhciStmts [let_stmt, print_it] } ]
 
               -- Plans where we don't bind "it"
-              no_it_plans = [
-                    tcGhciStmts [no_it_a] ,
-                    tcGhciStmts [no_it_b] ,
-                    tcGhciStmts [no_it_c] ]
+              no_it_plans =
+                tcGhciStmts [no_it_a] :|
+                tcGhciStmts [no_it_b] :
+                tcGhciStmts [no_it_c] :
+                []
 
         ; generate_it <- goptM Opt_NoIt
 
@@ -2413,13 +2414,13 @@ tcUserStmt rdr_stmt@(L loc _)
        ; let print_result_plan
                | opt_pr_flag                         -- The flag says "print result"
                , [v] <- collectLStmtBinders CollNoDictBinders gi_stmt  -- One binder
-               = [mk_print_result_plan gi_stmt v]
-               | otherwise = []
+               = Just $ mk_print_result_plan gi_stmt v
+               | otherwise = Nothing
 
         -- The plans are:
         --      [stmt; print v]         if one binder and not v::()
         --      [stmt]                  otherwise
-       ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])
+       ; plan <- runPlans $ maybe id (NE.<|) print_result_plan $ NE.singleton $ tcGhciStmts [gi_stmt]
        ; return (plan, fix_env) }
   where
     mk_print_result_plan stmt v
diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs
index e131415fa3..feecb3bfc3 100644
--- a/compiler/GHC/Types/Name/Reader.hs
+++ b/compiler/GHC/Types/Name/Reader.hs
@@ -825,12 +825,12 @@ pprGlobalRdrEnv locals_only env
     remove_locals gres | locals_only = filter isLocalGRE gres
                        | otherwise   = gres
     pp []   = empty
-    pp gres = hang (ppr occ
+    pp gres@(gre:_) = hang (ppr occ
                      <+> parens (text "unique" <+> ppr (getUnique occ))
                      <> colon)
                  2 (vcat (map ppr gres))
       where
-        occ = nameOccName (greMangledName (head gres))
+        occ = nameOccName (greMangledName gre)
 
 lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt]
 lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of
diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index cea7537773..403216954f 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -699,8 +699,8 @@ getUnitDbRefs cfg = do
   let base_conf_refs = case e_pkg_path of
         Left _ -> system_conf_refs
         Right path
-         | not (null path) && isSearchPathSeparator (last path)
-         -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs
+         | Just (xs, x) <- snocView path, isSearchPathSeparator x
+         -> map PkgDbPath (splitSearchPath xs) ++ system_conf_refs
          | otherwise
          -> map PkgDbPath (splitSearchPath path)
 
diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs
index 49f85d7d6a..307476b395 100644
--- a/compiler/GHC/Utils/Misc.hs
+++ b/compiler/GHC/Utils/Misc.hs
@@ -124,7 +124,7 @@ module GHC.Utils.Misc (
         HasDebugCallStack,
     ) where
 
-import GHC.Prelude
+import GHC.Prelude hiding ( last )
 
 import GHC.Utils.Exception
 import GHC.Utils.Panic.Plain
@@ -133,7 +133,7 @@ import GHC.Utils.Fingerprint
 
 import Data.Data
 import qualified Data.List as List
-import Data.List.NonEmpty  ( NonEmpty(..) )
+import Data.List.NonEmpty  ( NonEmpty(..), last )
 
 import GHC.Exts
 import GHC.Stack (HasCallStack)
@@ -750,7 +750,7 @@ last2 = List.foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError)
 
 lastMaybe :: [a] -> Maybe a
 lastMaybe [] = Nothing
-lastMaybe xs = Just $ last xs
+lastMaybe (x:xs) = Just $ last (x:|xs)
 
 -- | @onJust x m f@ applies f to the value inside the Just or returns the default.
 onJust :: b -> Maybe a -> (a->b) -> b
@@ -1293,9 +1293,9 @@ withAtomicRename targetFile f = do
 -- string is returned in the first component (and the second one is just
 -- empty).
 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
-splitLongestPrefix str pred
-  | null r_pre = (str,           [])
-  | otherwise  = (reverse (tail r_pre), reverse r_suf)
+splitLongestPrefix str pred = case r_pre of
+    [] -> (str,           [])
+    _:r_pre' -> (reverse r_pre', reverse r_suf)
                            -- 'tail' drops the char satisfying 'pred'
   where (r_suf, r_pre) = break pred (reverse str)