Commit 1375d065 authored by Brent Yorgey's avatar Brent Yorgey

init: guess at filling in deps in the build-depends: field

parent e92c51d4
......@@ -31,24 +31,38 @@ import Data.Time
( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )
import Data.List
( intersperse, (\\) )
( intersperse, intercalate, nub, groupBy, (\\) )
import Data.Maybe
( fromMaybe, isJust )
( fromMaybe, isJust, catMaybes )
import Data.Function
( on )
import qualified Data.Map as M
import Data.Traversable
( traverse )
import Control.Applicative
( (<$>) )
import Control.Monad
( when )
#if MIN_VERSION_base(3,0,0)
import Control.Monad
( (>=>), join )
#endif
import Control.Arrow
( (&&&) )
import Text.PrettyPrint hiding (mode, cat)
import Data.Version
( Version(..) )
import Distribution.Version
( orLaterVersion )
( orLaterVersion, withinVersion, VersionRange )
import Distribution.Verbosity
( Verbosity )
import Distribution.ModuleName
( ModuleName, fromString )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo, sourcePackageId, exposed )
import qualified Distribution.Package as P
import Distribution.Client.Init.Types
( InitFlags(..), PackageType(..), Category(..) )
......@@ -66,14 +80,30 @@ import Distribution.ReadE
( runReadE, readP_to_E )
import Distribution.Simple.Setup
( Flag(..), flagToMaybe )
import Distribution.Simple.Configure
( getInstalledPackages )
import Distribution.Simple.Compiler
( PackageDBStack, Compiler )
import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.PackageIndex
( PackageIndex, moduleNameIndex )
import Distribution.Text
( display, Text(..) )
initCabal :: InitFlags -> IO ()
initCabal initFlags = do
initCabal :: Verbosity
-> PackageDBStack
-> Compiler
-> ProgramConfiguration
-> InitFlags
-> IO ()
initCabal verbosity packageDBs comp conf initFlags = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
hSetBuffering stdout NoBuffering
initFlags' <- extendFlags initFlags
initFlags' <- extendFlags installedPkgIndex initFlags
writeLicense initFlags'
writeSetupFile initFlags'
......@@ -87,18 +117,19 @@ initCabal initFlags = do
-- | Fill in more details by guessing, discovering, or prompting the
-- user.
extendFlags :: InitFlags -> IO InitFlags
extendFlags = getPackageName
>=> getVersion
>=> getLicense
>=> getAuthorInfo
>=> getHomepage
>=> getSynopsis
>=> getCategory
>=> getLibOrExec
>=> getGenComments
>=> getSrcDir
>=> getModulesAndBuildTools
extendFlags :: PackageIndex -> InitFlags -> IO InitFlags
extendFlags pkgIx =
getPackageName
>=> getVersion
>=> getLicense
>=> getAuthorInfo
>=> getHomepage
>=> getSynopsis
>=> getCategory
>=> getLibOrExec
>=> getGenComments
>=> getSrcDir
>=> getModulesBuildToolsAndDeps pkgIx
-- | Combine two actions which may return a value, preferring the first. That
-- is, run the second action only if the first doesn't return a value.
......@@ -241,22 +272,86 @@ guessSourceDirs flags = do
else return []
-- | Get the list of exposed modules and extra tools needed to build them.
getModulesAndBuildTools :: InitFlags -> IO InitFlags
getModulesAndBuildTools flags = do
getModulesBuildToolsAndDeps :: PackageIndex -> InitFlags -> IO InitFlags
getModulesBuildToolsAndDeps pkgIx flags = do
dir <- fromMaybe getCurrentDirectory
(fmap return . flagToMaybe $ packageDir flags)
-- XXX really should use guessed source roots.
sourceFiles <- scanForModules dir
mods <- return (exposedModules flags)
Just mods <- return (exposedModules flags)
?>> (return . Just . map moduleName $ sourceFiles)
tools <- return (buildTools flags)
?>> (return . Just . neededBuildPrograms $ sourceFiles)
return $ flags { exposedModules = mods
, buildTools = tools }
deps <- return (dependencies flags)
?>> Just <$> importsToDeps flags
(fromString "Prelude" : concatMap imports sourceFiles)
pkgIx
return $ flags { exposedModules = Just mods
, buildTools = tools
, dependencies = deps
}
importsToDeps :: InitFlags -> [ModuleName] -> PackageIndex -> IO [P.Dependency]
importsToDeps flags mods pkgIx = do
let modMap :: M.Map ModuleName [InstalledPackageInfo]
modMap = M.map (filter exposed) $ moduleNameIndex pkgIx
modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])]
modDeps = map (id &&& flip M.lookup modMap) mods
message flags "\nGuessing dependencies..."
nub . catMaybes <$> mapM (chooseDep flags) modDeps
-- Given a module and a list of installed packages providing it,
-- choose a dependency (i.e. package + version range) to use for that
-- module.
chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo])
-> IO (Maybe P.Dependency)
chooseDep flags (m, Nothing)
= message flags ("\nWarning: no package found providing " ++ display m ++ ".")
>> return Nothing
chooseDep flags (m, Just [])
= message flags ("\nWarning: no package found providing " ++ display m ++ ".")
>> return Nothing
-- We found some packages: group them by name.
chooseDep flags (m, Just ps)
= case pkgGroups of
-- if there's only one group, i.e. multiple versions of a single package,
-- we make it into a dependency, choosing the latest-ish version (see toDep).
[grp] -> Just <$> toDep grp
-- otherwise, we refuse to choose between different packages and make the user
-- do it.
grps -> do message flags ("\nWarning: multiple packages found providing "
++ display m
++ ": " ++ intercalate ", " (map (display . P.pkgName . head) grps))
message flags ("You will need to pick one and manually add it to the Build-depends: field.")
return Nothing
where
pkgGroups = groupBy ((==) `on` P.pkgName) (map sourcePackageId ps)
-- Given a list of available versions of the same package, pick a dependency.
toDep :: [P.PackageIdentifier] -> IO P.Dependency
-- If only one version, easy. We change e.g. 0.4.2 into 0.4.*
toDep [pid] = return $ P.Dependency (P.pkgName pid) (pvpize . P.pkgVersion $ pid)
-- Otherwise, choose the latest version and issue a warning.
toDep pids = do
message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.")
return $ P.Dependency (P.pkgName . head $ pids)
(pvpize . maximum . map P.pkgVersion $ pids)
pvpize :: Version -> VersionRange
pvpize v = withinVersion $ v { versionBranch = take 2 (versionBranch v) }
---------------------------------------------------------------------------
-- Prompting/user interaction -------------------------------------------
......@@ -378,7 +473,7 @@ readMaybe s = case reads s of
writeLicense :: InitFlags -> IO ()
writeLicense flags = do
message flags "Generating LICENSE..."
message flags "\nGenerating LICENSE..."
year <- getYear
let licenseFile =
case license flags of
......@@ -424,6 +519,8 @@ writeSetupFile flags = do
, "main = defaultMain"
]
-- XXX ought to do something sensible if a .cabal file already exists,
-- instead of overwriting.
writeCabalFile :: InitFlags -> IO Bool
writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do
message flags "Error: no package name provided."
......
......@@ -19,8 +19,10 @@ module Distribution.Client.Init.Heuristics (
guessAuthorNameMail,
knownCategories,
) where
import Distribution.Simple.Setup(Flag(..))
import Distribution.ModuleName ( ModuleName, fromString )
import Distribution.Text (simpleParse)
import Distribution.Simple.Setup (Flag(..))
import Distribution.ModuleName
( ModuleName, fromString, toFilePath )
import Distribution.Client.PackageIndex
( allPackagesByName )
import qualified Distribution.PackageDescription as PD
......@@ -34,6 +36,7 @@ import Data.Char ( isUpper, isLower, isSpace )
#if MIN_VERSION_base(3,0,3)
import Data.Either ( partitionEithers )
#endif
import Data.List ( isPrefixOf )
import Data.Maybe ( catMaybes )
import Data.Monoid ( mempty, mappend )
import qualified Data.Set as Set ( fromList, toList )
......@@ -41,7 +44,7 @@ import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExis
getHomeDirectory, canonicalizePath )
import System.Environment ( getEnvironment )
import System.FilePath ( takeExtension, takeBaseName, dropExtension,
(</>), splitDirectories, makeRelative )
(</>), (<.>), splitDirectories, makeRelative )
-- |Guess the package name based on the given root directory
guessPackageName :: FilePath -> IO String
......@@ -50,10 +53,15 @@ guessPackageName = liftM (last . splitDirectories) . canonicalizePath
-- |Data type of source files found in the working directory
data SourceFileEntry = SourceFileEntry
{ relativeSourcePath :: FilePath
, moduleName :: ModuleName
, fileExtension :: String
, moduleName :: ModuleName
, fileExtension :: String
, imports :: [ModuleName]
} deriving Show
sfToFileName :: FilePath -> SourceFileEntry -> FilePath
sfToFileName projectRoot (SourceFileEntry relPath m ext _)
= projectRoot </> relPath </> toFilePath m <.> ext
-- |Search for source files in the given directory
-- and return pairs of guessed haskell source path and
-- module names.
......@@ -69,14 +77,15 @@ scanForModulesIn projectRoot srcRoot = scan srcRoot []
let modules = catMaybes [ guessModuleName hierarchy file
| file <- files
, isUpper (head file) ]
modules' <- mapM (findImports projectRoot) modules
recMods <- mapM (scanRecursive dir hierarchy) dirs
return $ concat (modules : recMods)
return $ concat (modules' : recMods)
tagIsDir parent entry = do
isDir <- doesDirectoryExist (parent </> entry)
return $ (if isDir then Right else Left) entry
guessModuleName hierarchy entry
| takeBaseName entry == "Setup" = Nothing
| ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext
| ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext []
| otherwise = Nothing
where
relRoot = makeRelative projectRoot srcRoot
......@@ -91,6 +100,35 @@ scanForModulesIn projectRoot srcRoot = scan srcRoot []
ignoreDir ('.':_) = True
ignoreDir dir = dir `elem` ["dist", "_darcs"]
findImports :: FilePath -> SourceFileEntry -> IO SourceFileEntry
findImports projectRoot sf = do
s <- readFile (sfToFileName projectRoot sf)
let modules = catMaybes
. map ( getModName
. drop 1
. filter (not . null)
. dropWhile (/= "import")
. words
)
. filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering
. lines
$ s
-- XXX we should probably make a better attempt at parsing
-- comments above. Unfortunately we can't use a full-fledged
-- Haskell parser since cabal's dependencies must be kept at a
-- minimum.
return sf { imports = modules }
where getModName :: [String] -> Maybe ModuleName
getModName [] = Nothing
getModName ("qualified":ws) = getModName ws
getModName (ms:_) = simpleParse ms
-- Unfortunately we cannot use the version exported by Distribution.Simple.Program
knownSuffixHandlers :: [(String,String)]
knownSuffixHandlers =
......
......@@ -18,6 +18,7 @@ import Distribution.Simple.Setup
( Flag(..) )
import Distribution.Version
import Distribution.Verbosity
import qualified Distribution.Package as P
import Distribution.License
import Distribution.ModuleName
......@@ -59,6 +60,8 @@ data InitFlags =
, dependencies :: Maybe [P.Dependency]
, sourceDirs :: Maybe [String]
, buildTools :: Maybe [String]
, initVerbosity :: Flag Verbosity
}
deriving (Show)
......@@ -91,6 +94,7 @@ instance Monoid InitFlags where
, dependencies = mempty
, sourceDirs = mempty
, buildTools = mempty
, initVerbosity = mempty
}
mappend a b = InitFlags
{ nonInteractive = combine nonInteractive
......@@ -113,6 +117,7 @@ instance Monoid InitFlags where
, dependencies = combine dependencies
, sourceDirs = combine sourceDirs
, buildTools = combine buildTools
, initVerbosity = combine initVerbosity
}
where combine field = field a `mappend` field b
......
......@@ -905,7 +905,7 @@ emptyInitFlags :: IT.InitFlags
emptyInitFlags = mempty
defaultInitFlags :: IT.InitFlags
defaultInitFlags = emptyInitFlags
defaultInitFlags = emptyInitFlags { IT.initVerbosity = toFlag normal }
initCommand :: CommandUI IT.InitFlags
initCommand = CommandUI {
......@@ -1039,6 +1039,8 @@ initCommand = CommandUI {
IT.buildTools (\v flags -> flags { IT.buildTools = v })
(reqArg' "TOOL" (Just . (:[]))
(fromMaybe []))
, optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v })
]
}
where readMaybe s = case reads s of
......
......@@ -26,7 +26,7 @@ import Distribution.Client.Setup
, InfoFlags(..), infoCommand
, UploadFlags(..), uploadCommand
, ReportFlags(..), reportCommand
, InitFlags, initCommand
, InitFlags(initVerbosity), initCommand
, SDistFlags(..), SDistExFlags(..), sdistCommand
, reportCommand
, unpackCommand, UnpackFlags(..) )
......@@ -359,8 +359,16 @@ unpackAction unpackFlags extraArgs globalFlags = do
targets
initAction :: InitFlags -> [String] -> GlobalFlags -> IO ()
initAction flags _extraArgs _globalFlags = do
initCabal flags
initAction initFlags _extraArgs globalFlags = do
let verbosity = fromFlag (initVerbosity initFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let configFlags = savedConfigureFlags config
(comp, conf) <- configCompilerAux' configFlags
initCabal verbosity
(configPackageDB' configFlags)
comp
conf
initFlags
-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.
--
......
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