Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix #5978 Handle pretty exceptions with --file-watch #5979

Merged
merged 2 commits into from
Dec 20, 2022
Merged

Fix #5978 Handle pretty exceptions with --file-watch #5979

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
4a5b13f
Add explicit import lists to Stack.FileWatch
mpilgrem Dec 20, 2022
ff1acd5
Fix #5978 Accommodate pretty exceptions with --file-watch
mpilgrem Dec 20, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 4 additions & 0 deletions ChangeLog.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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:
Expand Down
167 changes: 86 additions & 81 deletions src/Stack/FileWatch.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand All @@ -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."