Commit b90bd039 authored by Oleg Grenrus's avatar Oleg Grenrus
Browse files

Use traverse instead of mapM all over the place

parent bea19f65
......@@ -36,8 +36,9 @@ import Foreign
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.Char (chr,ord)
import Data.List (unfoldr)
import Data.Char (chr,ord)
import Data.List (unfoldr)
import Data.Foldable (traverse_)
-- And needed for the instances:
import qualified Data.ByteString as B
......@@ -389,7 +390,7 @@ instance (Binary a, Binary b, Binary c, Binary d, Binary e,
-- Container types
instance Binary a => Binary [a] where
put l = put (length l) >> mapM_ put l
put l = put (length l) >> traverse_ put l
get = do n <- get :: Get Int
getMany n
......@@ -444,26 +445,26 @@ instance Binary ByteString where
-- Maps and Sets
instance (Binary a) => Binary (Set.Set a) where
put s = put (Set.size s) >> mapM_ put (Set.toAscList s)
put s = put (Set.size s) >> traverse_ put (Set.toAscList s)
get = liftM Set.fromDistinctAscList get
instance (Binary k, Binary e) => Binary (Map.Map k e) where
put m = put (Map.size m) >> mapM_ put (Map.toAscList m)
put m = put (Map.size m) >> traverse_ put (Map.toAscList m)
get = liftM Map.fromDistinctAscList get
instance Binary IntSet.IntSet where
put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s)
put s = put (IntSet.size s) >> traverse_ put (IntSet.toAscList s)
get = liftM IntSet.fromDistinctAscList get
instance (Binary e) => Binary (IntMap.IntMap e) where
put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m)
put m = put (IntMap.size m) >> traverse_ put (IntMap.toAscList m)
get = liftM IntMap.fromDistinctAscList get
------------------------------------------------------------------------
-- Queues and Sequences
instance (Binary e) => Binary (Seq.Seq e) where
put s = put (Seq.length s) >> Fold.mapM_ put s
put s = put (Seq.length s) >> Fold.traverse_ put s
get = do n <- get :: Get Int
rep Seq.empty n get
where rep xs 0 _ = return $! xs
......@@ -496,7 +497,7 @@ instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
put a = do
put (bounds a)
put (rangeSize $ bounds a) -- write the length
mapM_ put (elems a) -- now the elems.
traverse_ put (elems a) -- now the elems.
get = do
bs <- get
n <- get -- read the length
......@@ -510,7 +511,7 @@ instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) wher
put a = do
put (bounds a)
put (rangeSize $ bounds a) -- now write the length
mapM_ put (elems a)
traverse_ put (elems a)
get = do
bs <- get
n <- get
......
......@@ -293,7 +293,7 @@ revNeighbors g k = do
-- Requires amortized construction of graph.
closure :: Graph a -> [Key a] -> Maybe [a]
closure g ks = do
vs <- mapM (graphKeyToVertex g) ks
vs <- traverse (graphKeyToVertex g) ks
return (decodeVertexForest g (G.dfs (graphForward g) vs))
-- | Compute the reverse closure of a graph from some set
......@@ -302,7 +302,7 @@ closure g ks = do
-- Requires amortized construction of graph.
revClosure :: Graph a -> [Key a] -> Maybe [a]
revClosure g ks = do
vs <- mapM (graphKeyToVertex g) ks
vs <- traverse (graphKeyToVertex g) ks
return (decodeVertexForest g (G.dfs (graphAdjoint g) vs))
flattenForest :: Tree.Forest a -> [a]
......
......@@ -49,6 +49,7 @@ import Distribution.Text
import Distribution.Simple.LocalBuildInfo hiding (compiler)
import Language.Haskell.Extension
import Control.Monad (mapM)
import Data.List (group)
import qualified System.Directory as System
( doesFileExist, doesDirectoryExist )
......
......@@ -534,7 +534,7 @@ readAndParseFile withFileContents' parser verbosity fpath = do
let (line, message) = locatedErrorMsg e
dieWithLocation fpath line message
ParseOk warnings x -> do
mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings
traverse_ (warn verbosity . showPWarning fpath) $ reverse warnings
return x
readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo
......@@ -561,15 +561,15 @@ isStanzaHeader _ = False
mapSimpleFields :: (Field -> ParseResult Field) -> [Field]
-> ParseResult [Field]
mapSimpleFields f = mapM walk
mapSimpleFields f = traverse walk
where
walk fld@F{} = f fld
walk (IfBlock l c fs1 fs2) = do
fs1' <- mapM walk fs1
fs2' <- mapM walk fs2
fs1' <- traverse walk fs1
fs2' <- traverse walk fs2
return (IfBlock l c fs1' fs2')
walk (Section ln n l fs1) = do
fs1' <- mapM walk fs1
fs1' <- traverse walk fs1
return (Section ln n l fs1')
-- prop_isMapM fs = mapSimpleFields return fs == return fs
......@@ -1053,7 +1053,7 @@ parsePackageDescription file = do
condFlds = [ f | f@IfBlock{} <- allflds ]
sections = [ s | s@Section{} <- allflds ]
mapM_
traverse_
(\(Section l n _ _) -> lift . warning $
"Unexpected section '" ++ n ++ "' on line " ++ show l)
sections
......@@ -1073,11 +1073,11 @@ parsePackageDescription file = do
-- to check the CondTree, rather than grovel everywhere
-- inside the conditional bits).
deps <- liftM concat
. mapM (lift . parseConstraint)
. traverse (lift . parseConstraint)
. filter isConstraint
$ simplFlds
ifs <- mapM processIfs condFlds
ifs <- traverse processIfs condFlds
return (CondNode a deps ifs)
where
......@@ -1123,10 +1123,10 @@ parsePackageDescription file = do
PM ()
checkForUndefinedFlags flags mlib sub_libs exes tests = do
let definedFlags = map flagName flags
mapM_ (checkCondTreeFlags definedFlags) (maybeToList mlib)
mapM_ (checkCondTreeFlags definedFlags . snd) sub_libs
mapM_ (checkCondTreeFlags definedFlags . snd) exes
mapM_ (checkCondTreeFlags definedFlags . snd) tests
traverse_ (checkCondTreeFlags definedFlags) (maybeToList mlib)
traverse_ (checkCondTreeFlags definedFlags . snd) sub_libs
traverse_ (checkCondTreeFlags definedFlags . snd) exes
traverse_ (checkCondTreeFlags definedFlags . snd) tests
checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()
checkCondTreeFlags definedFlags ct = do
......
......@@ -387,14 +387,14 @@ fName _ = error "fname: not a field or section"
readFields :: String -> ParseResult [Field]
readFields input = ifelse
=<< mapM (mkField 0)
=<< traverse (mkField 0)
=<< mkTree tokens
where ls = (lines . normaliseLineEndings) input
tokens = (concatMap tokeniseLine . trimLines) ls
readFieldsFlat :: String -> ParseResult [Field]
readFieldsFlat input = mapM (mkField 0)
readFieldsFlat input = traverse (mkField 0)
=<< mkTree tokens
where ls = (lines . normaliseLineEndings) input
tokens = (concatMap tokeniseLineFlat . trimLines) ls
......@@ -568,7 +568,7 @@ mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of
then tabsError n
else return $ F n (map toLower name)
(fieldValue rest' followingLines)
rest' -> do ts' <- mapM (mkField (d+1)) ts
rest' -> do ts' <- traverse (mkField (d+1)) ts
return (Section n (map toLower name) rest' ts')
where fieldValue firstLine followingLines =
let firstLine' = trimLeading firstLine
......
......@@ -505,7 +505,7 @@ clean pkg_descr flags = do
when exists (removeDirectoryRecursive distPref)
-- Any extra files the user wants to remove
mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr)
traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr)
-- If the user wanted to save the config, write it back
traverse_ (writePersistBuildConfig distPref) maybeConfig
......
......@@ -96,7 +96,7 @@ bench args pkg_descr lbi flags = do
let totalBenchmarks = length bmsToRun
notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."
exitcodes <- mapM doBench bmsToRun
exitcodes <- traverse doBench bmsToRun
let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes)
unless allOk exitFailure
where
......
......@@ -139,7 +139,7 @@ readBuildTargets pkg targetStrs = do
let (uproblems, utargets) = readUserBuildTargets targetStrs
reportUserBuildTargetProblems uproblems
utargets' <- mapM checkTargetExistsAsFile utargets
utargets' <- traverse checkTargetExistsAsFile utargets
let (bproblems, btargets) = resolveBuildTargets pkg utargets'
reportBuildTargetProblems bproblems
......
......@@ -197,7 +197,7 @@ registrationPackageDB dbs = last dbs
absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack
absolutePackageDBPaths = mapM absolutePackageDBPath
absolutePackageDBPaths = traverse absolutePackageDBPath
absolutePackageDBPath :: PackageDB -> IO PackageDB
absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB
......
......@@ -1345,12 +1345,12 @@ configurePkgconfigPackages verbosity pkg_descr conf
(_, _, conf') <- requireProgramVersion
(lessVerbose verbosity) pkgConfigProgram
(orLaterVersion $ Version [0,9,0] []) conf
mapM_ requirePkg allpkgs
mlib' <- mapM addPkgConfigBILib (library pkg_descr)
libs' <- mapM addPkgConfigBILib (subLibraries pkg_descr)
exes' <- mapM addPkgConfigBIExe (executables pkg_descr)
tests' <- mapM addPkgConfigBITest (testSuites pkg_descr)
benches' <- mapM addPkgConfigBIBench (benchmarks pkg_descr)
traverse_ requirePkg allpkgs
mlib' <- traverse addPkgConfigBILib (library pkg_descr)
libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr)
exes' <- traverse addPkgConfigBIExe (executables pkg_descr)
tests' <- traverse addPkgConfigBITest (testSuites pkg_descr)
benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr)
let pkg_descr' = pkg_descr { library = mlib',
subLibraries = libs', executables = exes',
testSuites = tests', benchmarks = benches' }
......@@ -2132,7 +2132,7 @@ checkPackageProblems verbosity gpkg pkg = do
errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ]
warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ]
if null errors
then mapM_ (warn verbosity) warnings
then traverse_ (warn verbosity) warnings
else die (intercalate "\n\n" errors)
-- | Preform checks if a relocatable build is allowed
......@@ -2189,11 +2189,11 @@ checkRelocatable verbosity pkg lbi
-- prefix of the package
depsPrefixRelative = do
pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi))
mapM_ (doCheck pkgr) ipkgs
traverse_ (doCheck pkgr) ipkgs
where
doCheck pkgr ipkg
| maybe False (== pkgr) (Installed.pkgRoot ipkg)
= mapM_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l)))
= traverse_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l)))
(Installed.libraryDirs ipkg)
| otherwise
= return ()
......
......@@ -203,7 +203,7 @@ guessToolFromGhcPath tool ghcProg verbosity searchpath
info verbosity $ "looking for tool " ++ toolname
++ " near compiler in " ++ given_dir
debug verbosity $ "candidate locations: " ++ show guesses
exists <- mapM doesFileExist guesses
exists <- traverse doesFileExist guesses
case [ file | (file, True) <- zip guesses exists ] of
-- If we can't find it near ghc, fall back to the usual
-- method.
......@@ -397,7 +397,7 @@ getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' verbosity packagedbs conf
| ghcVersion >= Version [6,9] [] =
sequence
sequenceA
[ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb
return (packagedb, pkgs)
| packagedb <- packagedbs ]
......@@ -415,11 +415,11 @@ getInstalledPackages' verbosity packagedbs conf = do
(UserPackageDB, _global:_) -> return $ Nothing
(SpecificPackageDB specific, _) -> return $ Just specific
_ -> die "cannot read ghc-pkg package listing"
pkgFiles' <- mapM dbFile packagedbs
sequence [ withFileContents file $ \content -> do
pkgFiles' <- traverse dbFile packagedbs
sequenceA [ withFileContents file $ \content -> do
pkgs <- readPackages file content
return (db, pkgs)
| (db , Just file) <- zip packagedbs pkgFiles' ]
| (db , Just file) <- zip packagedbs pkgFiles' ]
where
-- Depending on the version of ghc we use a different type's Read
-- instance to parse the package file and then convert.
......@@ -441,7 +441,7 @@ getInstalledPackagesMonitorFiles :: Verbosity -> Platform
-> [PackageDB]
-> IO [FilePath]
getInstalledPackagesMonitorFiles verbosity platform progdb =
mapM getPackageDBPath
traverse getPackageDBPath
where
getPackageDBPath :: PackageDB -> IO FilePath
getPackageDBPath GlobalPackageDB =
......@@ -659,17 +659,17 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do
libInstallPath = libdir $ absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest
sharedLibInstallPath = libInstallPath </> mkSharedLibName compiler_id uid
stubObjs <- catMaybes <$> sequence
stubObjs <- catMaybes <$> sequenceA
[ findFileWithExtension [objExtension] [libTargetDir]
(ModuleName.toFilePath x ++"_stub")
| ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files
, x <- libModules lib ]
stubProfObjs <- catMaybes <$> sequence
stubProfObjs <- catMaybes <$> sequenceA
[ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
(ModuleName.toFilePath x ++"_stub")
| ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files
, x <- libModules lib ]
stubSharedObjs <- catMaybes <$> sequence
stubSharedObjs <- catMaybes <$> sequenceA
[ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
(ModuleName.toFilePath x ++"_stub")
| ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files
......
......@@ -349,7 +349,7 @@ getHaskellObjects _implInfo lib lbi pref wanted_obj_ext allow_split_objs
let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"
dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)
| x <- libModules lib ]
objss <- mapM getDirectoryContents dirs
objss <- traverse getDirectoryContents dirs
let objs = [ dir </> obj
| (objs',dir) <- zip objss dirs, obj <- objs',
let obj_ext = takeExtension obj,
......
......@@ -161,7 +161,7 @@ guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath
guessNormal]
info verbosity $ "looking for tool " ++ toolname
++ " near compiler in " ++ dir
exists <- mapM doesFileExist guesses
exists <- traverse doesFileExist guesses
case [ file | (file, True) <- zip guesses exists ] of
-- If we can't find it near ghc, fall back to the usual
-- method.
......@@ -228,7 +228,7 @@ checkPackageDbStack _ =
getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' verbosity packagedbs conf =
sequence
sequenceA
[ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb
return (packagedb, pkgs)
| packagedb <- packagedbs ]
......
......@@ -569,7 +569,7 @@ haddockPackagePaths :: [InstalledPackageInfo]
-> Maybe (InstalledPackageInfo -> FilePath)
-> IO ([(FilePath, Maybe FilePath)], Maybe String)
haddockPackagePaths ipkgs mkHtmlPath = do
interfaces <- sequence
interfaces <- sequenceA
[ case interfaceAndHtmlPath ipkg of
Nothing -> return (Left (packageId ipkg))
Just (interface, html) -> do
......@@ -750,7 +750,7 @@ getExeSourceFiles lbi exe clbi = do
getSourceFiles :: [FilePath]
-> [ModuleName.ModuleName]
-> IO [(ModuleName.ModuleName, FilePath)]
getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $
getSourceFiles dirs modules = flip traverse modules $ \m -> fmap ((,) m) $
findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m)
>>= maybe (notFound m) (return . normalise)
where
......
......@@ -124,7 +124,7 @@ markupPackage :: Verbosity
-> IO ()
markupPackage verbosity lbi distPref libName suites = do
let tixFiles = map (tixFilePath distPref way . testName) suites
tixFilesExist <- mapM doesFileExist tixFiles
tixFilesExist <- traverse doesFileExist tixFiles
when (and tixFilesExist) $ do
-- behaviour of 'markup' depends on version, so we need *a* version
-- but no particular one
......
......@@ -228,7 +228,7 @@ copyComponent _ _ _ _ _ _ = return ()
--
installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO ()
installDataFiles verbosity pkg_descr destDataDir =
flip mapM_ (dataFiles pkg_descr) $ \ file -> do
flip traverse_ (dataFiles pkg_descr) $ \ file -> do
let srcDataDir = dataDir pkg_descr
files <- matchDirFileGlob srcDataDir file
let dir = takeDirectory file
......@@ -243,7 +243,7 @@ installIncludeFiles :: Verbosity -> Library -> FilePath -> IO ()
installIncludeFiles verbosity lib destIncludeDir = do
let relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)
lbi = libBuildInfo lib
incs <- mapM (findInc relincdirs) (installIncludes lbi)
incs <- traverse (findInc relincdirs) (installIncludes lbi)
sequence_
[ do createDirectoryIfMissingVerbose verbosity True destDir
installOrdinaryFile verbosity srcFile destFile
......
......@@ -225,7 +225,7 @@ getInstalledPackages' :: ConfiguredProgram -> Verbosity
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' lhcPkg verbosity packagedbs conf
=
sequence
sequenceA
[ do str <- rawSystemProgramStdoutConf verbosity lhcPkgProgram conf
["dump", packageDbGhcPkgFlag packagedb]
`catchExit` \_ -> die $ "ghc-pkg dump failed"
......@@ -348,15 +348,15 @@ buildLib verbosity pkg_descr lbi lib clbi = do
sharedLibFilePath = libTargetDir </> mkSharedLibName cid lib_name
ghciLibFilePath = libTargetDir </> mkGHCiLibName lib_name
stubObjs <- fmap catMaybes $ sequence
stubObjs <- fmap catMaybes $ sequenceA
[ findFileWithExtension [objExtension] [libTargetDir]
(ModuleName.toFilePath x ++"_stub")
| x <- libModules lib ]
stubProfObjs <- fmap catMaybes $ sequence
stubProfObjs <- fmap catMaybes $ sequenceA
[ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
(ModuleName.toFilePath x ++"_stub")
| x <- libModules lib ]
stubSharedObjs <- fmap catMaybes $ sequence
stubSharedObjs <- fmap catMaybes $ sequenceA
[ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
(ModuleName.toFilePath x ++"_stub")
| x <- libModules lib ]
......@@ -538,7 +538,7 @@ getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs
| splitObjs lbi && allow_split_objs = do
let dirs = [ pref </> (ModuleName.toFilePath x ++ "_split")
| x <- libModules lib ]
objss <- mapM getDirectoryContents dirs
objss <- traverse getDirectoryContents dirs
let objs = [ dir </> obj
| (objs',dir) <- zip objss dirs, obj <- objs',
let obj_ext = takeExtension obj,
......@@ -719,7 +719,7 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
ifVanilla $ copyModuleFiles "hi"
ifProf $ copyModuleFiles "p_hi"
hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib)
flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase </> srcFile]
flip traverse_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase </> srcFile]
-- copy the built library files over:
ifVanilla $ copy builtDir targetDir vanillaLibName
......
......@@ -273,7 +273,7 @@ depLibraryPaths inplace relative lbi clbi = do
allDepLibDirs = concatMap Installed.libraryDirs ipkgs
allDepLibDirs' = internalLibs ++ allDepLibDirs
allDepLibDirsC <- mapM canonicalizePathNoFail allDepLibDirs'
allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs'
let p = prefix installDirs
prefixRelative l = isJust (stripPrefix p l)
......
......@@ -132,7 +132,7 @@ findProgramOnSearchPath verbosity searchpath prog = do
-- algorithm looks at more than just the @%PATH%@.
programSearchPathAsPATHVar :: ProgramSearchPath -> IO String
programSearchPathAsPATHVar searchpath = do
ess <- mapM getEntries searchpath
ess <- traverse getEntries searchpath
return (intercalate [searchPathSeparator] (concat ess))
where
getEntries (ProgramSearchPathDir dir) = return [dir]
......
......@@ -341,7 +341,7 @@ list hpi verbosity packagedb = do
++ programId (hcPkgProgram hpi) ++ " list'"
where
parsePackageIds = sequence . map simpleParse . words
parsePackageIds = traverse simpleParse . words
--------------------------
-- The program invocations
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment