Merge pull request #299 from commercialhaskell/283-test-suite-fix

Test suite overhaul

Author: chrisdone

src/Control/Concurrent/Execute.hs

@@ -11,7 +11,7 @@ module Control.Concurrent.Execute
     ) where
 
 import           Control.Applicative
-import           Control.Concurrent.Async (Concurrently (..))
+import           Control.Concurrent.Async (Concurrently (..), async)
 import           Control.Concurrent.STM
 import           Control.Exception
 import           Control.Monad            (join)
@@ -24,8 +24,7 @@ import           Stack.Types
 
 data ActionType
     = ATBuild
-    | ATInstall
-    | ATWanted
+    | ATFinal
     deriving (Show, Eq, Ord)
 data ActionId = ActionId !PackageIdentifier !ActionType
     deriving (Show, Eq, Ord)
@@ -36,15 +35,16 @@ data Action = Action
     }
 
 data ActionContext = ActionContext
-    { acRemaining :: !Int
+    { acRemaining :: !(Set ActionId)
     -- ^ Does not include the current action
     }
     deriving Show
 
 data ExecuteState = ExecuteState
     { esActions    :: TVar [Action]
     , esExceptions :: TVar [SomeException]
-    , esInAction   :: TVar Int
+    , esInAction   :: TVar (Set ActionId)
+    , esCompleted  :: TVar Int
     }
 
 data ExecuteException
@@ -58,12 +58,15 @@ instance Show ExecuteException where
 
 runActions :: Int -- ^ threads
            -> [Action]
+           -> (TVar Int -> IO ()) -- ^ progress updated
            -> IO [SomeException]
-runActions threads actions0 = do
+runActions threads actions0 withProgress = do
     es <- ExecuteState
         <$> newTVarIO actions0
         <*> newTVarIO []
+        <*> newTVarIO Set.empty
         <*> newTVarIO 0
+    _ <- async $ withProgress $ esCompleted es
     if threads <= 1
         then runActions' es
         else runConcurrently $ sequenceA_ $ replicate threads $ Concurrently $ runActions' es
@@ -87,28 +90,32 @@ runActions' ExecuteState {..} =
         case break (Set.null . actionDeps) as of
             (_, []) -> do
                 inAction <- readTVar esInAction
-                if inAction == 0
+                if Set.null inAction
                     then do
                         modifyTVar esExceptions (toException InconsistentDependencies:)
                         return $ return ()
                     else retry
             (xs, action:ys) -> do
                 let as' = xs ++ ys
                 inAction <- readTVar esInAction
-                let remaining = length as' + inAction
+                let remaining = Set.union
+                        (Set.fromList $ map actionId as')
+                        inAction
                 writeTVar esActions as'
-                modifyTVar esInAction (+ 1)
+                modifyTVar esInAction (Set.insert $ actionId action)
                 return $ mask $ \restore -> do
                     eres <- try $ restore $ actionDo action ActionContext
                         { acRemaining = remaining
                         }
                     case eres of
                         Left err -> atomically $ do
                             modifyTVar esExceptions (err:)
-                            modifyTVar esInAction (subtract 1)
+                            modifyTVar esInAction (Set.delete $ actionId action)
+                            modifyTVar esCompleted (+1)
                         Right () -> do
                             atomically $ do
-                                modifyTVar esInAction (subtract 1)
+                                modifyTVar esInAction (Set.delete $ actionId action)
+                                modifyTVar esCompleted (+1)
                                 let dropDep a = a { actionDeps = Set.delete (actionId action) $ actionDeps a }
                                 modifyTVar esActions $ map dropDep
                             restore loop

src/Stack/Build.hs

@@ -62,7 +62,7 @@ build bopts = do
         constructPlan mbp baseConfigOpts locals extraToBuild locallyRegistered loadPackage sourceMap installedMap
 
     if boptsDryrun bopts
-        then printPlan plan
+        then printPlan (boptsFinalAction bopts) plan
         else executePlan menv bopts baseConfigOpts locals plan
   where
     profiling = boptsLibProfile bopts || boptsExeProfile bopts

src/Stack/Build/Cache.hs

@@ -6,6 +6,7 @@
 module Stack.Build.Cache
     ( tryGetBuildCache
     , tryGetConfigCache
+    , tryGetCabalMod
     , getPackageFileModTimes
     , getInstalledExes
     , buildCacheTimes
@@ -15,6 +16,7 @@ module Stack.Build.Cache
     , writeFlagCache
     , writeBuildCache
     , writeConfigCache
+    , writeCabalMod
     ) where
 
 import           Control.Exception.Enclosed (handleIO, tryIO)
@@ -25,16 +27,12 @@ import           Control.Monad.Logger (MonadLogger)
 import           Control.Monad.Reader
 import           Data.Binary (Binary)
 import qualified Data.Binary as Binary
-import           Data.ByteString (ByteString)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
 import           Data.Map (Map)
 import qualified Data.Map as Map
 import           Data.Maybe (catMaybes, mapMaybe)
-import           Data.Set (Set)
 import qualified Data.Set as Set
-import           Data.Text (Text)
-import           Data.Text.Encoding (encodeUtf8)
 import           GHC.Generics (Generic)
 import           Path
 import           Path.IO
@@ -93,6 +91,11 @@ tryGetConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m,
                   => Path Abs Dir -> m (Maybe ConfigCache)
 tryGetConfigCache = tryGetCache configCacheFile
 
+-- | Try to read the mod time of the cabal file from the last build
+tryGetCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
+               => Path Abs Dir -> m (Maybe ModTime)
+tryGetCabalMod = tryGetCache configCabalMod
+
 -- | Try to load a cache.
 tryGetCache :: (MonadIO m, Binary a, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
             => (Path Abs Dir -> m (Path Abs File))
@@ -124,32 +127,25 @@ writeBuildCache dir times =
 -- | Write the dirtiness cache for this package's configuration.
 writeConfigCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
                 => Path Abs Dir
-                -> [Text]
-                -> Set GhcPkgId -- ^ dependencies
-                -> Path Abs file
-                -> TaskType
+                -> ConfigCache
                 -> m ()
-writeConfigCache dir opts deps cabalfp ttype =
-    do now <- liftIO (getModificationTime (toFilePath cabalfp))
-       let cache = ConfigCache
-                   { configCacheOpts = map encodeUtf8 opts
-                   , configCacheDeps = deps
-                   , configCabalFileModTime =
-                         case ttype of
-                           TTLocal lp _ | lpWanted lp -> Just (modTime now)
-                           _ -> Nothing
-                   }
-       writeCache
-           dir
-           configCacheFile
-           cache
+writeConfigCache dir = writeCache dir configCacheFile
+
+-- | See 'tryGetCabalMod'
+writeCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
+              => Path Abs Dir
+              -> ModTime
+              -> m ()
+writeCabalMod dir = writeCache dir configCabalMod
 
 -- | Delete the caches for the project.
 deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m, HasEnvConfig env)
              => Path Abs Dir -> m ()
 deleteCaches dir = do
+    {- FIXME confirm that this is acceptable to remove
     bfp <- buildCacheFile dir
     removeFileIfExists bfp
+    -}
     cfp <- configCacheFile dir
     removeFileIfExists cfp
 
@@ -167,16 +163,19 @@ writeCache dir get' content = do
              (Binary.encode content))
 
 flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasBuildConfig env)
-              => GhcPkgId
+              => Installed
               -> m (Path Abs File)
-flagCacheFile gid = do
-    rel <- parseRelFile $ ghcPkgIdString gid
+flagCacheFile installed = do
+    rel <- parseRelFile $
+        case installed of
+            Library gid -> ghcPkgIdString gid
+            Executable ident -> packageIdentifierString ident
     dir <- flagCacheLocal
     return $ dir </> rel
 
 -- | Loads the flag cache for the given installed extra-deps
 tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasBuildConfig env)
-                => GhcPkgId
+                => Installed
                 -> m (Maybe ConfigCache)
 tryGetFlagCache gid = do
     file <- flagCacheFile gid
@@ -186,22 +185,11 @@ tryGetFlagCache gid = do
         _ -> return Nothing
 
 writeFlagCache :: (MonadIO m, MonadReader env m, HasBuildConfig env, MonadThrow m)
-               => GhcPkgId
-               -> [ByteString]
-               -> Set GhcPkgId
-               -> Path Abs File
-               -> TaskType
+               => Installed
+               -> ConfigCache
                -> m ()
-writeFlagCache gid flags deps cabalfp ttype = do
+writeFlagCache gid cache = do
     file <- flagCacheFile gid
-    now <- liftIO $ getModificationTime (toFilePath cabalfp)
-    let cache = ConfigCache
-                              { configCacheOpts = flags
-                              , configCacheDeps = deps
-                              , configCabalFileModTime = case ttype of
-                                                           TTLocal lp _ | lpWanted lp -> Just (modTime now)
-                                                           _ -> Nothing
-                              }
     liftIO $ do
         createDirectoryIfMissing True $ toFilePath $ parent file