Commit 1c11acb5 authored by edmundnoble's avatar edmundnoble Committed by Dale Wijnand

Use Data.List.NonEmpty and avoid some partial functions

Add safe alternatives to some partial functions in
Distribution.Utils.Generic, and removes the originals from
Distribution.Compat.Prelude

Uncomment versions of functions in Distribution.Compat.Parsing
that return non-empty lists
Co-authored-by: Dale Wijnand's avatarDale Wijnand <dale.wijnand@gmail.com>
parent e5b48049
......@@ -8,7 +8,7 @@ module Distribution.Backpack.ComponentsGraph (
componentCycleMsg
) where
import Prelude ()
import Prelude (head)
import Distribution.Compat.Prelude
import Distribution.Package
......
......@@ -19,7 +19,7 @@ module Distribution.Compat.DList (
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Compat.Prelude hiding (toList)
-- | Difference list.
newtype DList a = DList ([a] -> [a])
......
......@@ -85,7 +85,7 @@ module Distribution.Compat.Graph (
import Prelude ()
import qualified Distribution.Compat.Prelude as Prelude
import Distribution.Compat.Prelude hiding (lookup, null, empty)
import Distribution.Compat.Prelude hiding (lookup, null, empty, toList)
import Data.Graph (SCC(..))
import qualified Data.Graph as G
......
......@@ -28,10 +28,10 @@ module Distribution.Compat.Parsing
, sepBy1
, sepByNonEmpty
, sepEndBy1
-- , sepEndByNonEmpty
, sepEndByNonEmpty
, sepEndBy
, endBy1
-- , endByNonEmpty
, endByNonEmpty
, endBy
, count
, chainl
......@@ -58,6 +58,7 @@ import Control.Monad.Trans.Reader (ReaderT (..))
import Control.Monad.Trans.Identity (IdentityT (..))
import Data.Foldable (asum)
import qualified Data.List.NonEmpty as NE
import qualified Text.Parsec as Parsec
-- | @choice ps@ tries to apply the parsers in the list @ps@ in order,
......@@ -102,8 +103,7 @@ sepBy p sep = sepBy1 p sep <|> pure []
-- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated
-- by @sep@. Returns a list of values returned by @p@.
sepBy1 :: Alternative m => m a -> m sep -> m [a]
sepBy1 p sep = (:) <$> p <*> many (sep *> p)
-- toList <$> sepByNonEmpty p sep
sepBy1 p sep = toList <$> sepByNonEmpty p sep
{-# INLINE sepBy1 #-}
-- | @sepByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated
......@@ -116,16 +116,13 @@ sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p)
-- separated and optionally ended by @sep@. Returns a list of values
-- returned by @p@.
sepEndBy1 :: Alternative m => m a -> m sep -> m [a]
sepEndBy1 p sep = (:) <$> p <*> ((sep *> sepEndBy p sep) <|> pure [])
-- toList <$> sepEndByNonEmpty p sep
sepEndBy1 p sep = toList <$> sepEndByNonEmpty p sep
{-
-- | @sepEndByNonEmpty p sep@ parses /one/ or more occurrences of @p@,
-- separated and optionally ended by @sep@. Returns a non-empty list of values
-- returned by @p@.
sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a)
sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure [])
-}
-- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@,
-- separated and optionally ended by @sep@, ie. haskell style
......@@ -142,13 +139,11 @@ endBy1 :: Alternative m => m a -> m sep -> m [a]
endBy1 p sep = some (p <* sep)
{-# INLINE endBy1 #-}
{-
-- | @endByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated
-- and ended by @sep@. Returns a non-empty list of values returned by @p@.
endByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a)
endByNonEmpty p sep = some1 (p <* sep)
endByNonEmpty p sep = NE.some1 (p <* sep)
{-# INLINE endByNonEmpty #-}
-}
-- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated
-- and ended by @sep@. Returns a list of values returned by @p@.
......
......@@ -71,6 +71,7 @@ module Distribution.Compat.Prelude (
find, foldl',
traverse_, for_,
any, all,
toList,
-- * Data.Traversable
Traversable, traverse, sequenceA,
......@@ -103,7 +104,7 @@ module Distribution.Compat.Prelude (
) where
-- We also could hide few partial function
import Prelude as BasePrelude hiding
( IO, mapM, mapM_, sequence, null, length, foldr, any, all
( IO, mapM, mapM_, sequence, null, length, foldr, any, all, head, tail, last, init
-- partial functions
, read
, foldr1, foldl1
......@@ -123,8 +124,9 @@ import Prelude as BasePrelude hiding
#if !MINVER_base_48
import Control.Applicative (Applicative (..), (<$), (<$>))
import Distribution.Compat.Semigroup (Monoid (..))
import Data.Foldable (toList)
#else
import Data.Foldable (length, null)
import Data.Foldable (length, null, Foldable(toList))
#endif
import Data.Foldable (Foldable (foldMap, foldr), find, foldl', for_, traverse_, any, all)
......
......@@ -71,11 +71,12 @@ import Distribution.Compat.Prelude
import Distribution.Simple.Utils (fromUTF8BS)
import Prelude ()
import qualified Data.ByteString as BS
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Text.Parsec as P
import qualified Text.Parsec.Error as P
import qualified Data.ByteString as BS
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Text.Parsec as P
import qualified Text.Parsec.Error as P
import Distribution.CabalSpecVersion
import Distribution.FieldGrammar.Class
......@@ -155,12 +156,12 @@ instance FieldGrammar ParsecFieldGrammar where
uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
where
parser v fields = case Map.lookup fn fields of
Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing"
Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing"
Just [x] -> parseOne v x
Just xs -> do
Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing"
Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing"
Just [x] -> parseOne v x
Just xs@(_:y:ys) -> do
warnMultipleSingularFields fn xs
last <$> traverse (parseOne v) xs
NE.last <$> traverse (parseOne v) (y:|ys)
parseOne v (MkNamelessField pos fls) =
unpack' _pack <$> runFieldParser pos parsec v fls
......@@ -168,24 +169,24 @@ instance FieldGrammar ParsecFieldGrammar where
booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser
where
parser v fields = case Map.lookup fn fields of
Nothing -> pure def
Just [] -> pure def
Just [x] -> parseOne v x
Just xs -> do
Nothing -> pure def
Just [] -> pure def
Just [x] -> parseOne v x
Just xs@(_:y:ys) -> do
warnMultipleSingularFields fn xs
last <$> traverse (parseOne v) xs
NE.last <$> traverse (parseOne v) (y:|ys)
parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls
optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
where
parser v fields = case Map.lookup fn fields of
Nothing -> pure Nothing
Just [] -> pure Nothing
Just [x] -> parseOne v x
Just xs -> do
Nothing -> pure Nothing
Just [] -> pure Nothing
Just [x] -> parseOne v x
Just xs@(_:y:ys) -> do
warnMultipleSingularFields fn xs
last <$> traverse (parseOne v) xs
NE.last <$> traverse (parseOne v) (y:|ys)
parseOne v (MkNamelessField pos fls)
| null fls = pure Nothing
......@@ -194,12 +195,12 @@ instance FieldGrammar ParsecFieldGrammar where
optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser
where
parser v fields = case Map.lookup fn fields of
Nothing -> pure def
Just [] -> pure def
Just [x] -> parseOne v x
Just xs -> do
Nothing -> pure def
Just [] -> pure def
Just [x] -> parseOne v x
Just xs@(_:y:ys) -> do
warnMultipleSingularFields fn xs
last <$> traverse (parseOne v) xs
NE.last <$> traverse (parseOne v) (y:|ys)
parseOne v (MkNamelessField pos fls)
| null fls = pure def
......@@ -207,12 +208,12 @@ instance FieldGrammar ParsecFieldGrammar where
freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser where
parser v fields = case Map.lookup fn fields of
Nothing -> pure Nothing
Just [] -> pure Nothing
Just [x] -> parseOne v x
Just xs -> do
Nothing -> pure Nothing
Just [] -> pure Nothing
Just [x] -> parseOne v x
Just xs@(_:y:ys) -> do
warnMultipleSingularFields fn xs
last <$> traverse (parseOne v) xs
NE.last <$> traverse (parseOne v) (y:|ys)
parseOne v (MkNamelessField pos fls)
| null fls = pure Nothing
......@@ -221,12 +222,12 @@ instance FieldGrammar ParsecFieldGrammar where
freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser where
parser v fields = case Map.lookup fn fields of
Nothing -> pure ""
Just [] -> pure ""
Just [x] -> parseOne v x
Just xs -> do
Nothing -> pure ""
Just [] -> pure ""
Just [x] -> parseOne v x
Just xs@(_:y:ys) -> do
warnMultipleSingularFields fn xs
last <$> traverse (parseOne v) xs
NE.last <$> traverse (parseOne v) (y:|ys)
parseOne v (MkNamelessField pos fls)
| null fls = pure ""
......
......@@ -32,6 +32,7 @@ module Distribution.Fields.LexerMonad (
) where
import qualified Data.ByteString as B
import qualified Data.List.NonEmpty as NE
import Distribution.Compat.Prelude
import Distribution.Parsec.Position (Position (..), showPos)
import Distribution.Parsec.Warning (PWarnType (..), PWarning (..))
......@@ -76,15 +77,15 @@ toPWarnings :: [LexWarning] -> [PWarning]
toPWarnings
= map (uncurry toWarning)
. Map.toList
. Map.fromListWith (++)
. map (\(LexWarning t p) -> (t, [p]))
. Map.fromListWith (<>)
. map (\(LexWarning t p) -> (t, pure p))
where
toWarning LexWarningBOM poss =
PWarning PWTLexBOM (head poss) "Byte-order mark found at the beginning of the file"
PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file"
toWarning LexWarningNBSP poss =
PWarning PWTLexNBSP (head poss) $ "Non breaking spaces at " ++ intercalate ", " (map showPos poss)
PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss)
toWarning LexWarningTab poss =
PWarning PWTLexTab (head poss) $ "Tabs used as indentation at " ++ intercalate ", " (map showPos poss)
PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss)
data LexState = LexState {
curPos :: {-# UNPACK #-} !Position, -- ^ position at current input location
......
......@@ -34,7 +34,7 @@ module Distribution.PackageDescription.Check (
) where
import Distribution.Compat.Prelude
import Prelude ()
import Prelude (last, init)
import Control.Monad (mapM)
import Data.List (group)
......
......@@ -268,7 +268,7 @@ parsecLeadingCommaList p = do
parsecOptCommaList :: CabalParsing m => m a -> m [a]
parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma)
where
comma = P.char ',' *> P.spaces
comma = P.char ',' *> P.spaces
-- | Like 'parsecOptCommaList' but
--
......
......@@ -57,7 +57,7 @@ module Distribution.Simple (
import Control.Exception (try)
import Prelude ()
import Prelude (head)
import Distribution.Compat.Prelude
-- local
......
......@@ -28,7 +28,7 @@ module Distribution.Simple.Build (
writeAutogenFiles,
) where
import Prelude ()
import Prelude (head, init)
import Distribution.Compat.Prelude
import Distribution.Types.ComponentLocalBuildInfo
......
......@@ -73,6 +73,7 @@ module Distribution.Simple.Compiler (
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.Generic(safeLast)
import Distribution.Pretty
import Distribution.Compiler
......@@ -197,8 +198,9 @@ type PackageDBStack = [PackageDB]
-- the top of the stack.
--
registrationPackageDB :: PackageDBStack -> PackageDB
registrationPackageDB [] = error "internal error: empty package db set"
registrationPackageDB dbs = last dbs
registrationPackageDB dbs = case safeLast dbs of
Nothing -> error "internal error: empty package db set"
Just p -> p
-- | Make package paths absolute
......
......@@ -54,7 +54,7 @@ module Distribution.Simple.Configure
, platformDefines,
) where
import Prelude ()
import Prelude (head, tail, last)
import Distribution.Compat.Prelude
import Distribution.Compiler
......
......@@ -69,7 +69,7 @@ module Distribution.Simple.GHC (
GhcImplInfo(..)
) where
import Prelude ()
import Prelude (head, tail)
import Distribution.Compat.Prelude
import qualified Distribution.Simple.GHC.Internal as Internal
......
......@@ -37,7 +37,7 @@ module Distribution.Simple.GHCJS (
GhcImplInfo(..)
) where
import Prelude ()
import Prelude (head)
import Distribution.Compat.Prelude
import qualified Distribution.Simple.GHC.Internal as Internal
......@@ -939,7 +939,7 @@ decodeMainIsArg arg
splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
splitLongestPrefix str pred'
| null r_pre = (str, [])
| otherwise = (reverse (tail r_pre), reverse r_suf)
| otherwise = (reverse (safeTail r_pre), reverse r_suf)
-- 'tail' drops the char satisfying 'pred'
where (r_suf, r_pre) = break pred' (reverse str)
......
......@@ -37,6 +37,8 @@ import Distribution.Version
import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)
import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (</>), (<.>))
import qualified Data.List.NonEmpty as NE
-- Note throughout that we use splitDirectories, not splitPath. On
-- Posix, this makes no difference, but, because Windows accepts both
-- slash and backslash as its path separators, if we left in the
......@@ -151,7 +153,7 @@ fileGlobMatchesSegments pat (seg : segs) = case pat of
fileGlobMatchesSegments pat' segs
GlobFinal final -> case final of
FinalMatch Recursive multidot ext -> do
let (candidateBase, candidateExts) = splitExtensions (last $ seg:segs)
let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg:|segs)
guard (not (null candidateBase))
checkExt multidot ext candidateExts
FinalMatch NonRecursive multidot ext -> do
......
......@@ -3,7 +3,7 @@
module Distribution.Simple.HaskellSuite where
import Prelude ()
import Prelude (last, init)
import Distribution.Compat.Prelude
import Data.Either (partitionEithers)
......
......@@ -112,6 +112,7 @@ import Data.Array ((!))
import qualified Data.Array as Array
import qualified Data.Graph as Graph
import Data.List as List ( groupBy, deleteBy, deleteFirstsBy )
import qualified Data.List.NonEmpty as NE
import qualified Data.Tree as Tree
import Control.Monad
import Distribution.Compat.Stack
......@@ -210,20 +211,20 @@ mkPackageIndex pids pnames = assert (invariant index) index
-- ones.
--
fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex
fromList pkgs = mkPackageIndex pids pnames
fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames)
where
pids = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ]
pnames =
Map.fromList
[ (liftM2 (,) packageName IPI.sourceLibName (head pkgsN), pvers)
| pkgsN <- groupBy (equating (liftM2 (,) packageName IPI.sourceLibName))
[ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers)
| pkgsN <- NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName))
. sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion))
$ pkgs
, let pvers =
Map.fromList
[ (packageVersion (head pkgsNV),
nubBy (equating installedUnitId) (reverse pkgsNV))
| pkgsNV <- groupBy (equating packageVersion) pkgsN
[ (packageVersion (NE.head pkgsNV),
NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV))
| pkgsNV <- NE.groupBy (equating packageVersion) pkgsN
]
]
......
......@@ -269,7 +269,7 @@ preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes ha
let (srcStem, ext) = splitExtension psrcRelFile
psrcFile = psrcLoc </> psrcRelFile
pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected")
(lookup (tailNotNull ext) handlers)
(lookup (safeTail ext) handlers)
-- Preprocessing files for 'sdist' is different from preprocessing
-- for 'build'. When preprocessing for sdist we preprocess to
-- avoid that the user has to have the preprocessors available.
......@@ -296,8 +296,6 @@ preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes ha
where
dirName = takeDirectory
tailNotNull [] = []
tailNotNull x = tail x
-- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files
-- be in the same place as the hs files, so if we put the hs file in dist/
......
......@@ -17,6 +17,7 @@ module Distribution.Simple.PreProcess.Unlit (unlit,plain) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.Generic (safeTail, safeLast, safeInit)
import Data.List (mapAccumL)
......@@ -33,12 +34,10 @@ plain _ hs = hs
classify :: String -> Classified
classify ('>':s) = BirdTrack s
classify ('#':s) = case tokens s of
(line:file:_) | all isDigit line
&& length file >= 2
&& head file == '"'
&& last file == '"'
(line:file@('"':_:_):_) | all isDigit line
&& safeLast file == Just '"'
-- this shouldn't fail as we tested for 'all isDigit'
-> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (tail (init file)) -- TODO:eradicateNoParse
-> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse
_ -> CPP s
where tokens = unfoldr $ \str -> case lex str of
(t@(_:_), str'):_ -> Just (t, str')
......
......@@ -42,8 +42,8 @@ module Distribution.Simple.Program.HcPkg (
listInvocation,
) where
import Prelude ()
import Distribution.Compat.Prelude hiding (init)
import Prelude (last)
import Distribution.Compat.Prelude
import Data.Either (partitionEithers)
import qualified Data.List.NonEmpty as NE
......
......@@ -13,6 +13,7 @@ module Distribution.Simple.Program.Internal (
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.Generic(safeTail)
-- | Extract the version number from the output of 'strip --version'.
--
......@@ -29,7 +30,7 @@ stripExtractVersion str =
filterPar' :: Int -> [String] -> [String]
filterPar' _ [] = []
filterPar' n (x:xs)
| n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((tail x):xs)
| n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((safeTail x):xs)
| n > 0 && ")" `isSuffixOf` x = filterPar' (n-1) xs
| n > 0 = filterPar' n xs
| otherwise = x:filterPar' n xs
......
......@@ -27,7 +27,7 @@ module Distribution.Simple.Program.Run (
getEffectiveEnvironment,
) where
import Prelude ()
import Prelude (last, init)
import Distribution.Compat.Prelude
import Distribution.Simple.Program.Types
......
......@@ -22,9 +22,8 @@ module Distribution.Simple.UHC (
buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath
) where
import Prelude ()
import Prelude (last)
import Distribution.Compat.Prelude
import Data.Foldable (toList)
import Distribution.InstalledPackageInfo
import Distribution.Package hiding (installedUnitId)
......
......@@ -150,6 +150,7 @@ module Distribution.Simple.Utils (
ordNub,
ordNubBy,
ordNubRight,
safeHead,
safeTail,
unintersperse,
wrapText,
......
......@@ -68,7 +68,7 @@ instance NFData MungedPackageName where rnf = genericRnf
-- >>> prettyShow $ MungedPackageName "servant" LMainLibName
-- "servant"
--
-- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey")
-- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey")
-- "z-servant-z-lackey"
--
instance Pretty MungedPackageName where
......@@ -77,7 +77,7 @@ instance Pretty MungedPackageName where
-- indefinite package for us.
pretty = Disp.text . encodeCompatPackageName'
-- |
-- |
--
-- >>> simpleParsec "servant" :: Maybe MungedPackageName
-- Just (MungedPackageName (PackageName "servant") LMainLibName)
......
......@@ -13,6 +13,7 @@ import Distribution.Pretty
import Distribution.Types.PackageName
import Distribution.Version (Version, nullVersion)
import qualified Data.List.NonEmpty as NE
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
......@@ -58,10 +59,10 @@ instance Pretty PackageIdentifier where
--
instance Parsec PackageIdentifier where
parsec = do
xs' <- P.sepBy1 component (P.char '-')
(v, xs) <- case simpleParsec (last xs') of
Nothing -> return (nullVersion, xs') -- all components are version
Just v -> return (v, init xs')
xs' <- P.sepByNonEmpty component (P.char '-')
(v, xs) <- case simpleParsec (NE.last xs') of
Nothing -> return (nullVersion, toList xs') -- all components are version
Just v -> return (v, NE.init xs')
if not (null xs) && all (\c -> all (/= '.') c && not (all isDigit c)) xs
then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v
else fail "all digits or a dot in a portion of package name"
......
......@@ -21,7 +21,7 @@ module Distribution.Types.VersionInterval (
Bound(..),
) where
import Prelude ()
import Prelude (tail)
import Distribution.Compat.Prelude
import Control.Exception (assert)
......
......@@ -39,7 +39,7 @@ module Distribution.Types.VersionRange (
import Distribution.Compat.Prelude
import Distribution.Types.Version
import Distribution.Types.VersionRange.Internal
import Prelude ()
import Prelude (last, init)
-- | Fold over the basic syntactic structure of a 'VersionRange'.
--
......
......@@ -64,7 +64,10 @@ module Distribution.Utils.Generic (
ordNub,
ordNubBy,
ordNubRight,
safeHead,
safeTail,
safeLast,
safeInit,
unintersperse,
wrapText,