Merge pull request #3985 from ezyang/pr/nix-sdist-replacement

For non-Custom packages, replace sdist with hand-rolled rebuild checking

Author: ezyang

Cabal/Distribution/Simple/SrcDist.hs

@@ -177,12 +177,7 @@ listPackageSourcesOrdinary verbosity pkg_descr pps =
        case testInterface t of
          TestSuiteExeV10 _ mainPath -> do
            biSrcs <- allSourcesBuildInfo bi pps []
-           srcMainFile <- do
-             ppFile <- findFileWithExtension (ppSuffixes pps)
-                       (hsSourceDirs bi) (dropExtension mainPath)
-             case ppFile of
-               Nothing -> findFile (hsSourceDirs bi) mainPath
-               Just pp -> return pp
+           srcMainFile <- findMainExeFile bi pps mainPath
            return (srcMainFile:biSrcs)
          TestSuiteLibV09 _ m ->
            allSourcesBuildInfo bi pps [m]
@@ -196,12 +191,7 @@ listPackageSourcesOrdinary verbosity pkg_descr pps =
        case benchmarkInterface bm of
          BenchmarkExeV10 _ mainPath -> do
            biSrcs <- allSourcesBuildInfo bi pps []
-           srcMainFile <- do
-             ppFile <- findFileWithExtension (ppSuffixes pps)
-                       (hsSourceDirs bi) (dropExtension mainPath)
-             case ppFile of
-               Nothing -> findFile (hsSourceDirs bi) mainPath
-               Just pp -> return pp
+           srcMainFile <- findMainExeFile bi pps mainPath
            return (srcMainFile:biSrcs)
          BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: "
                                     ++ show tp
@@ -427,6 +417,9 @@ allSourcesBuildInfo bi pps modules = do
   let searchDirs = hsSourceDirs bi
   sources <- fmap concat $ sequenceA $
     [ let file = ModuleName.toFilePath module_
+      -- NB: *Not* findFileWithExtension, because the same source
+      -- file may show up in multiple paths due to a conditional;
+      -- we need to package all of them.  See #367.
       in findAllFilesWithExtension suffixes searchDirs file
          >>= nonEmpty (notFound module_) return
     | module_ <- modules ++ otherModules bi ]

cabal-install/Distribution/Client/FileMonitor.hs

@@ -15,6 +15,7 @@ module Distribution.Client.FileMonitor (
   monitorFile,
   monitorFileHashed,
   monitorNonExistentFile,
+  monitorFileExistence,
   monitorDirectory,
   monitorNonExistentDirectory,
   monitorDirectoryExistence,
@@ -123,6 +124,12 @@ monitorFileHashed = MonitorFile FileHashed DirNotExists
 monitorNonExistentFile :: FilePath -> MonitorFilePath
 monitorNonExistentFile = MonitorFile FileNotExists DirNotExists
 
+-- | Monitor a single file for existence only. The monitored file is
+-- considered to have changed if it no longer exists.
+--
+monitorFileExistence :: FilePath -> MonitorFilePath
+monitorFileExistence = MonitorFile FileExists DirNotExists
+
 -- | Monitor a single directory for changes, based on its modification
 -- time. The monitored directory is considered to have changed if it no
 -- longer exists or if its modification time has changed.

cabal-install/Distribution/Client/ProjectBuilding.hs

@@ -56,12 +56,15 @@ import           Distribution.Client.FetchUtils
 import           Distribution.Client.GlobalFlags (RepoContext)
 import qualified Distribution.Client.Tar as Tar
 import           Distribution.Client.Setup (filterConfigureFlags)
+import           Distribution.Client.SourceFiles
 import           Distribution.Client.SrcDist (allPackageSourceFiles)
 import           Distribution.Client.Utils (removeExistingFile)
 
 import           Distribution.Package hiding (InstalledPackageId, installedPackageId)
+import qualified Distribution.PackageDescription as PD
 import           Distribution.InstalledPackageInfo (InstalledPackageInfo)
 import qualified Distribution.InstalledPackageInfo as Installed
+import           Distribution.Types.BuildType
 import           Distribution.Simple.Program
 import qualified Distribution.Simple.Setup as Cabal
 import           Distribution.Simple.Command (CommandUI)
@@ -85,7 +88,6 @@ import qualified Data.ByteString.Lazy as LBS
 
 import           Control.Monad
 import           Control.Exception
-import           Data.List
 import           Data.Maybe
 
 import           System.FilePath
@@ -452,15 +454,14 @@ updatePackageBuildFileMonitor :: PackageFileMonitor
                               -> MonitorTimestamp
                               -> ElaboratedConfiguredPackage
                               -> BuildStatusRebuild
-                              -> [FilePath]
+                              -> [MonitorFilePath]
                               -> BuildResultMisc
                               -> IO ()
 updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}
                               srcdir timestamp pkg pkgBuildStatus
-                              allSrcFiles buildResult =
+                              monitors buildResult =
     updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)
-                      (map monitorFileHashed allSrcFiles)
-                      buildComponents' buildResult
+                      monitors buildComponents' buildResult
   where
     (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
 
@@ -1041,29 +1042,35 @@ buildInplaceUnpackedPackage verbosity
           annotateFailureNoLog BuildFailed $
             setup buildCommand buildFlags buildArgs
 
-          --TODO: [required eventually] this doesn't track file
-          --non-existence, so we could fail to rebuild if someone
-          --adds a new file which changes behavior.
-          allSrcFiles <-
-            let trySdist    = allPackageSourceFiles verbosity scriptOptions srcdir
-                -- This is just a hack, to get semi-reasonable file
-                -- listings for the monitor
-                tryFallback = do
-                    warn verbosity $
-                        "Couldn't use sdist to compute source files; falling " ++
-                        "back on recursive file scan."
-                    filter (not . ("dist" `isPrefixOf`))
-                        `fmap` getDirectoryContentsRecursive srcdir
-            in if elabSetupScriptCliVersion pkg >= mkVersion [1,17]
-                  then do r <- trySdist
-                          if null r
-                            then tryFallback
-                            else return r
-                  else tryFallback
+          let listSimple =
+                execRebuild srcdir (needElaboratedConfiguredPackage pkg)
+              listSdist =
+                fmap (map monitorFileHashed) $
+                    allPackageSourceFiles verbosity scriptOptions srcdir
+              ifNullThen m m' = do xs <- m
+                                   if null xs then m' else return xs
+          monitors <- case PD.buildType (elabPkgDescription pkg) of
+            Just Simple -> listSimple
+            -- If a Custom setup was used, AND the Cabal is recent
+            -- enough to have sdist --list-sources, use that to
+            -- determine the files that we need to track.  This can
+            -- cause unnecessary rebuilding (for example, if README
+            -- is edited, we will try to rebuild) but there isn't
+            -- a more accurate Custom interface we can use to get
+            -- this info.  We prefer not to use listSimple here
+            -- as it can miss extra source files that are considered
+            -- by the Custom setup.
+            _ | elabSetupScriptCliVersion pkg >= mkVersion [1,17]
+              -- However, sometimes sdist --list-sources will fail
+              -- and return an empty list.  In that case, fall
+              -- back on the (inaccurate) simple tracking.
+              -> listSdist `ifNullThen` listSimple
+              | otherwise
+              -> listSimple
 
           updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp
                                         pkg buildStatus
-                                        allSrcFiles buildResult
+                                        monitors buildResult
 
         -- PURPOSELY omitted: no copy!
 

cabal-install/Distribution/Client/RebuildMonad.hs

@@ -12,6 +12,7 @@ module Distribution.Client.RebuildMonad (
     -- * Rebuild monad
     Rebuild,
     runRebuild,
+    execRebuild,
     askRoot,
 
     -- * Setting up file monitoring
@@ -44,6 +45,12 @@ module Distribution.Client.RebuildMonad (
     getDirectoryContentsMonitored,
     createDirectoryMonitored,
     monitorDirectoryStatus,
+    doesFileExistMonitored,
+    need,
+    needIfExists,
+    findFileWithExtensionMonitored,
+    findFirstFileMonitored,
+    findFileMonitored,
   ) where
 
 import Prelude ()
@@ -58,7 +65,7 @@ import Distribution.Verbosity    (Verbosity)
 
 import Control.Monad.State as State
 import Control.Monad.Reader as Reader
-import System.FilePath (takeFileName)
+import System.FilePath
 import System.Directory
 
 
@@ -88,6 +95,10 @@ unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) []
 runRebuild :: FilePath -> Rebuild a -> IO a
 runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) []
 
+-- | Run a 'Rebuild' IO action.
+execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath]
+execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) []
+
 -- | The root that relative paths are interpreted as being relative to.
 askRoot :: Rebuild FilePath
 askRoot = Rebuild Reader.ask
@@ -166,3 +177,58 @@ monitorDirectoryStatus dir = do
                     then monitorDirectory dir
                     else monitorNonExistentDirectory dir]
 
+-- | Like 'doesFileExist', but in the 'Rebuild' monad.  This does
+-- NOT track the contents of 'FilePath'; use 'need' in that case.
+doesFileExistMonitored :: FilePath -> Rebuild Bool
+doesFileExistMonitored f = do
+    root <- askRoot
+    exists <- liftIO $ doesFileExist (root </> f)
+    monitorFiles [if exists
+                    then monitorFileExistence f
+                    else monitorNonExistentFile f]
+    return exists
+
+-- | Monitor a single file
+need :: FilePath -> Rebuild ()
+need f = monitorFiles [monitorFileHashed f]
+
+-- | Monitor a file if it exists; otherwise check for when it
+-- gets created.  This is a bit better for recompilation avoidance
+-- because sometimes users give bad package metadata, and we don't
+-- want to repeatedly rebuild in this case (which we would if we
+-- need'ed a non-existent file).
+needIfExists :: FilePath -> Rebuild ()
+needIfExists f = do
+    root <- askRoot
+    exists <- liftIO $ doesFileExist (root </> f)
+    monitorFiles [if exists
+                    then monitorFileHashed f
+                    else monitorNonExistentFile f]
+
+-- | Like 'findFileWithExtension', but in the 'Rebuild' monad.
+findFileWithExtensionMonitored
+    :: [String]
+    -> [FilePath]
+    -> FilePath
+    -> Rebuild (Maybe FilePath)
+findFileWithExtensionMonitored extensions searchPath baseName =
+  findFirstFileMonitored id
+    [ path </> baseName <.> ext
+    | path <- nub searchPath
+    , ext <- nub extensions ]
+
+-- | Like 'findFirstFile', but in the 'Rebuild' monad.
+findFirstFileMonitored :: (a -> FilePath) -> [a] -> Rebuild (Maybe a)
+findFirstFileMonitored file = findFirst
+  where findFirst []     = return Nothing
+        findFirst (x:xs) = do exists <- doesFileExistMonitored (file x)
+                              if exists
+                                then return (Just x)
+                                else findFirst xs
+
+-- | Like 'findFile', but in the 'Rebuild' monad.
+findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath)
+findFileMonitored searchPath fileName =
+  findFirstFileMonitored id
+    [ path </> fileName
+    | path <- nub searchPath]