Commit 13599ae8 authored by Dale Wijnand's avatar Dale Wijnand Committed by Oleg Grenrus

Replace Prelude.head/tail/init/last with NonEmpty

parent 0046cf2d
......@@ -8,7 +8,7 @@ module Distribution.Backpack.ComponentsGraph (
componentCycleMsg
) where
import Prelude (head)
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Package
......@@ -19,6 +19,7 @@ import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.UnqualComponentName
import Distribution.Compat.Graph (Graph, Node(..))
import qualified Distribution.Compat.Graph as Graph
import Distribution.Utils.Generic
import Distribution.Pretty (pretty)
import Text.PrettyPrint
......@@ -94,4 +95,4 @@ componentCycleMsg cnames =
text $ "Components in the package depend on each other in a cyclic way:\n "
++ intercalate " depends on "
[ "'" ++ showComponentName cname ++ "'"
| cname <- cnames ++ [head cnames] ]
| cname <- cnames ++ maybeToList (safeHead cnames) ]
......@@ -64,6 +64,7 @@ module Distribution.Compat.Prelude (
-- * Data.List.NonEmpty
NonEmpty((:|)), foldl1, foldr1,
head, tail, last, init,
-- * Data.Foldable
Foldable, foldMap, foldr,
......@@ -154,7 +155,7 @@ import Data.Char
import Data.List (intercalate, intersperse, isPrefixOf,
isSuffixOf, nub, nubBy, sort, sortBy,
unfoldr)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.List.NonEmpty (NonEmpty((:|)), head, tail, init, last)
import Data.Maybe
import Data.String (IsString (..))
import Data.Int
......
......@@ -34,7 +34,7 @@ module Distribution.PackageDescription.Check (
) where
import Distribution.Compat.Prelude
import Prelude (last, init)
import Prelude ()
import Control.Monad (mapM)
import Data.List (group)
......@@ -56,7 +56,7 @@ import Distribution.Types.CondTree
import Distribution.Types.ExeDependency
import Distribution.Types.LibraryName
import Distribution.Types.UnqualComponentName
import Distribution.Utils.Generic (isAscii)
import Distribution.Utils.Generic (isAscii, safeInit)
import Distribution.Verbosity
import Distribution.Version
import Language.Haskell.Extension
......@@ -1591,8 +1591,8 @@ checkPackageVersions pkg =
boundedAbove :: VersionRange -> Bool
boundedAbove vr = case asVersionIntervals vr of
[] -> True -- this is the inconsistent version range.
intervals -> case last intervals of
[] -> True -- this is the inconsistent version range.
(x:xs) -> case last (x:|xs) of
(_, UpperBound _ _) -> True
(_, NoUpperBound ) -> False
......@@ -2145,7 +2145,7 @@ checkTarPath path
Right (_:_) -> Just noSplit
where
-- drop the '/' between the name and prefix:
remainder = init h : rest
remainder = safeInit h : rest
where
nameMax, prefixMax :: Int
......
......@@ -57,7 +57,7 @@ module Distribution.Simple (
import Control.Exception (try)
import Prelude (head)
import Prelude ()
import Distribution.Compat.Prelude
-- local
......@@ -524,9 +524,9 @@ sanityCheckHookedBuildInfo verbosity
++ "but the package does not have a library."
sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes)
| not (null nonExistant)
| exe1 : _ <- nonExistant
= die' verbosity $ "The buildinfo contains info for an executable called '"
++ prettyShow (head nonExistant) ++ "' but the package does not have a "
++ prettyShow exe1 ++ "' but the package does not have a "
++ "executable with that name."
where
pkgExeNames = nub (map exeName (executables pkg_descr))
......
......@@ -28,8 +28,9 @@ module Distribution.Simple.Build (
writeAutogenFiles,
) where
import Prelude (head, init)
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.Generic
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.ComponentRequestedSpec
......@@ -154,7 +155,9 @@ repl pkg_descr lbi flags suffixes args = do
target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of
-- This seems DEEPLY questionable.
[] -> return (head (allTargetsInBuildOrder' pkg_descr lbi))
[] -> case allTargetsInBuildOrder' pkg_descr lbi of
(target:_) -> return target
[] -> die' verbosity $ "Failed to determine target."
[target] -> return target
_ -> die' verbosity $ "The 'repl' command does not support multiple targets at once."
let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target]
......@@ -180,7 +183,7 @@ repl pkg_descr lbi flags suffixes args = do
componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity
buildComponent verbosity NoFlag
pkg_descr lbi' suffixes comp clbi distPref
| subtarget <- init componentsToBuild ]
| subtarget <- safeInit componentsToBuild ]
-- REPL for target components
let clbi = targetCLBI target
......
......@@ -54,7 +54,7 @@ module Distribution.Simple.Configure
, platformDefines,
) where
import Prelude (head, tail, last)
import qualified Prelude (tail)
import Distribution.Compat.Prelude
import Distribution.Compiler
......@@ -102,6 +102,7 @@ import Distribution.Backpack.DescribeUnitId
import Distribution.Backpack.PreExistingComponent
import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour)
import Distribution.Backpack.Id
import Distribution.Utils.Generic
import Distribution.Utils.LogProgress
import qualified Distribution.Simple.GHC as GHC
......@@ -112,6 +113,7 @@ import qualified Distribution.Simple.HaskellSuite as HaskellSuite
import Control.Exception
( ErrorCall, Exception, evaluate, throw, throwIO, try )
import Control.Monad ( forM, forM_ )
import Data.List.NonEmpty ( nonEmpty )
import Distribution.Compat.Binary ( decodeOrFailIO, encode )
import Distribution.Compat.Directory ( listDirectory )
import Data.ByteString.Lazy ( ByteString )
......@@ -1313,18 +1315,21 @@ selectDependency pkgid internalIndex installedIndex requiredDepsMap
-- It's an external package, normal situation
do_external_external =
case PackageIndex.lookupDependency installedIndex dep_pkgname vr of
[] -> Left (DependencyNotExists dep_pkgname)
pkgs -> Right $ head $ snd $ last pkgs
case pickLastIPI $ PackageIndex.lookupDependency installedIndex dep_pkgname vr of
Nothing -> Left (DependencyNotExists dep_pkgname)
Just pkg -> Right pkg
-- It's an internal library, being looked up externally
do_external_internal
:: LibraryName -> Either FailedDependency InstalledPackageInfo
do_external_internal ln =
case PackageIndex.lookupInternalDependency installedIndex
case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex
(packageName pkgid) vr ln of
[] -> Left (DependencyMissingInternal dep_pkgname (packageName pkgid))
pkgs -> Right $ head $ snd $ last pkgs
Nothing -> Left (DependencyMissingInternal dep_pkgname (packageName pkgid))
Just pkg -> Right pkg
pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo
pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs
reportSelectedDependencies :: Verbosity
-> [ResolvedDependency] -> IO ()
......@@ -1773,7 +1778,7 @@ checkForeignDeps pkg lbi verbosity =
findOffendingHdr =
ifBuildsWith allHeaders ccArgs
(return Nothing)
(go . tail . inits $ allHeaders)
(go . Prelude.tail . inits $ allHeaders) -- inits always contains at least []
where
go [] = return Nothing -- cannot happen
go (hdrs:hdrsInits) =
......@@ -1782,8 +1787,9 @@ checkForeignDeps pkg lbi verbosity =
-- If that works, try compiling too
(ifBuildsWith hdrs ccArgs
(go hdrsInits)
(return . Just . Right . last $ hdrs))
(return . Just . Left . last $ hdrs)
(return . fmap Right . safeLast $ hdrs))
(return . fmap Left . safeLast $ hdrs)
cppArgs = "-E":commonCppArgs -- preprocess only
ccArgs = "-c":commonCcArgs -- don't try to link
......@@ -2004,7 +2010,7 @@ checkRelocatable verbosity pkg lbi
-- database to which the package is installed are relative to the
-- prefix of the package
depsPrefixRelative = do
pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi))
pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi))
traverse_ (doCheck pkgr) ipkgs
where
doCheck pkgr ipkg
......
......@@ -69,7 +69,7 @@ module Distribution.Simple.GHC (
GhcImplInfo(..)
) where
import Prelude (head, tail)
import Prelude ()
import Distribution.Compat.Prelude
import qualified Distribution.Simple.GHC.Internal as Internal
......@@ -1074,24 +1074,26 @@ exeMainModuleName Executable{buildInfo = bnfo} =
-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753.
decodeMainIsArg :: String -> Maybe ModuleName
decodeMainIsArg arg
| not (null main_fn) && isLower (head main_fn)
| headOf main_fn isLower
-- The arg looked like "Foo.Bar.baz"
= Just (ModuleName.fromString main_mod)
| isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar"
| headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar"
= Just (ModuleName.fromString arg)
| otherwise -- The arg looked like "baz"
= Nothing
where
headOf :: String -> (Char -> Bool) -> Bool
headOf str pred' = any pred' (safeHead str)
(main_mod, main_fn) = splitLongestPrefix arg (== '.')
splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
splitLongestPrefix str pred'
| null r_pre = (str, [])
| otherwise = (reverse (tail r_pre), reverse r_suf)
-- 'tail' drops the char satisfying 'pred'
| otherwise = (reverse (safeTail r_pre), reverse r_suf)
-- 'safeTail' drops the char satisfying 'pred'
where (r_suf, r_pre) = break pred' (reverse str)
-- | A collection of:
-- * C input files
-- * C++ input files
......
......@@ -37,7 +37,7 @@ module Distribution.Simple.GHCJS (
GhcImplInfo(..)
) where
import Prelude (head)
import Prelude ()
import Distribution.Compat.Prelude
import qualified Distribution.Simple.GHC.Internal as Internal
......@@ -926,21 +926,24 @@ exeMainModuleName Executable{buildInfo = bnfo} =
-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753.
decodeMainIsArg :: String -> Maybe ModuleName
decodeMainIsArg arg
| not (null main_fn) && isLower (head main_fn)
| headOf main_fn isLower
-- The arg looked like "Foo.Bar.baz"
= Just (ModuleName.fromString main_mod)
| isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar"
| headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar"
= Just (ModuleName.fromString arg)
| otherwise -- The arg looked like "baz"
= Nothing
where
headOf :: String -> (Char -> Bool) -> Bool
headOf str pred' = any pred' (safeHead str)
(main_mod, main_fn) = splitLongestPrefix arg (== '.')
splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
splitLongestPrefix str pred'
| null r_pre = (str, [])
| otherwise = (reverse (safeTail r_pre), reverse r_suf)
-- 'tail' drops the char satisfying 'pred'
-- 'safeTail' drops the char satisfying 'pred'
where (r_suf, r_pre) = break pred' (reverse str)
......
......@@ -3,7 +3,7 @@
module Distribution.Simple.HaskellSuite where
import Prelude (last, init)
import Prelude ()
import Distribution.Compat.Prelude
import Data.Either (partitionEithers)
......@@ -26,6 +26,7 @@ import Distribution.PackageDescription
import Distribution.Simple.LocalBuildInfo
import Distribution.System (Platform)
import Distribution.Compat.Exception
import Distribution.Utils.Generic
import Language.Haskell.Extension
import Distribution.Simple.Program.Builtin
......@@ -92,15 +93,15 @@ hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version)
hstoolVersion = findProgramVersion "--hspkg-version" id
numericVersion :: Verbosity -> FilePath -> IO (Maybe Version)
numericVersion = findProgramVersion "--compiler-version" (last . words)
numericVersion = findProgramVersion "--compiler-version" (fromMaybe "" . safeLast . words)
getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version)
getCompilerVersion verbosity prog = do
output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"]
let
parts = words output
name = concat $ init parts -- there shouldn't be any spaces in the name anyway
versionStr = last parts
name = concat $ safeInit parts -- there shouldn't be any spaces in the name anyway
versionStr = fromMaybe "" $ safeLast parts
version <-
maybe (die' verbosity "haskell-suite: couldn't determine compiler version") return $
simpleParsec versionStr
......@@ -217,7 +218,7 @@ registerPackage verbosity progdb packageDbs installedPkgInfo = do
runProgramInvocation verbosity $
(programInvocation hspkg
["update", packageDbOpt $ last packageDbs])
["update", packageDbOpt $ registrationPackageDB packageDbs])
{ progInvokeInput = Just $ showInstalledPackageInfo installedPkgInfo }
initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO ()
......
......@@ -42,8 +42,8 @@ module Distribution.Simple.Program.HcPkg (
listInvocation,
) where
import Prelude (last)
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Compat.Prelude hiding (init)
import Data.Either (partitionEithers)
import qualified Data.List.NonEmpty as NE
......@@ -162,7 +162,7 @@ register hpi verbosity packagedbs pkgInfo registerOptions
--
| registerMultiInstance registerOptions
, recacheMultiInstance hpi
= do let pkgdb = last packagedbs
= do let pkgdb = registrationPackageDB packagedbs
writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo
recache hpi verbosity pkgdb
......@@ -386,9 +386,7 @@ registerInvocation hpi verbosity packagedbs pkgInfo registerOptions =
| otherwise = "register"
args file = [cmdname, file]
++ (if noPkgDbStack hpi
then [packageDbOpts hpi (last packagedbs)]
else packageDbStackOpts hpi packagedbs)
++ packageDbStackOpts hpi packagedbs
++ [ "--enable-multi-instance"
| registerMultiInstance registerOptions ]
++ [ "--force-files"
......@@ -423,9 +421,7 @@ describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId
describeInvocation hpi verbosity packagedbs pkgid =
programInvocation (hcPkgProgram hpi) $
["describe", prettyShow pkgid]
++ (if noPkgDbStack hpi
then [packageDbOpts hpi (last packagedbs)]
else packageDbStackOpts hpi packagedbs)
++ packageDbStackOpts hpi packagedbs
++ verbosityOpts hpi verbosity
hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
......@@ -460,19 +456,21 @@ listInvocation hpi _verbosity packagedb =
packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String]
packageDbStackOpts hpi dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> "--global"
: "--user"
: map specific dbs
(GlobalPackageDB:dbs) -> "--global"
: ("--no-user-" ++ packageDbFlag hpi)
: map specific dbs
_ -> ierror
where
specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
specific _ = ierror
ierror :: a
ierror = error ("internal error: unexpected package db stack: " ++ show dbstack)
packageDbStackOpts hpi dbstack
| noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)]
| otherwise = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> "--global"
: "--user"
: map specific dbs
(GlobalPackageDB:dbs) -> "--global"
: ("--no-user-" ++ packageDbFlag hpi)
: map specific dbs
_ -> ierror
where
specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
specific _ = ierror
ierror :: a
ierror = error ("internal error: unexpected package db stack: " ++ show dbstack)
packageDbFlag :: HcPkgInfo -> String
packageDbFlag hpi
......
......@@ -27,13 +27,14 @@ module Distribution.Simple.Program.Run (
getEffectiveEnvironment,
) where
import Prelude (last, init)
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Simple.Program.Types
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Compat.Environment
import Distribution.Utils.Generic
import qualified Data.Map as Map
import System.FilePath
......@@ -243,13 +244,14 @@ multiStageProgramInvocation simple (initial, middle, final) args =
chunkSize = maxCommandLineSize - fixedArgSize
in case splitChunks chunkSize args of
[] -> [ simple ]
[] -> [ simple ]
[c] -> [ simple `appendArgs` c ]
[c] -> [ simple `appendArgs` c ]
(c:cs) -> [ initial `appendArgs` c ]
++ [ middle `appendArgs` c'| c' <- init cs ]
++ [ final `appendArgs` c'| let c' = last cs ]
(c:c2:cs) | (xs, x) <- unsnocNE (c2:|cs) ->
[ initial `appendArgs` c ]
++ [ middle `appendArgs` c'| c' <- xs ]
++ [ final `appendArgs` x ]
where
appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation
......
......@@ -22,7 +22,7 @@ module Distribution.Simple.UHC (
buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath
) where
import Prelude (last)
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.InstalledPackageInfo
......@@ -277,7 +277,7 @@ registerPackage
-> InstalledPackageInfo
-> IO ()
registerPackage verbosity comp progdb packageDbs installedPkgInfo = do
dbdir <- case last packageDbs of
dbdir <- case registrationPackageDB packageDbs of
GlobalPackageDB -> getGlobalPackageDir verbosity progdb
UserPackageDB -> getUserPackageDir
SpecificPackageDB dir -> return dir
......
......@@ -21,7 +21,7 @@ module Distribution.Types.VersionInterval (
Bound(..),
) where
import Prelude (tail)
import Prelude ()
import Distribution.Compat.Prelude
import Control.Exception (assert)
......@@ -118,9 +118,9 @@ invariant (VersionIntervals intervals) = all validInterval intervals
doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l'
adjacentIntervals :: [(VersionInterval, VersionInterval)]
adjacentIntervals
| null intervals = []
| otherwise = zip intervals (tail intervals)
adjacentIntervals = case intervals of
[] -> []
(_:tl) -> zip intervals tl
checkInvariant :: VersionIntervals -> VersionIntervals
checkInvariant is = assert (invariant is) is
......
......@@ -39,7 +39,8 @@ module Distribution.Types.VersionRange (
import Distribution.Compat.Prelude
import Distribution.Types.Version
import Distribution.Types.VersionRange.Internal
import Prelude (last, init)
import Distribution.Utils.Generic
import Prelude ()
-- | Fold over the basic syntactic structure of a 'VersionRange'.
--
......@@ -130,7 +131,9 @@ withinRange v = foldVersionRange
-- | @since 2.2
wildcardUpperBound :: Version -> Version
wildcardUpperBound = alterVersion $
\lowerBound -> init lowerBound ++ [last lowerBound + 1]
\lowerBound -> case unsnoc lowerBound of
Nothing -> []
Just (xs, x) -> xs ++ [x + 1]
isWildcardRange :: Version -> Version -> Bool
isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2)
......
......@@ -74,13 +74,15 @@ module Distribution.Utils.Generic (
unfoldrM,
spanMaybe,
breakMaybe,
unsnoc,
unsnocNE,
-- * FilePath stuff
isAbsoluteOnAnyPlatform,
isRelativeOnAnyPlatform,
) where
import Prelude (head, tail, last, init)
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.String
......@@ -283,11 +285,11 @@ normaliseLineEndings ( c :s) = c : normaliseLineEndings s
--
-- Example:
--
-- >>> tail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1]
-- >>> safeTail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1]
-- *** Exception: Prelude.undefined
-- ...
--
-- >>> tail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1]
-- >>> safeTail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1]
-- [5,4,3]
--
-- >>> take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined]
......@@ -368,23 +370,24 @@ listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b
-- | A total variant of 'head'.
safeHead :: [a] -> Maybe a
safeHead [] = Nothing
safeHead xs = Just (head xs)
safeHead [] = Nothing
safeHead (x:_) = Just x
-- | A total variant of 'tail'.
safeTail :: [a] -> [a]
safeTail [] = []
safeTail xs = tail xs
safeTail [] = []
safeTail (_:xs) = xs
-- | A total variant of 'last'.
safeLast :: [a] -> Maybe a
safeLast [] = Nothing
safeLast xs = Just (last xs)
safeLast [] = Nothing
safeLast (x:xs) = Just (foldl (\_ a -> a) x xs)
-- | A total variant of 'init'.
safeInit :: [a] -> [a]
safeInit [] = []
safeInit xs = init xs
safeInit [] = []
safeInit [_] = []
safeInit (x:xs) = x : safeInit xs
equating :: Eq a => (b -> a) -> b -> b -> Bool
equating p x y = p x == p y
......@@ -472,6 +475,35 @@ unfoldrM f = go where
Nothing -> return []
Just (a, b') -> liftM (a :) (go b')
-- | The opposite of 'snoc', which is the reverse of 'cons'
--
-- Example:
--
-- >>> unsnoc [1, 2, 3]
-- Just ([1,2],3)
--
-- >>> unsnoc []
-- Nothing
--
unsnoc :: [a] -> Maybe ([a], a)
unsnoc [] = Nothing
unsnoc (x:xs) = Just (unsnocNE (x :| xs))
-- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe'
--
-- Example:
--
-- >>> unsnocNE (1 :| [2, 3])
-- ([1,2],3)
--
-- >>> unsnocNE (1 :| [])
-- ([],1)
--
unsnocNE :: NonEmpty a -> ([a], a)
unsnocNE (x:|xs) = go x xs where
go y [] = ([], y)
go y (z: