Commit e2864182 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

-Wall clean fixes

This patch is sponsored by Hac 07.
Have you hacked a lambda today?
parent b1b5165c
......@@ -96,7 +96,7 @@ splitFileName p = (reverse path1, reverse fname1)
"" -> "."
_ -> case dropWhile isPathSeparator path of
"" -> [pathSeparator]
p -> p
_ -> path
fname1 = case fname of
"" -> "."
_ -> fname
......@@ -293,8 +293,8 @@ pathParents p =
(root,path) = ("",p)
#endif
(root',root'',path') = case path of
(c:path) | isPathSeparator c -> (root++[pathSeparator],root++[pathSeparator],path)
_ -> (root ,root++"." ,path)
(c:path_tail) | isPathSeparator c -> (root++[pathSeparator],root++[pathSeparator],path_tail)
_ -> (root ,root++"." ,path)
dropEmptyPath ("":paths) = paths
dropEmptyPath paths = paths
......@@ -308,14 +308,14 @@ pathParents p =
_ -> "" : map (joinFileName pre) (inits suf)
where
(pre,suf) = case break isPathSeparator cs of
(pre,"") -> (pre, "")
(pre,_:suf) -> (pre,suf)
(prefix,"") -> (prefix, "")
(prefix,_:suffix) -> (prefix,suffix)
-- | Given a list of file paths, returns the longest common parent.
commonParent :: [FilePath] -> Maybe FilePath
commonParent [] = Nothing
commonParent paths@(p:ps) =
case common Nothing "" p ps of
commonParent paths@(path:paths') =
case common Nothing "" path paths' of
#if mingw32_HOST_OS || mingw32_TARGET_OS
Nothing | all (not . isAbsolutePath) paths ->
let
......@@ -337,24 +337,24 @@ commonParent paths@(p:ps) =
| isPathSeparator c = removeSep i acc cs [] ps
| otherwise = removeChar i acc c cs [] ps
checkSep i acc [] = Just (reverse acc)
checkSep i acc ([]:ps) = Just (reverse acc)
checkSep i acc ((c1:p):ps)
checkSep _ acc [] = Just (reverse acc)
checkSep _ acc ([]:_) = Just (reverse acc)
checkSep i acc ((c1:_):ps)
| isPathSeparator c1 = checkSep i acc ps
checkSep i acc ps = i
checkSep i _ _ = i
removeSep i acc cs pacc [] =
removeSep _ acc cs pacc [] =
common (Just (reverse (pathSeparator:acc))) (pathSeparator:acc) cs pacc
removeSep i acc cs pacc ([] :ps) = Just (reverse acc)
removeSep _ acc _ _ ([] :_ ) = Just (reverse acc)
removeSep i acc cs pacc ((c1:p):ps)
| isPathSeparator c1 = removeSep i acc cs (p:pacc) ps
removeSep i acc cs pacc ps = i
removeSep i _ _ _ _ = i
removeChar i acc c cs pacc [] = common i (c:acc) cs pacc
removeChar i acc c cs pacc ([] :ps) = i
removeChar i _ _ _ _ ([] :_ ) = i
removeChar i acc c cs pacc ((c1:p):ps)
| c == c1 = removeChar i acc c cs (p:pacc) ps
removeChar i acc c cs pacc ps = i
removeChar i _ _ _ _ _ = i
--------------------------------------------------------------
-- * Search path
......
......@@ -152,7 +152,7 @@ parseInstalledPackageInfo inp = do
stLines <- singleStanza inp
-- not interested in stanzas, so just allow blank lines in
-- the package info.
foldM (parseBasicStanza fields) emptyInstalledPackageInfo stLines
foldM (parseBasicStanza all_fields) emptyInstalledPackageInfo stLines
parseBasicStanza :: [StanzaField a]
-> a
......@@ -167,7 +167,7 @@ parseBasicStanza [] pkg (_, _, _) = return pkg
-- Pretty-printing
showInstalledPackageInfo :: InstalledPackageInfo -> String
showInstalledPackageInfo pkg = render (ppFields fields)
showInstalledPackageInfo pkg = render (ppFields all_fields)
where
ppFields [] = empty
ppFields ((StanzaField name get' _):flds) =
......@@ -177,17 +177,18 @@ showInstalledPackageInfoField
:: String
-> Maybe (InstalledPackageInfo -> String)
showInstalledPackageInfoField field
= case [ (f,get') | (StanzaField f get' _) <- fields, f == field ] of
= case [ (f,get') | (StanzaField f get' _) <- all_fields, f == field ] of
[] -> Nothing
((f,get'):_) -> Just (render . pprField f . get')
pprField :: String -> Doc -> Doc
pprField name field = text name <> colon <+> field
-- -----------------------------------------------------------------------------
-- Description of the fields, for parsing/printing
fields :: [StanzaField InstalledPackageInfo]
fields = basicStanzaFields ++ installedStanzaFields
all_fields :: [StanzaField InstalledPackageInfo]
all_fields = basicStanzaFields ++ installedStanzaFields
basicStanzaFields :: [StanzaField InstalledPackageInfo]
basicStanzaFields =
......@@ -284,4 +285,6 @@ installedStanzaFields = [
haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs})
]
parsePackageId' :: ReadP [PackageIdentifier] PackageIdentifier
parsePackageId' = parseQuoted parsePackageId <++ parsePackageId
......@@ -26,11 +26,11 @@ plain _ hs = hs
classify :: [String] -> [Classified]
classify [] = []
classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs
classify ("\\begin{code":rest) = Blank : allProg rest
where allProg [] = [] -- Should give an error message,
-- but I have no good position information.
allProg (('\\':x):xs) | x == "end{code}" = Blank : classify xs
allProg (x:xs) = Program x:allProg xs
allProg ("\\end{code}":xs) = Blank : classify xs
allProg (x:xs) = Program x:allProg xs
classify (('>':x):xs) = Program (' ':x) : classify xs
classify (('#':x):xs) = (case words x of
(line:file:_) | all isDigit line
......@@ -38,7 +38,7 @@ classify (('#':x):xs) = (case words x of
_ -> Pre x
) : classify xs
classify (x:xs) | all isSpace x = Blank:classify xs
classify (x:xs) = Comment:classify xs
classify (_:xs) = Comment:classify xs
unclassify :: Classified -> String
unclassify (Program s) = s
......@@ -57,17 +57,18 @@ unlit file lhs = (unlines
adjacent :: FilePath -> Int -> Classified -> [Classified] -> [Classified]
adjacent file 0 _ (x :xs) = x : adjacent file 1 x xs -- force evaluation of line number
adjacent file n y@(Program _) (x@Comment :xs) = error (message file n "program" "comment")
adjacent file n y@(Program _) (x@(Include i f):xs) = x: adjacent f i y xs
adjacent file n (Program _) ( Comment :_ ) = error (message file n "program" "comment")
adjacent _ _ y@(Program _) (x@(Include i f):xs) = x: adjacent f i y xs
adjacent file n y@(Program _) (x@(Pre _) :xs) = x: adjacent file (n+1) y xs
adjacent file n y@Comment (x@(Program _) :xs) = error (message file n "comment" "program")
adjacent file n y@Comment (x@(Include i f):xs) = x: adjacent f i y xs
adjacent file n Comment ( (Program _) :_ ) = error (message file n "comment" "program")
adjacent _ _ y@Comment (x@(Include i f):xs) = x: adjacent f i y xs
adjacent file n y@Comment (x@(Pre _) :xs) = x: adjacent file (n+1) y xs
adjacent file n y@Blank (x@(Include i f):xs) = x: adjacent f i y xs
adjacent _ _ y@Blank (x@(Include i f):xs) = x: adjacent f i y xs
adjacent file n y@Blank (x@(Pre _) :xs) = x: adjacent file (n+1) y xs
adjacent file n _ (x@next :xs) = x: adjacent file (n+1) x xs
adjacent file n _ [] = []
adjacent file n _ (x :xs) = x: adjacent file (n+1) x xs
adjacent _ _ _ [] = []
message :: String -> Int -> String -> String -> String
message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"
message [] n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"
message file n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n"
......@@ -75,7 +76,8 @@ message file n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " li
-- Re-implementation of 'lines', for better efficiency (but decreased laziness).
-- Also, importantly, accepts non-standard DOS and Mac line ending characters.
inlines s = lines' s id
inlines :: String -> [String]
inlines xs = lines' xs id
where
lines' [] acc = [acc []]
lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS
......
......@@ -61,9 +61,6 @@ module Distribution.Program(
) where
import qualified Distribution.Compat.Map as Map
import Control.Monad(when)
import Data.Maybe(catMaybes)
import System.Exit (ExitCode)
import Distribution.Compat.Directory(findExecutable)
import Distribution.Simple.Utils (die, rawSystemVerbose, maybeExit)
......
......@@ -550,7 +550,7 @@ parseConfigureArgs progConf = parseArgs (configureCmd progConf) updateCfg
updateCfg t WithSplitObjs = t { configSplitObjs = True }
updateCfg t WithoutSplitObjs = t { configSplitObjs = False }
updateCfg t (Lift _) = t
updateCfg t _ = error $ "Unexpected flag!"
updateCfg _ _ = error $ "Unexpected flag!"
buildCmd :: Cmd a
buildCmd = Cmd {
......@@ -716,13 +716,14 @@ parseRegisterArgs :: RegisterFlags -> [String] -> [OptDescr a] ->
IO (RegisterFlags, [a], [String])
parseRegisterArgs = parseArgs registerCmd registerUpdateCfg
registerUpdateCfg :: RegisterFlags -> Flag a -> RegisterFlags
registerUpdateCfg reg fl = case fl of
UserFlag -> reg { regUser=MaybeUserUser }
GlobalFlag -> reg { regUser=MaybeUserGlobal }
Verbose n -> reg { regVerbose=n }
GenScriptFlag -> reg { regGenScript=True }
InPlaceFlag -> reg { regInPlace=True }
WithHcPkg f -> reg { regWithHcPkg=Just f }
InPlaceFlag -> reg { regInPlace=True }
WithHcPkg f -> reg { regWithHcPkg=Just f }
_ -> error $ "Unexpected flag!"
unregisterCmd :: Cmd a
......
......@@ -84,8 +84,7 @@ import Distribution.Simple.Register ( register, unregister,
)
import Distribution.Simple.Configure(getPersistBuildConfig, maybeGetPersistBuildConfig,
findProgram, configure, writePersistBuildConfig,
localBuildInfoFile)
configure, writePersistBuildConfig, localBuildInfoFile)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))
import Distribution.Simple.Install(install)
......@@ -220,21 +219,21 @@ defaultMain = getArgs >>=defaultMainArgs
defaultMainArgs :: [String] -> IO ()
defaultMainArgs args = do
(action, args) <- parseGlobalArgs (allPrograms Nothing) args
(action, args') <- parseGlobalArgs (allPrograms Nothing) args
pkg_descr_file <- defaultPackageDesc
pkg_descr <- readPackageDescription pkg_descr_file
defaultMainWorker pkg_descr action args Nothing
defaultMainWorker pkg_descr action args' Nothing
return ()
-- | A customizable version of 'defaultMain'.
defaultMainWithHooks :: UserHooks -> IO ()
defaultMainWithHooks hooks
= do args <- getArgs
(action, args) <- parseGlobalArgs (allPrograms (Just hooks)) args
(action, args') <- parseGlobalArgs (allPrograms (Just hooks)) args
maybeDesc <- readDesc hooks
pkg_descr <- maybe (defaultPackageDesc >>= readPackageDescription)
return maybeDesc
defaultMainWorker pkg_descr action args (Just hooks)
defaultMainWorker pkg_descr action args' (Just hooks)
return ()
-- |Like 'defaultMain', but accepts the package description as input
......@@ -242,8 +241,8 @@ defaultMainWithHooks hooks
defaultMainNoRead :: PackageDescription -> IO ()
defaultMainNoRead pkg_descr
= do args <- getArgs
(action, args) <- parseGlobalArgs (allPrograms Nothing) args
defaultMainWorker pkg_descr action args Nothing
(action, args') <- parseGlobalArgs (allPrograms Nothing) args
defaultMainWorker pkg_descr action args' Nothing
return ()
-- |Combine the programs in the given hooks with the programs built
......@@ -276,94 +275,94 @@ defaultMainWorker :: PackageDescription
defaultMainWorker pkg_descr_in action args hooks
= do case action of
ConfigCmd flags -> do
(flags, optFns, args) <-
parseConfigureArgs (allPrograms hooks) flags args [buildDirOpt]
pkg_descr <- hookOrInArgs preConf args flags
(flags', optFns, args') <-
parseConfigureArgs (allPrograms hooks) flags args [buildDirOpt]
pkg_descr <- hookOrInArgs preConf args' flags'
(warns, ers) <- sanityCheckPackage pkg_descr
errorOut warns ers
let c = maybe (confHook defaultUserHooks) confHook hooks
localbuildinfo <- c pkg_descr flags
writePersistBuildConfig (foldr id localbuildinfo optFns)
localbuildinfo <- c pkg_descr flags
writePersistBuildConfig (foldr id localbuildinfo optFns)
postHook postConf args flags pkg_descr localbuildinfo
BuildCmd -> do
(flags, _, args) <- parseBuildArgs args []
pkg_descr <- hookOrInArgs preBuild args flags
localbuildinfo <- getPersistBuildConfig
(flags, _, args') <- parseBuildArgs args []
pkg_descr <- hookOrInArgs preBuild args' flags
localbuildinfo <- getPersistBuildConfig
cmdHook buildHook pkg_descr localbuildinfo flags
postHook postBuild args flags pkg_descr localbuildinfo
HaddockCmd -> do
(verbose, _, args) <- parseHaddockArgs emptyHaddockFlags args []
pkg_descr <- hookOrInArgs preHaddock args verbose
localbuildinfo <- getPersistBuildConfig
(verbose, _, args') <- parseHaddockArgs emptyHaddockFlags args []
pkg_descr <- hookOrInArgs preHaddock args' verbose
localbuildinfo <- getPersistBuildConfig
cmdHook haddockHook pkg_descr localbuildinfo verbose
postHook postHaddock args verbose pkg_descr localbuildinfo
ProgramaticaCmd -> do
(verbose, _, args) <- parseProgramaticaArgs args []
pkg_descr <- hookOrInArgs prePFE args verbose
(verbose, _, args') <- parseProgramaticaArgs args []
pkg_descr <- hookOrInArgs prePFE args' verbose
localbuildinfo <- getPersistBuildConfig
cmdHook pfeHook pkg_descr localbuildinfo verbose
postHook postPFE args verbose pkg_descr localbuildinfo
CleanCmd -> do
(flags,_, args) <- parseCleanArgs emptyCleanFlags args []
pkg_descr <- hookOrInArgs preClean args flags
maybeLocalbuildinfo <- maybeGetPersistBuildConfig
(flags,_, args') <- parseCleanArgs emptyCleanFlags args []
pkg_descr <- hookOrInArgs preClean args' flags
maybeLocalbuildinfo <- maybeGetPersistBuildConfig
cmdHook cleanHook pkg_descr maybeLocalbuildinfo flags
postHook postClean args flags pkg_descr maybeLocalbuildinfo
CopyCmd mprefix -> do
(flags, _, args) <- parseCopyArgs (CopyFlags mprefix 0) args []
pkg_descr <- hookOrInArgs preCopy args flags
localbuildinfo <- getPersistBuildConfig
(flags, _, args') <- parseCopyArgs (CopyFlags mprefix 0) args []
pkg_descr <- hookOrInArgs preCopy args' flags
localbuildinfo <- getPersistBuildConfig
cmdHook copyHook pkg_descr localbuildinfo flags
postHook postCopy args flags pkg_descr localbuildinfo
InstallCmd -> do
(flags, _, args) <- parseInstallArgs emptyInstallFlags args []
pkg_descr <- hookOrInArgs preInst args flags
localbuildinfo <- getPersistBuildConfig
(flags, _, args') <- parseInstallArgs emptyInstallFlags args []
pkg_descr <- hookOrInArgs preInst args' flags
localbuildinfo <- getPersistBuildConfig
cmdHook instHook pkg_descr localbuildinfo flags
postHook postInst args flags pkg_descr localbuildinfo
SDistCmd -> do
(flags,_, args) <- parseSDistArgs args []
pkg_descr <- hookOrInArgs preSDist args flags
(flags,_, args') <- parseSDistArgs args []
pkg_descr <- hookOrInArgs preSDist args' flags
maybeLocalbuildinfo <- maybeGetPersistBuildConfig
cmdHook sDistHook pkg_descr maybeLocalbuildinfo flags
postHook postSDist args flags pkg_descr maybeLocalbuildinfo
TestCmd -> do
(verbose,_, args) <- parseTestArgs args []
(_,_, args') <- parseTestArgs args []
case hooks of
Nothing -> return ExitSuccess
Just h -> do localbuildinfo <- getPersistBuildConfig
out <- (runTests h) args False pkg_descr_in localbuildinfo
out <- (runTests h) args' False pkg_descr_in localbuildinfo
when (isFailure out) (exitWith out)
return out
RegisterCmd -> do
(flags, _, args) <- parseRegisterArgs emptyRegisterFlags args []
pkg_descr <- hookOrInArgs preReg args flags
localbuildinfo <- getPersistBuildConfig
(flags, _, args') <- parseRegisterArgs emptyRegisterFlags args []
pkg_descr <- hookOrInArgs preReg args' flags
localbuildinfo <- getPersistBuildConfig
cmdHook regHook pkg_descr localbuildinfo flags
postHook postReg args flags pkg_descr localbuildinfo
UnregisterCmd -> do
(flags,_, args) <- parseUnregisterArgs emptyRegisterFlags args []
pkg_descr <- hookOrInArgs preUnreg args flags
localbuildinfo <- getPersistBuildConfig
(flags,_, args') <- parseUnregisterArgs emptyRegisterFlags args []
pkg_descr <- hookOrInArgs preUnreg args' flags
localbuildinfo <- getPersistBuildConfig
cmdHook unregHook pkg_descr localbuildinfo flags
postHook postUnreg args flags pkg_descr localbuildinfo
......@@ -380,10 +379,10 @@ defaultMainWorker pkg_descr_in action args hooks
Just h -> do pbi <- f h a i
return (updatePackageDescription pbi pkg_descr_in)
cmdHook f desc lbi = (maybe (f defaultUserHooks) f hooks) desc lbi hooks
postHook f args flags pkg_descr localbuildinfo
postHook f arguments flags pkg_descr localbuildinfo
= case hooks of
Nothing -> return ExitSuccess
Just h -> f h args flags pkg_descr localbuildinfo
Just h -> f h arguments flags pkg_descr localbuildinfo
isFailure :: ExitCode -> Bool
isFailure (ExitFailure _) = True
......@@ -401,8 +400,8 @@ haddock :: PackageDescription -> LocalBuildInfo -> Maybe UserHooks -> HaddockFla
haddock pkg_descr lbi hooks (HaddockFlags hoogle verbose) = do
let pps = allSuffixHandlers hooks
confHaddock <- do let programConf = withPrograms lbi
let haddockName = programName haddockProgram
mHaddock <- lookupProgram haddockName programConf
let haddockPath = programName haddockProgram
mHaddock <- lookupProgram haddockPath programConf
maybe (die "haddock command not found") return mHaddock
let tmpDir = joinPaths (buildDir lbi) "tmp"
......@@ -413,7 +412,7 @@ haddock pkg_descr lbi hooks (HaddockFlags hoogle verbose) = do
setupMessage "Running Haddock for" pkg_descr
let replaceLitExts = map (joinFileName tmpDir . flip changeFileExt "hs")
let mockAll bi = mapM_ (mockPP ["-D__HADDOCK__"] pkg_descr bi lbi tmpDir verbose)
let mockAll bi = mapM_ (mockPP ["-D__HADDOCK__"] bi tmpDir)
let showPkg = showPackageId (package pkg_descr)
let showDepPkgs = map showPackageId (packageDeps lbi)
let outputFlag = if hoogle then "--hoogle" else "--html"
......@@ -462,7 +461,7 @@ haddock pkg_descr lbi hooks (HaddockFlags hoogle verbose) = do
removeDirectoryRecursive tmpDir
where
mockPP inputArgs pkg_descr bi lbi pref verbose file
mockPP inputArgs bi pref file
= do let (filePref, fileName) = splitFileName file
let targetDir = joinPaths pref filePref
let targetFile = joinFileName targetDir fileName
......@@ -496,7 +495,7 @@ pfe pkg_descr _lbi hooks (PFEFlags verbose) = do
return ()
clean :: PackageDescription -> Maybe LocalBuildInfo -> Maybe UserHooks -> CleanFlags -> IO ()
clean pkg_descr maybeLbi hooks (CleanFlags saveConfigure verbose) = do
clean pkg_descr maybeLbi hooks (CleanFlags saveConfigure _verbose) = do
let pps = allSuffixHandlers hooks
putStrLn "cleaning..."
try $ removeDirectoryRecursive (joinPaths distPref "doc")
......@@ -515,7 +514,7 @@ clean pkg_descr maybeLbi hooks (CleanFlags saveConfigure verbose) = do
JHC -> cleanJHCExtras lbi
_ -> return ()
where
cleanGHCExtras lbi = do
cleanGHCExtras _ = do
-- remove source stubs for library
withLib pkg_descr () $ \ Library{libBuildInfo=bi} ->
removeGHCModuleStubs bi (libModules pkg_descr)
......@@ -633,7 +632,7 @@ defaultUserHooks
preUnreg = readHook regVerbose
}
where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode
defaultPostConf args flags pkg_descr lbi
defaultPostConf args flags _ _
= do let verbose = configVerbose flags
args' = configureArgs flags ++ args
confExists <- doesFileExist "configure"
......
......@@ -91,7 +91,7 @@ build pkg_descr lbi verbose = do
rawSystemExit verbose jhcPath (["-o",out] ++ args ++ [modulePath exe])
constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> FilePath -> Int -> [String]
constructJHCCmdLine lbi bi odir verbose =
constructJHCCmdLine lbi bi _odir verbose =
(if verbose > 4 then ["-v"] else [])
++ snd (extensionsToJHCFlag (extensions bi))
++ hcOptions JHC (options bi)
......@@ -112,13 +112,14 @@ jhcPkgConf pd =
]
installLib :: Int -> FilePath -> FilePath -> PackageDescription -> Library -> IO ()
installLib verb dest build pkg_descr _ = do
installLib verb dest build_dir pkg_descr _ = do
let p = showPackageId (package pkg_descr)++".hl"
createDirectoryIfMissing True dest
copyFileVerbose verb (joinFileName build p) (joinFileName dest p)
copyFileVerbose verb (joinFileName build_dir p) (joinFileName dest p)
installExe :: Int -> FilePath -> FilePath -> PackageDescription -> Executable -> IO ()
installExe verb dest build pkg_descr exe = do
installExe verb dest build_dir _ exe = do
let out = exeName exe `joinFileName` exeExtension
createDirectoryIfMissing True dest
copyFileVerbose verb (joinFileName build out) (joinFileName dest out)
copyFileVerbose verb (joinFileName build_dir out) (joinFileName dest out)
......@@ -213,7 +213,7 @@ default_bindir = "$prefix" `joinFileName`
#endif
default_libdir :: Compiler -> FilePath
default_libdir hc = "$prefix" `joinFileName`
default_libdir _ = "$prefix" `joinFileName`
#if mingw32_HOST_OS || mingw32_TARGET_OS
"Haskell"
#else
......@@ -236,11 +236,12 @@ default_libexecdir = "$prefix" `joinFileName`
#endif
default_datadir :: PackageDescription -> IO FilePath
default_datadir pkg_descr
#if mingw32_HOST_OS || mingw32_TARGET_OS
default_datadir pkg_descr
| hasLibs pkg_descr = getCommonFilesDir
| otherwise = return ("$prefix" `joinFileName` "Haskell")
#else
default_datadir _
= return ("$prefix" `joinFileName` "share")
#endif
......@@ -300,13 +301,13 @@ prefixRelPath :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath
-> Maybe FilePath
prefixRelPath pkg_descr lbi0 copydest ('$':'p':'r':'e':'f':'i':'x':s) = Just $
case s of
(c:s) | isPathSeparator c -> substDir pkg_descr lbi s
s -> substDir pkg_descr lbi s
(c:s') | isPathSeparator c -> substDir pkg_descr lbi s'
_ -> substDir pkg_descr lbi s
where
lbi = case copydest of
CopyPrefix d -> lbi0{prefix=d}
_otherwise -> lbi0
prefixRelPath pkg_descr lbi copydest s = Nothing
prefixRelPath _ _ _ _ = Nothing
absolutePath :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath
-> FilePath
......@@ -317,7 +318,7 @@ absolutePath pkg_descr lbi copydest s =
CopyTo p -> p `joinFileName` (dropAbsolutePrefix (substDir pkg_descr lbi s))
substDir :: PackageDescription -> LocalBuildInfo -> String -> String
substDir pkg_descr lbi s = loop s
substDir pkg_descr lbi xs = loop xs
where
loop "" = ""
loop ('$':'p':'r':'e':'f':'i':'x':s)
......@@ -332,3 +333,4 @@ substDir pkg_descr lbi s = loop s
= show (pkgVersion (package pkg_descr)) ++ loop s
loop ('$':'$':s) = '$' : loop s
loop (c:s) = c : loop s
......@@ -180,12 +180,12 @@ rawSystemPathExit verbose prog args = do
--
xargs :: Int -> (FilePath -> [String] -> IO ExitCode)
-> FilePath -> [String] -> [String] -> IO ExitCode
xargs maxSize rawSystem prog fixedArgs bigArgs =
xargs maxSize rawSystemFun prog fixedArgs bigArgs =
let fixedArgSize = sum (map length fixedArgs) + length fixedArgs
chunkSize = maxSize - fixedArgSize
loop [] = return ExitSuccess
loop (args:remainingArgs) = do
status <- rawSystem prog (fixedArgs ++ args)
status <- rawSystemFun prog (fixedArgs ++ args)
case status of
ExitSuccess -> loop remainingArgs
_ -> return status
......@@ -195,7 +195,7 @@ xargs maxSize rawSystem prog fixedArgs bigArgs =
if null s then Nothing
else Just (chunk [] len s)
chunk acc len [] = (reverse acc,[])
chunk acc _ [] = (reverse acc,[])
chunk acc len (s:ss)
| len' < len = chunk (s:acc) (len-len'-1) ss
| otherwise = (reverse acc, s:ss)
......@@ -255,7 +255,7 @@ findFile prefPathsIn locPath = do
case nub paths of -- also ignore dups, though above nub should fix this.
[path] -> return path
[] -> die (locPath ++ " doesn't exist")
paths -> die (locPath ++ " is found in multiple places:" ++ unlines (map ((++) " ") paths))
paths' -> die (locPath ++ " is found in multiple places:" ++ unlines (map ((++) " ") paths'))
dotToSep :: String -> String
dotToSep = map dts
......
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