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