Permalink
Browse files

Fix backport of 'Find original sources for main-is when creating sdist'

Required an extra util function.
  • Loading branch information...
dcoutts committed May 29, 2008
1 parent 294cee0 commit ff3cf2f89916f4b76bd4250ffdabedb8dca3cbe2
Showing with 38 additions and 9 deletions.
  1. +3 −2 Distribution/Simple/SrcDist.hs
  2. +35 −7 Distribution/Simple/Utils.hs
@@ -64,7 +64,8 @@ import Distribution.Package (showPackageId, PackageIdentifier(pkgVersion))
import Distribution.Version (Version(versionBranch), VersionRange(AnyVersion))
import Distribution.Simple.Utils (createDirectoryIfMissingVerbose,
smartCopySources, die, warn, notice,
findPackageDesc, findFile, copyFileVerbose)
findPackageDesc, findFile, findFileWithExtension,
copyFileVerbose)
import Distribution.Simple.Setup (SDistFlags(..))
import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessSources)
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
@@ -81,7 +82,7 @@ import System.Time (getClockTime, toCalendarTime, CalendarTime(..))
import Distribution.Compat.Directory (doesFileExist, doesDirectoryExist,
getCurrentDirectory, removeDirectoryRecursive)
import Distribution.Verbosity
import System.FilePath ((</>), takeDirectory, isAbsolute)
import System.FilePath ((</>), takeDirectory, isAbsolute, dropExtension)
#ifdef DEBUG
import Test.HUnit (Test)
@@ -66,6 +66,8 @@ module Distribution.Simple.Utils (
currentDir,
dotToSep,
findFile,
findFileWithExtension,
findFileWithExtension',
defaultPackageDesc,
findPackageDesc,
defaultHookedPackageDesc,
@@ -359,13 +361,39 @@ moduleToPossiblePaths searchPref s possibleSuffixes =
findFile :: [FilePath] -- ^search locations
-> FilePath -- ^File Name
-> IO FilePath
findFile prefPathsIn locPath = do
let prefPaths = nub prefPathsIn -- ignore dups
paths <- filterM doesFileExist [prefPath </> locPath | prefPath <- prefPaths]
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'))
findFile searchPath fileName =
findFirstFile id
[ path </> fileName
| path <- nub searchPath]
>>= maybe (die $ fileName ++ " doesn't exist") return
findFileWithExtension :: [String]
-> [FilePath]
-> FilePath
-> IO (Maybe FilePath)
findFileWithExtension extensions searchPath baseName =
findFirstFile id
[ path </> baseName <.> ext
| path <- nub searchPath
, ext <- nub extensions ]
findFileWithExtension' :: [String]
-> [FilePath]
-> FilePath
-> IO (Maybe (FilePath, FilePath))
findFileWithExtension' extensions searchPath baseName =
findFirstFile (uncurry (</>))
[ (path, baseName <.> ext)
| path <- nub searchPath
, ext <- nub extensions ]
findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)
findFirstFile file = findFirst
where findFirst [] = return Nothing
findFirst (x:xs) = do exists <- doesFileExist (file x)
if exists
then return (Just x)
else findFirst xs
dotToSep :: String -> String
dotToSep = map dts

0 comments on commit ff3cf2f

Please sign in to comment.