diff --git a/ChangeLog.md b/ChangeLog.md index 3d8d21d5b8..ccea38047c 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -14,6 +14,10 @@ Other enhancements: Bug fixes: +* `stack build` with `--file-watch` or `--file-watch-poll` outputs 'pretty' + error messages, as intended. See + [#5978](https://github.com/commercialhaskell/stack/issues/5978). + ## v2.9.3 Release notes: diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs index 64480c69c2..02fc574c85 100644 --- a/src/Stack/FileWatch.hs +++ b/src/Stack/FileWatch.hs @@ -12,19 +12,23 @@ import Control.Concurrent.STM ( check ) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import GHC.IO.Exception -import Path + ( IOErrorType (InvalidArgument), IOException (..) ) +import Path ( parent ) import Stack.Prelude import System.FSNotify + ( WatchConfig, WatchMode (..), confWatchMode, defaultConfig + , eventPath, watchDir, withManagerConf + ) import System.IO ( getLine ) -fileWatch - :: (HasLogFunc env, HasTerm env) +fileWatch :: + (HasLogFunc env, HasTerm env) => ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env () fileWatch = fileWatchConf defaultConfig -fileWatchPoll - :: (HasLogFunc env, HasTerm env) +fileWatchPoll :: + (HasLogFunc env, HasTerm env) => ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env () fileWatchPoll = @@ -34,100 +38,101 @@ fileWatchPoll = -- -- The action provided takes a callback that is used to set the files to be -- watched. When any of those files are changed, we rerun the action again. -fileWatchConf - :: (HasLogFunc env, HasTerm env) +fileWatchConf :: + (HasLogFunc env, HasTerm env) => WatchConfig -> ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env () -fileWatchConf cfg inner = withRunInIO $ \run -> withManagerConf cfg $ \manager -> do +fileWatchConf cfg inner = + withRunInIO $ \run -> withManagerConf cfg $ \manager -> do allFiles <- newTVarIO Set.empty dirtyVar <- newTVarIO True watchVar <- newTVarIO Map.empty let onChange event = atomically $ do - files <- readTVar allFiles - when (eventPath event `Set.member` files) (writeTVar dirtyVar True) + files <- readTVar allFiles + when (eventPath event `Set.member` files) (writeTVar dirtyVar True) setWatched :: Set (Path Abs File) -> IO () setWatched files = do - atomically $ writeTVar allFiles $ Set.map toFilePath files - watch0 <- readTVarIO watchVar - let actions = Map.mergeWithKey - keepListening - stopListening - startListening - watch0 - newDirs - watch1 <- forM (Map.toList actions) $ \(k, mmv) -> do - mv <- mmv - pure $ - case mv of - Nothing -> Map.empty - Just v -> Map.singleton k v - atomically $ writeTVar watchVar $ Map.unions watch1 - where - newDirs = Map.fromList $ map (, ()) - $ Set.toList - $ Set.map parent files + atomically $ writeTVar allFiles $ Set.map toFilePath files + watch0 <- readTVarIO watchVar + let actions = Map.mergeWithKey + keepListening + stopListening + startListening + watch0 + newDirs + watch1 <- forM (Map.toList actions) $ \(k, mmv) -> do + mv <- mmv + pure $ + case mv of + Nothing -> Map.empty + Just v -> Map.singleton k v + atomically $ writeTVar watchVar $ Map.unions watch1 + where + newDirs = Map.fromList $ map (, ()) + $ Set.toList + $ Set.map parent files - keepListening _dir listen () = Just $ pure $ Just listen - stopListening = Map.map $ \f -> do - () <- f `catch` \ioe -> - -- Ignore invalid argument error - it can happen if - -- the directory is removed. - case ioe_type ioe of - InvalidArgument -> pure () - _ -> throwIO ioe - pure Nothing - startListening = Map.mapWithKey $ \dir () -> do - let dir' = fromString $ toFilePath dir - listen <- watchDir manager dir' (const True) onChange - pure $ Just listen + keepListening _dir listen () = Just $ pure $ Just listen + stopListening = Map.map $ \f -> do + () <- f `catch` \ioe -> + -- Ignore invalid argument error - it can happen if + -- the directory is removed. + case ioe_type ioe of + InvalidArgument -> pure () + _ -> throwIO ioe + pure Nothing + startListening = Map.mapWithKey $ \dir () -> do + let dir' = fromString $ toFilePath dir + listen <- watchDir manager dir' (const True) onChange + pure $ Just listen let watchInput = do - l <- getLine - unless (l == "quit") $ do - run $ case l of - "help" -> do - logInfo "" - logInfo "help: display this help" - logInfo "quit: exit" - logInfo "build: force a rebuild" - logInfo "watched: display watched files" - "build" -> atomically $ writeTVar dirtyVar True - "watched" -> do - watch <- readTVarIO allFiles - mapM_ (logInfo . fromString) (Set.toList watch) - "" -> atomically $ writeTVar dirtyVar True - _ -> logInfo $ - "Unknown command: " <> - displayShow l <> - ". Try 'help'" + l <- getLine + unless (l == "quit") $ do + run $ case l of + "help" -> do + logInfo "" + logInfo "help: display this help" + logInfo "quit: exit" + logInfo "build: force a rebuild" + logInfo "watched: display watched files" + "build" -> atomically $ writeTVar dirtyVar True + "watched" -> do + watch <- readTVarIO allFiles + mapM_ (logInfo . fromString) (Set.toList watch) + "" -> atomically $ writeTVar dirtyVar True + _ -> logInfo $ + "Unknown command: " <> + displayShow l <> + ". Try 'help'" - watchInput + watchInput race_ watchInput $ run $ forever $ do - atomically $ do - dirty <- readTVar dirtyVar - check dirty + atomically $ do + dirty <- readTVar dirtyVar + check dirty - eres <- tryAny $ inner setWatched + eres <- tryAny $ inner setWatched - -- Clear dirtiness flag after the build to avoid an infinite - -- loop caused by the build itself triggering dirtiness. This - -- could be viewed as a bug, since files changed during the - -- build will not trigger an extra rebuild, but overall seems - -- like better behavior. See - -- https://github.com/commercialhaskell/stack/issues/822 - atomically $ writeTVar dirtyVar False + -- Clear dirtiness flag after the build to avoid an infinite loop caused + -- by the build itself triggering dirtiness. This could be viewed as a + -- bug, since files changed during the build will not trigger an extra + -- rebuild, but overall seems like better behavior. See + -- https://github.com/commercialhaskell/stack/issues/822 + atomically $ writeTVar dirtyVar False - prettyInfo $ - case eres of - Left e -> - let theStyle = case fromException e of - Just ExitSuccess -> Good - _ -> Error - in style theStyle $ fromString $ displayException e - _ -> style Good "Success! Waiting for next file change." + case eres of + Left e -> + case fromException e of + Just ExitSuccess -> + prettyInfo $ style Good $ fromString $ displayException e + _ -> case fromException e :: Maybe PrettyException of + Just pe -> prettyError $ pretty pe + _ -> prettyInfo $ style Error $ fromString $ displayException e + _ -> prettyInfo $ style Good "Success! Waiting for next file change." - logInfo "Type help for available commands. Press enter to force a rebuild." + logInfo "Type help for available commands. Press enter to force a rebuild."