Avoid Data.List.group; prefer Data.List.NonEmpty.group

This allows to avoid further partiality, e. g., map head . group is
replaced by map NE.head . NE.group, and there are less panic calls.

14 files changed, 73 insertions, 75 deletions

diff --git a/compiler/GHC/Cmm/Switch.hs b/compiler/GHC/Cmm/Switch.hs
index f03eaac70f..233b95ff48 100644
--- a/compiler/GHC/Cmm/Switch.hs
+++ b/compiler/GHC/Cmm/Switch.hs
@@ -20,8 +20,7 @@ import GHC.Utils.Panic
 import GHC.Cmm.Dataflow.Label (Label)
 
 import Data.Maybe
-import Data.List (groupBy)
-import Data.Function (on)
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Map as M
 
 -- Note [Cmm Switches, the general plan]
@@ -204,8 +203,8 @@ switchTargetsToList (SwitchTargets _ _ mbdef branches)
 switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label)
 switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)
   where
-    groups = map (\xs -> (map fst xs, snd (head xs))) $
-             groupBy ((==) `on` snd) $
+    groups = map (\xs -> (map fst (NE.toList xs), snd (NE.head xs))) $
+             NE.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 8932a48cc6..81935780b9 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -139,7 +139,8 @@ import GHC.Unit
 import GHC.Data.Stream (Stream)
 import qualified GHC.Data.Stream as Stream
 
-import Data.List (sortBy, groupBy)
+import Data.List (sortBy)
+import qualified Data.List.NonEmpty as NE
 import Data.Maybe
 import Data.Ord         ( comparing )
 import Control.Monad
@@ -769,17 +770,14 @@ makeImportsDoc config imports
         -- Generate "symbol stubs" for all external symbols that might
         -- come from a dynamic library.
         dyld_stubs :: [CLabel] -> SDoc
-{-      dyld_stubs imps = vcat $ map pprDyldSymbolStub $
-                                    map head $ group $ sort imps-}
         -- (Hack) sometimes two Labels pretty-print the same, but have
         -- different uniques; so we compare their text versions...
         dyld_stubs imps
                 | needImportedSymbols config
                 = vcat $
                         (pprGotDeclaration config :) $
-                        map ( pprImportedSymbol config . fst . head) $
-                        groupBy (\(_,a) (_,b) -> a == b) $
-                        sortBy (\(_,a) (_,b) -> compare a b) $
+                        fmap ( pprImportedSymbol config . fst . NE.head) $
+                        NE.groupAllWith snd $
                         map doPpr $
                         imps
                 | otherwise
diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
index ad8190270f..d3c8b261b5 100644
--- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
@@ -67,7 +67,7 @@ import GHC.Types.Unique.Supply
 import GHC.Data.Bag
 import GHC.Utils.Monad.State.Strict
 
-import Data.List (mapAccumL, groupBy, partition)
+import Data.List (mapAccumL, partition)
 import Data.Maybe
 import Data.IntSet              (IntSet)
 
@@ -911,13 +911,11 @@ livenessSCCs platform blockmap done
                 -> a -> b
                 -> (a,c)
 
-            iterateUntilUnchanged f eq a b
-                = head $
-                  concatMap tail $
-                  groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
-                  iterate (\(a, _) -> f a b) $
-                  (a, panic "RegLiveness.livenessSCCs")
-
+            iterateUntilUnchanged f eq aa b = go aa
+              where
+                go a = if eq a a' then ac else go a'
+                  where
+                    ac@(a', _) = f a b
 
             linearLiveness
                 :: Instruction instr
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index 18296158e3..d891fd17b3 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -59,7 +59,8 @@ import GHC.Utils.Logger
 
 import Data.Maybe (fromJust)
 import Control.Monad.Trans.State (StateT (..))
-import Data.List (sortBy, groupBy, isPrefixOf)
+import Data.List (isPrefixOf)
+import qualified Data.List.NonEmpty as NE
 import Data.Ord (comparing)
 
 -- ----------------------------------------------------------------------------
@@ -192,7 +193,7 @@ padLiveArgs platform live =
     -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg
     -- all use the same real regs on X86-64 (XMM registers).
     --
-    classes         = groupBy sharesClass fprLive
+    classes         = NE.groupBy sharesClass fprLive
     sharesClass a b = regsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers
     norm x          = CmmGlobal ((fpr_ctor x) 1)             -- get the first register of the family
 
@@ -202,10 +203,10 @@ padLiveArgs platform live =
     -- E.g. sortedRs = [   F2,   XMM4, D5]
     --      output   = [D1,   D3]
     padded      = concatMap padClass classes
-    padClass rs = go sortedRs [1..]
+    padClass rs = go (NE.toList sortedRs) 1
       where
-         sortedRs = sortBy (comparing fpr_num) rs
-         maxr     = last sortedRs
+         sortedRs = NE.sortBy (comparing fpr_num) rs
+         maxr     = NE.last sortedRs
          ctor     = fpr_ctor maxr
 
          go [] _ = []
@@ -216,10 +217,9 @@ padLiveArgs platform live =
                text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <>
                text ") both alive AND mapped to the same real register: " <> ppr real <>
                text ". This isn't currently supported by the LLVM backend."
-         go (c:cs) (f:fs)
-            | fpr_num c == f = go cs fs              -- already covered by a real register
-            | otherwise      = ctor f : go (c:cs) fs -- add padding register
-         go _ _ = undefined -- unreachable
+         go (c:cs) f
+            | fpr_num c == f = go cs f                    -- already covered by a real register
+            | otherwise      = ctor f : go (c:cs) (f + 1) -- add padding register
 
     fpr_ctor :: GlobalReg -> Int -> GlobalReg
     fpr_ctor (FloatReg _)  = FloatReg
diff --git a/compiler/GHC/Core/Opt/Stats.hs b/compiler/GHC/Core/Opt/Stats.hs
index bdf920a8ee..79dfffbcfb 100644
--- a/compiler/GHC/Core/Opt/Stats.hs
+++ b/compiler/GHC/Core/Opt/Stats.hs
@@ -22,12 +22,14 @@ import GHC.Utils.Outputable as Outputable
 
 import GHC.Data.FastString
 
-import Data.List (groupBy, sortBy)
+import Data.List (sortOn)
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
 import Data.Ord
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.Map.Strict as MapStrict
-import GHC.Utils.Panic (throwGhcException, GhcException(..), panic)
+import GHC.Utils.Panic (throwGhcException, GhcException(..))
 
 getVerboseSimplStats :: (Bool -> SDoc) -> SDoc
 getVerboseSimplStats = getPprDebug          -- For now, anyway
@@ -205,18 +207,16 @@ pprTickCounts :: Map Tick Int -> SDoc
 pprTickCounts counts
   = vcat (map pprTickGroup groups)
   where
-    groups :: [[(Tick,Int)]]    -- Each group shares a common tag
-                                -- toList returns common tags adjacent
-    groups = groupBy same_tag (Map.toList counts)
-    same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2
-
-pprTickGroup :: [(Tick, Int)] -> SDoc
-pprTickGroup group@((tick1,_):_)
-  = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
+    groups :: [NonEmpty (Tick, Int)] -- Each group shares a common tag
+                                     -- toList returns common tags adjacent
+    groups = NE.groupWith (tickToTag . fst) (Map.toList counts)
+
+pprTickGroup :: NonEmpty (Tick, Int) -> SDoc
+pprTickGroup group@((tick1,_) :| _)
+  = hang (int (sum (fmap snd group)) <+> text (tickString tick1))
        2 (vcat [ int n <+> pprTickCts tick
                                     -- flip as we want largest first
-               | (tick,n) <- sortBy (flip (comparing snd)) group])
-pprTickGroup [] = panic "pprTickGroup"
+               | (tick,n) <- sortOn (Down . snd) (NE.toList group)])
 
 data Tick  -- See Note [Which transformations are innocuous]
   = PreInlineUnconditionally    Id
diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs
index 1e56808278..64dff69c1a 100644
--- a/compiler/GHC/HsToCore/Match/Constructor.hs
+++ b/compiler/GHC/HsToCore/Match/Constructor.hs
@@ -36,8 +36,8 @@ import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import Control.Monad(liftM)
-import Data.List (groupBy)
 import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
 
 {-
 We are confronted with the first column of patterns in a set of
@@ -143,13 +143,13 @@ matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single construct
         -- and returns the types of the *value* args, which is what we want
 
               match_group :: [Id]
-                          -> [(ConArgPats, EquationInfo)] -> DsM (MatchResult CoreExpr)
+                          -> NonEmpty (ConArgPats, EquationInfo)
+                          -> DsM (MatchResult CoreExpr)
               -- All members of the group have compatible ConArgPats
               match_group arg_vars arg_eqn_prs
-                = assert (notNull arg_eqn_prs) $
-                  do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
+                = do { (wraps, eqns') <- liftM NE.unzip (mapM shift arg_eqn_prs)
                      ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
-                     ; match_result <- match (group_arg_vars ++ vars) ty eqns'
+                     ; match_result <- match (group_arg_vars ++ vars) ty (NE.toList eqns')
                      ; return $ foldr1 (.) wraps <$> match_result
                      }
 
@@ -184,9 +184,9 @@ matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single construct
                 -- suggestions for the new variables
 
         -- Divide into sub-groups; see Note [Record patterns]
-        ; let groups :: [[(ConArgPats, EquationInfo)]]
-              groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn)
-                                               | eqn <- eqn1:eqns ]
+        ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfo))
+              groups = NE.groupBy1 compatible_pats
+                     $ fmap (\eqn -> (pat_args (firstPat eqn), eqn)) (eqn1 :| eqns)
 
         ; match_results <- mapM (match_group arg_vars) groups
 
@@ -210,8 +210,8 @@ matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single construct
 
     -- Choose the right arg_vars in the right order for this group
     -- Note [Record patterns]
-    select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id]
-    select_arg_vars arg_vars ((arg_pats, _) : _)
+    select_arg_vars :: [Id] -> NonEmpty (ConArgPats, EquationInfo) -> [Id]
+    select_arg_vars arg_vars ((arg_pats, _) :| _)
       | RecCon flds <- arg_pats
       , let rpats = rec_flds flds
       , not (null rpats)     -- Treated specially; cf conArgPats
@@ -224,7 +224,6 @@ matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single construct
         fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
         lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
                                             (idName (hsRecFieldId rpat))
-    select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
 
 -----------------
 compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 8c4e6c6ad7..6e1418a130 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -80,7 +80,7 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
-import Data.List (sortBy, nubBy, partition)
+import Data.List (nubBy, partition)
 import qualified Data.List.NonEmpty as NE
 import Data.List.NonEmpty (NonEmpty(..))
 import Control.Monad
@@ -443,7 +443,7 @@ rnImplicitTvBndrs :: HsDocContext
                   -> ([Name] -> RnM (a, FreeVars))
                   -> RnM (a, FreeVars)
 rnImplicitTvBndrs ctx mb_assoc implicit_vs_with_dups thing_inside
-  = do { implicit_vs <- forM (NE.groupBy eqLocated $ sortBy cmpLocated $ implicit_vs_with_dups) $ \case
+  = do { implicit_vs <- forM (NE.groupAllWith unLoc $ implicit_vs_with_dups) $ \case
            (x :| []) -> return x
            (x :| _) -> do
              let msg = mkTcRnUnknownMessage $ mkPlainError noHints $
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index edc0af5f52..ca710744de 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -93,7 +93,9 @@ import Data.Either      ( partitionEithers )
 import Data.Map         ( Map )
 import qualified Data.Map as Map
 import Data.Ord         ( comparing )
-import Data.List        ( partition, (\\), find, sortBy, groupBy, sortOn )
+import Data.List        ( partition, (\\), find, sortBy )
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
 import Data.Function    ( on )
 import qualified Data.Set as S
 import Data.Foldable    ( toList )
@@ -1968,7 +1970,7 @@ getMinimalImports = fmap combine . mapM mk_minimal
           all_non_overloaded = all (not . flIsOverloaded)
 
     combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn]
-    combine = map merge . groupBy ((==) `on` getKey) . sortOn getKey
+    combine = map merge . NE.groupAllWith getKey
 
     getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName)
     getKey decl =
@@ -1980,10 +1982,9 @@ getMinimalImports = fmap combine . mapM mk_minimal
         idecl :: ImportDecl GhcRn
         idecl = unLoc decl
 
-    merge :: [LImportDecl GhcRn] -> LImportDecl GhcRn
-    merge []                     = error "getMinimalImports: unexpected empty list"
-    merge decls@((L l decl) : _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) })
-      where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) decls
+    merge :: NonEmpty (LImportDecl GhcRn) -> LImportDecl GhcRn
+    merge decls@((L l decl) :| _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) })
+      where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) $ NE.toList decls
 
 
 printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM ()
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index c5c5616024..c2a680b3d4 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -88,7 +88,8 @@ import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUn
 import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
 import Data.Function
-import Data.List (partition, sortBy, groupBy, intersect)
+import Data.List (partition, sortBy, intersect)
+import qualified Data.List.NonEmpty as NE
 
 import GHC.Data.Bag ( unitBag )
 
@@ -1699,7 +1700,7 @@ badFieldsUpd rbinds data_cons
             in
             -- Fields that don't change the membership status of the set
             -- are redundant and can be dropped.
-            map (fst . head) $ groupBy ((==) `on` snd) growingSets
+            map (fst . NE.head) $ NE.groupWith snd growingSets
 
     aMember = assert (not (null members) ) fst (head members)
     (members, nonMembers) = partition (or . snd) membership
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 99826e7144..6cbf4dffb9 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -122,8 +122,9 @@ import qualified Data.ByteString.Char8 as BS
 import Data.Char
 import Data.Function
 import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
-import Data.List ( elemIndices, find, group, intercalate, intersperse,
+import Data.List ( elemIndices, find, intercalate, intersperse,
                    isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Set as S
 import Data.Maybe
 import qualified Data.Map as M
@@ -3699,11 +3700,11 @@ completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
   return (filter (w `isPrefixOf`) opts)
     where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":
                  "prompt-cont-function":"editor":"stop":flagList
-          flagList = map head $ group $ sort allNonDeprecatedFlags
+          flagList = map NE.head $ NE.group $ sort allNonDeprecatedFlags
 
 completeSeti = wrapCompleter flagWordBreakChars $ \w -> do
   return (filter (w `isPrefixOf`) flagList)
-    where flagList = map head $ group $ sort allNonDeprecatedFlags
+    where flagList = map NE.head $ NE.group $ sort allNonDeprecatedFlags
 
 completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
   return (filter (w `isPrefixOf`) opts)
diff --git a/ghc/GHCi/UI/Tags.hs b/ghc/GHCi/UI/Tags.hs
index 410b2c5927..f1d55eab15 100644
--- a/ghc/GHCi/UI/Tags.hs
+++ b/ghc/GHCi/UI/Tags.hs
@@ -29,7 +29,8 @@ import GHC.Driver.Env
 
 import Control.Monad
 import Data.Function
-import Data.List (sort, sortBy, groupBy)
+import Data.List (sort, sortOn)
+import qualified Data.List.NonEmpty as NE
 import Data.Maybe
 import Data.Ord
 import GHC.Driver.Phases
@@ -176,14 +177,13 @@ collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
 
 makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]
 makeTagGroupsWithSrcInfo tagInfos = do
-  let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos
+  let groups = NE.groupAllWith tagFile tagInfos
   mapM addTagSrcInfo groups
 
   where
-    addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")
-    addTagSrcInfo group@(tagInfo:_) = do
+    addTagSrcInfo group@(tagInfo NE.:| _) = do
       file <- readFile $ tagFile tagInfo
-      let sortedGroup = sortBy (comparing tagLine) group
+      let sortedGroup = sortOn tagLine (NE.toList group)
       return $ perFile sortedGroup 1 0 $ lines file
 
     perFile allTags@(tag:tags) cnt pos allLs@(l:ls)
diff --git a/hadrian/src/Rules/Dependencies.hs b/hadrian/src/Rules/Dependencies.hs
index 453c45acad..ebdb7b70d8 100644
--- a/hadrian/src/Rules/Dependencies.hs
+++ b/hadrian/src/Rules/Dependencies.hs
@@ -2,6 +2,7 @@ module Rules.Dependencies (buildPackageDependencies) where
 
 import Data.Bifunctor
 import Data.Function
+import qualified Data.List.NonEmpty as NE
 
 import Base
 import Context
@@ -67,9 +68,8 @@ buildPackageDependencies rs = do
         writeFileChanged deps . unlines
                               . map (\(src, deps) -> unwords $ src : deps)
                               . map (bimap unifyPath (map unifyPath))
-                              . map (bimap head concat . unzip)
-                              . groupBy ((==) `on` fst)
-                              . sortBy (compare `on` fst)
+                              . map (bimap NE.head concat . NE.unzip)
+                              . NE.groupAllWith fst
                               $ parseMakefile mkDeps
 
 
diff --git a/testsuite/tests/lib/integer/integerGmpInternals.hs b/testsuite/tests/lib/integer/integerGmpInternals.hs
index 982e4dcaba..0dbf8dd4e4 100644
--- a/testsuite/tests/lib/integer/integerGmpInternals.hs
+++ b/testsuite/tests/lib/integer/integerGmpInternals.hs
@@ -2,7 +2,7 @@
 
 module Main (main) where
 
-import Data.List (group)
+import qualified Data.List.NonEmpty as NE
 import Data.Bits
 import Data.Word
 import Control.Monad
@@ -40,7 +40,7 @@ main = do
 
     b1024 = roll (map fromIntegral (take 128 [0x80::Int .. ]))
 
-    rle = map (\x -> (length x, head x)) . group
+    rle = map (\x -> (length x, NE.head x)) . NE.group
 
 
     roll :: [Word8] -> Integer
diff --git a/testsuite/tests/numeric/should_run/CarryOverflow.hs b/testsuite/tests/numeric/should_run/CarryOverflow.hs
index bcbcf121bc..d188ca9e38 100644
--- a/testsuite/tests/numeric/should_run/CarryOverflow.hs
+++ b/testsuite/tests/numeric/should_run/CarryOverflow.hs
@@ -5,7 +5,8 @@ import GHC.Exts
 
 import Control.Monad
 import Data.Bits
-import Data.List (sort, group)
+import Data.List (sort)
+import qualified Data.List.NonEmpty as NE
 import System.Exit
 
 allEqual :: Eq a => [a] -> Bool
@@ -13,7 +14,7 @@ allEqual [] = error "allEqual: nothing to compare"
 allEqual (x:xs) = all (== x) xs
 
 testWords :: [Word]
-testWords = map head . group . sort $
+testWords = map NE.head . NE.group . sort $
             concatMap (\w -> [w - 1, w, w + 1]) $
             concatMap (\w -> [w, maxBound - w]) $
             trailingOnes ++ randoms