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

cabal-install/Distribution/Client/Init.hs

@@ -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."

cabal-install/Distribution/Client/Init/Heuristics.hs

@@ -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 =

cabal-install/Distribution/Client/Init/Types.hs

@@ -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
 

cabal-install/Distribution/Client/Setup.hs

@@ -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

cabal-install/Main.hs

@@ -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.
 --