1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TupleSections #-}
4module Stack.FileWatch
5    ( fileWatch
6    , fileWatchPoll
7    ) where
8
9import Control.Concurrent.STM (check)
10import Stack.Prelude
11import qualified Data.Map.Strict as Map
12import qualified Data.Set as Set
13import GHC.IO.Exception
14import Path
15import System.FSNotify
16import System.IO (getLine)
17import RIO.PrettyPrint hiding (line)
18
19fileWatch
20  :: (HasLogFunc env, HasTerm env)
21  => ((Set (Path Abs File) -> IO ()) -> RIO env ())
22  -> RIO env ()
23fileWatch = fileWatchConf defaultConfig
24
25fileWatchPoll
26  :: (HasLogFunc env, HasTerm env)
27  => ((Set (Path Abs File) -> IO ()) -> RIO env ())
28  -> RIO env ()
29fileWatchPoll = fileWatchConf $ defaultConfig { confUsePolling = True }
30
31-- | Run an action, watching for file changes
32--
33-- The action provided takes a callback that is used to set the files to be
34-- watched. When any of those files are changed, we rerun the action again.
35fileWatchConf
36  :: (HasLogFunc env, HasTerm env)
37  => WatchConfig
38  -> ((Set (Path Abs File) -> IO ()) -> RIO env ())
39  -> RIO env ()
40fileWatchConf cfg inner = withRunInIO $ \run -> withManagerConf cfg $ \manager -> do
41    allFiles <- newTVarIO Set.empty
42    dirtyVar <- newTVarIO True
43    watchVar <- newTVarIO Map.empty
44
45    let onChange event = atomically $ do
46            files <- readTVar allFiles
47            when (eventPath event `Set.member` files) (writeTVar dirtyVar True)
48
49        setWatched :: Set (Path Abs File) -> IO ()
50        setWatched files = do
51            atomically $ writeTVar allFiles $ Set.map toFilePath files
52            watch0 <- readTVarIO watchVar
53            let actions = Map.mergeWithKey
54                    keepListening
55                    stopListening
56                    startListening
57                    watch0
58                    newDirs
59            watch1 <- forM (Map.toList actions) $ \(k, mmv) -> do
60                mv <- mmv
61                return $
62                    case mv of
63                        Nothing -> Map.empty
64                        Just v -> Map.singleton k v
65            atomically $ writeTVar watchVar $ Map.unions watch1
66          where
67            newDirs = Map.fromList $ map (, ())
68                    $ Set.toList
69                    $ Set.map parent files
70
71            keepListening _dir listen () = Just $ return $ Just listen
72            stopListening = Map.map $ \f -> do
73                () <- f `catch` \ioe ->
74                    -- Ignore invalid argument error - it can happen if
75                    -- the directory is removed.
76                    case ioe_type ioe of
77                        InvalidArgument -> return ()
78                        _ -> throwIO ioe
79                return Nothing
80            startListening = Map.mapWithKey $ \dir () -> do
81                let dir' = fromString $ toFilePath dir
82                listen <- watchDir manager dir' (const True) onChange
83                return $ Just listen
84
85    let watchInput = do
86            line <- getLine
87            unless (line == "quit") $ do
88                run $ case line of
89                    "help" -> do
90                        logInfo ""
91                        logInfo "help: display this help"
92                        logInfo "quit: exit"
93                        logInfo "build: force a rebuild"
94                        logInfo "watched: display watched files"
95                    "build" -> atomically $ writeTVar dirtyVar True
96                    "watched" -> do
97                        watch <- readTVarIO allFiles
98                        mapM_ (logInfo . fromString) (Set.toList watch)
99                    "" -> atomically $ writeTVar dirtyVar True
100                    _ -> logInfo $
101                        "Unknown command: " <>
102                        displayShow line <>
103                        ". Try 'help'"
104
105                watchInput
106
107    race_ watchInput $ run $ forever $ do
108        atomically $ do
109            dirty <- readTVar dirtyVar
110            check dirty
111
112        eres <- tryAny $ inner setWatched
113
114        -- Clear dirtiness flag after the build to avoid an infinite
115        -- loop caused by the build itself triggering dirtiness. This
116        -- could be viewed as a bug, since files changed during the
117        -- build will not trigger an extra rebuild, but overall seems
118        -- like better behavior. See
119        -- https://github.com/commercialhaskell/stack/issues/822
120        atomically $ writeTVar dirtyVar False
121
122        prettyInfo $
123          case eres of
124            Left e ->
125                let theStyle = case fromException e of
126                        Just ExitSuccess -> Good
127                        _ -> Error
128                 in style theStyle $ fromString $ show e
129            _ -> style Good "Success! Waiting for next file change."
130
131        logInfo "Type help for available commands. Press enter to force a rebuild."
132