{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Client.RebuildMonad
(
Rebuild
, runRebuild
, execRebuild
, askRoot
, monitorFiles
, MonitorFilePath
, monitorFile
, monitorFileHashed
, monitorNonExistentFile
, monitorDirectory
, monitorNonExistentDirectory
, monitorDirectoryExistence
, monitorFileOrDirectory
, monitorFileSearchPath
, monitorFileHashedSearchPath
, monitorFileGlob
, monitorFileGlobExistence
, RootedGlob (..)
, FilePathRoot (..)
, Glob (..)
, GlobPiece (..)
, FileMonitor (..)
, newFileMonitor
, rerunIfChanged
, delayInitSharedResource
, delayInitSharedResources
, matchFileGlob
, getDirectoryContentsMonitored
, createDirectoryMonitored
, monitorDirectoryStatus
, doesFileExistMonitored
, need
, needIfExists
, findFileWithExtensionMonitored
, findFirstFileMonitored
, findFileMonitored
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Client.FileMonitor
import Distribution.Client.Glob hiding (matchFileGlob)
import qualified Distribution.Client.Glob as Glob (matchFileGlob)
import Distribution.Simple.PreProcess.Types (Suffix (..))
import Distribution.Simple.Utils (debug)
import Control.Concurrent.MVar (MVar, modifyMVar, newMVar)
import Control.Monad.Reader as Reader
import Control.Monad.State as State
import qualified Data.Map.Strict as Map
import System.Directory
import System.FilePath
newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a)
deriving ((forall a b. (a -> b) -> Rebuild a -> Rebuild b)
-> (forall a b. a -> Rebuild b -> Rebuild a) -> Functor Rebuild
forall a b. a -> Rebuild b -> Rebuild a
forall a b. (a -> b) -> Rebuild a -> Rebuild b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Rebuild a -> Rebuild b
fmap :: forall a b. (a -> b) -> Rebuild a -> Rebuild b
$c<$ :: forall a b. a -> Rebuild b -> Rebuild a
<$ :: forall a b. a -> Rebuild b -> Rebuild a
Functor, Functor Rebuild
Functor Rebuild =>
(forall a. a -> Rebuild a)
-> (forall a b. Rebuild (a -> b) -> Rebuild a -> Rebuild b)
-> (forall a b c.
(a -> b -> c) -> Rebuild a -> Rebuild b -> Rebuild c)
-> (forall a b. Rebuild a -> Rebuild b -> Rebuild b)
-> (forall a b. Rebuild a -> Rebuild b -> Rebuild a)
-> Applicative Rebuild
forall a. a -> Rebuild a
forall a b. Rebuild a -> Rebuild b -> Rebuild a
forall a b. Rebuild a -> Rebuild b -> Rebuild b
forall a b. Rebuild (a -> b) -> Rebuild a -> Rebuild b
forall a b c. (a -> b -> c) -> Rebuild a -> Rebuild b -> Rebuild c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Rebuild a
pure :: forall a. a -> Rebuild a
$c<*> :: forall a b. Rebuild (a -> b) -> Rebuild a -> Rebuild b
<*> :: forall a b. Rebuild (a -> b) -> Rebuild a -> Rebuild b
$cliftA2 :: forall a b c. (a -> b -> c) -> Rebuild a -> Rebuild b -> Rebuild c
liftA2 :: forall a b c. (a -> b -> c) -> Rebuild a -> Rebuild b -> Rebuild c
$c*> :: forall a b. Rebuild a -> Rebuild b -> Rebuild b
*> :: forall a b. Rebuild a -> Rebuild b -> Rebuild b
$c<* :: forall a b. Rebuild a -> Rebuild b -> Rebuild a
<* :: forall a b. Rebuild a -> Rebuild b -> Rebuild a
Applicative, Applicative Rebuild
Applicative Rebuild =>
(forall a b. Rebuild a -> (a -> Rebuild b) -> Rebuild b)
-> (forall a b. Rebuild a -> Rebuild b -> Rebuild b)
-> (forall a. a -> Rebuild a)
-> Monad Rebuild
forall a. a -> Rebuild a
forall a b. Rebuild a -> Rebuild b -> Rebuild b
forall a b. Rebuild a -> (a -> Rebuild b) -> Rebuild b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Rebuild a -> (a -> Rebuild b) -> Rebuild b
>>= :: forall a b. Rebuild a -> (a -> Rebuild b) -> Rebuild b
$c>> :: forall a b. Rebuild a -> Rebuild b -> Rebuild b
>> :: forall a b. Rebuild a -> Rebuild b -> Rebuild b
$creturn :: forall a. a -> Rebuild a
return :: forall a. a -> Rebuild a
Monad, Monad Rebuild
Monad Rebuild => (forall a. IO a -> Rebuild a) -> MonadIO Rebuild
forall a. IO a -> Rebuild a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Rebuild a
liftIO :: forall a. IO a -> Rebuild a
MonadIO)
monitorFiles :: [MonitorFilePath] -> Rebuild ()
monitorFiles :: [MonitorFilePath] -> Rebuild ()
monitorFiles [MonitorFilePath]
filespecs = ReaderT FilePath (StateT [MonitorFilePath] IO) () -> Rebuild ()
forall a.
ReaderT FilePath (StateT [MonitorFilePath] IO) a -> Rebuild a
Rebuild (([MonitorFilePath] -> [MonitorFilePath])
-> ReaderT FilePath (StateT [MonitorFilePath] IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ([MonitorFilePath]
filespecs [MonitorFilePath] -> [MonitorFilePath] -> [MonitorFilePath]
forall a. [a] -> [a] -> [a]
++))
unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath])
unRebuild :: forall a. FilePath -> Rebuild a -> IO (a, [MonitorFilePath])
unRebuild FilePath
rootDir (Rebuild ReaderT FilePath (StateT [MonitorFilePath] IO) a
action) = StateT [MonitorFilePath] IO a
-> [MonitorFilePath] -> IO (a, [MonitorFilePath])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReaderT FilePath (StateT [MonitorFilePath] IO) a
-> FilePath -> StateT [MonitorFilePath] IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT FilePath (StateT [MonitorFilePath] IO) a
action FilePath
rootDir) []
runRebuild :: FilePath -> Rebuild a -> IO a
runRebuild :: forall a. FilePath -> Rebuild a -> IO a
runRebuild FilePath
rootDir (Rebuild ReaderT FilePath (StateT [MonitorFilePath] IO) a
action) = StateT [MonitorFilePath] IO a -> [MonitorFilePath] -> IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ReaderT FilePath (StateT [MonitorFilePath] IO) a
-> FilePath -> StateT [MonitorFilePath] IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT FilePath (StateT [MonitorFilePath] IO) a
action FilePath
rootDir) []
execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath]
execRebuild :: forall a. FilePath -> Rebuild a -> IO [MonitorFilePath]
execRebuild FilePath
rootDir (Rebuild ReaderT FilePath (StateT [MonitorFilePath] IO) a
action) = StateT [MonitorFilePath] IO a
-> [MonitorFilePath] -> IO [MonitorFilePath]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (ReaderT FilePath (StateT [MonitorFilePath] IO) a
-> FilePath -> StateT [MonitorFilePath] IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT FilePath (StateT [MonitorFilePath] IO) a
action FilePath
rootDir) []
askRoot :: Rebuild FilePath
askRoot :: Rebuild FilePath
askRoot = ReaderT FilePath (StateT [MonitorFilePath] IO) FilePath
-> Rebuild FilePath
forall a.
ReaderT FilePath (StateT [MonitorFilePath] IO) a -> Rebuild a
Rebuild ReaderT FilePath (StateT [MonitorFilePath] IO) FilePath
forall r (m :: * -> *). MonadReader r m => m r
Reader.ask
rerunIfChanged
:: (Binary a, Structured a, Binary b, Structured b)
=> Verbosity
-> FileMonitor a b
-> a
-> Rebuild b
-> Rebuild b
rerunIfChanged :: forall a b.
(Binary a, Structured a, Binary b, Structured b) =>
Verbosity -> FileMonitor a b -> a -> Rebuild b -> Rebuild b
rerunIfChanged Verbosity
verbosity FileMonitor a b
monitor a
key Rebuild b
action = do
rootDir <- Rebuild FilePath
askRoot
changed <- liftIO $ checkFileMonitorChanged monitor rootDir key
case changed of
MonitorUnchanged b
result [MonitorFilePath]
files -> do
IO () -> Rebuild ()
forall a. IO a -> Rebuild a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rebuild ()) -> IO () -> Rebuild ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath
"File monitor '"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
monitorName
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' unchanged."
[MonitorFilePath] -> Rebuild ()
monitorFiles [MonitorFilePath]
files
b -> Rebuild b
forall a. a -> Rebuild a
forall (m :: * -> *) a. Monad m => a -> m a
return b
result
MonitorChanged MonitorChangedReason a
reason -> do
IO () -> Rebuild ()
forall a. IO a -> Rebuild a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rebuild ()) -> IO () -> Rebuild ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath
"File monitor '"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
monitorName
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' changed: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ MonitorChangedReason a -> FilePath
forall {a}. MonitorChangedReason a -> FilePath
showReason MonitorChangedReason a
reason
startTime <- IO MonitorTimestamp -> Rebuild MonitorTimestamp
forall a. IO a -> Rebuild a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MonitorTimestamp -> Rebuild MonitorTimestamp)
-> IO MonitorTimestamp -> Rebuild MonitorTimestamp
forall a b. (a -> b) -> a -> b
$ IO MonitorTimestamp
beginUpdateFileMonitor
(result, files) <- liftIO $ unRebuild rootDir action
liftIO $
updateFileMonitor
monitor
rootDir
(Just startTime)
files
key
result
monitorFiles files
return result
where
monitorName :: FilePath
monitorName = FilePath -> FilePath
takeFileName (FileMonitor a b -> FilePath
forall a b. FileMonitor a b -> FilePath
fileMonitorCacheFile FileMonitor a b
monitor)
showReason :: MonitorChangedReason a -> FilePath
showReason (MonitoredFileChanged FilePath
file) = FilePath
"file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
file
showReason (MonitoredValueChanged a
_) = FilePath
"monitor value changed"
showReason MonitorChangedReason a
MonitorFirstRun = FilePath
"first run"
showReason MonitorChangedReason a
MonitorCorruptCache = FilePath
"invalid cache file"
delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a)
delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a)
delayInitSharedResource IO a
action = do
var <- IO (MVar (Maybe a)) -> Rebuild (MVar (Maybe a))
forall a. IO a -> Rebuild a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe a -> IO (MVar (Maybe a))
forall a. a -> IO (MVar a)
newMVar Maybe a
forall a. Maybe a
Nothing)
return (liftIO (getOrInitResource var))
where
getOrInitResource :: MVar (Maybe a) -> IO a
getOrInitResource :: MVar (Maybe a) -> IO a
getOrInitResource MVar (Maybe a)
var =
MVar (Maybe a) -> (Maybe a -> IO (Maybe a, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe a)
var ((Maybe a -> IO (Maybe a, a)) -> IO a)
-> (Maybe a -> IO (Maybe a, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \Maybe a
mx ->
case Maybe a
mx of
Just a
x -> (Maybe a, a) -> IO (Maybe a, a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x, a
x)
Maybe a
Nothing -> do
x <- IO a
action
return (Just x, x)
delayInitSharedResources
:: forall k v
. Ord k
=> (k -> IO v)
-> Rebuild (k -> Rebuild v)
delayInitSharedResources :: forall k v. Ord k => (k -> IO v) -> Rebuild (k -> Rebuild v)
delayInitSharedResources k -> IO v
action = do
var <- IO (MVar (Map k v)) -> Rebuild (MVar (Map k v))
forall a. IO a -> Rebuild a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Map k v -> IO (MVar (Map k v))
forall a. a -> IO (MVar a)
newMVar Map k v
forall k a. Map k a
Map.empty)
return (liftIO . getOrInitResource var)
where
getOrInitResource :: MVar (Map k v) -> k -> IO v
getOrInitResource :: MVar (Map k v) -> k -> IO v
getOrInitResource MVar (Map k v)
var k
k =
MVar (Map k v) -> (Map k v -> IO (Map k v, v)) -> IO v
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Map k v)
var ((Map k v -> IO (Map k v, v)) -> IO v)
-> (Map k v -> IO (Map k v, v)) -> IO v
forall a b. (a -> b) -> a -> b
$ \Map k v
m ->
case k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k v
m of
Just v
x -> (Map k v, v) -> IO (Map k v, v)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k v
m, v
x)
Maybe v
Nothing -> do
x <- k -> IO v
action k
k
let !m' = k -> v -> Map k v -> Map k v
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k v
x Map k v
m
return (m', x)
matchFileGlob :: RootedGlob -> Rebuild [FilePath]
matchFileGlob :: RootedGlob -> Rebuild [FilePath]
matchFileGlob RootedGlob
glob = do
root <- Rebuild FilePath
askRoot
monitorFiles [monitorFileGlobExistence glob]
liftIO $ Glob.matchFileGlob root glob
getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath]
getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath]
getDirectoryContentsMonitored FilePath
dir = do
exists <- FilePath -> Rebuild Bool
monitorDirectoryStatus FilePath
dir
if exists
then liftIO $ getDirectoryContents dir
else return []
createDirectoryMonitored :: Bool -> FilePath -> Rebuild ()
createDirectoryMonitored :: Bool -> FilePath -> Rebuild ()
createDirectoryMonitored Bool
createParents FilePath
dir = do
[MonitorFilePath] -> Rebuild ()
monitorFiles [FilePath -> MonitorFilePath
monitorDirectoryExistence FilePath
dir]
IO () -> Rebuild ()
forall a. IO a -> Rebuild a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rebuild ()) -> IO () -> Rebuild ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
createParents FilePath
dir
monitorDirectoryStatus :: FilePath -> Rebuild Bool
monitorDirectoryStatus :: FilePath -> Rebuild Bool
monitorDirectoryStatus FilePath
dir = do
exists <- IO Bool -> Rebuild Bool
forall a. IO a -> Rebuild a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Rebuild Bool) -> IO Bool -> Rebuild Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
dir
monitorFiles
[ if exists
then monitorDirectory dir
else monitorNonExistentDirectory dir
]
return exists
doesFileExistMonitored :: FilePath -> Rebuild Bool
doesFileExistMonitored :: FilePath -> Rebuild Bool
doesFileExistMonitored FilePath
f = do
root <- Rebuild FilePath
askRoot
exists <- liftIO $ doesFileExist (root </> f)
monitorFiles
[ if exists
then monitorFileExistence f
else monitorNonExistentFile f
]
return exists
need :: FilePath -> Rebuild ()
need :: FilePath -> Rebuild ()
need FilePath
f = [MonitorFilePath] -> Rebuild ()
monitorFiles [FilePath -> MonitorFilePath
monitorFileHashed FilePath
f]
needIfExists :: FilePath -> Rebuild ()
needIfExists :: FilePath -> Rebuild ()
needIfExists FilePath
f = do
root <- Rebuild FilePath
askRoot
exists <- liftIO $ doesFileExist (root </> f)
monitorFiles
[ if exists
then monitorFileHashed f
else monitorNonExistentFile f
]
findFileWithExtensionMonitored
:: [Suffix]
-> [FilePath]
-> FilePath
-> Rebuild (Maybe FilePath)
findFileWithExtensionMonitored :: [Suffix] -> [FilePath] -> FilePath -> Rebuild (Maybe FilePath)
findFileWithExtensionMonitored [Suffix]
extensions [FilePath]
searchPath FilePath
baseName =
(FilePath -> FilePath) -> [FilePath] -> Rebuild (Maybe FilePath)
forall a. (a -> FilePath) -> [a] -> Rebuild (Maybe a)
findFirstFileMonitored
FilePath -> FilePath
forall a. a -> a
id
[ FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
baseName FilePath -> FilePath -> FilePath
<.> FilePath
ext
| FilePath
path <- [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub [FilePath]
searchPath
, Suffix FilePath
ext <- [Suffix] -> [Suffix]
forall a. Eq a => [a] -> [a]
nub [Suffix]
extensions
]
findFirstFileMonitored :: forall a. (a -> FilePath) -> [a] -> Rebuild (Maybe a)
findFirstFileMonitored :: forall a. (a -> FilePath) -> [a] -> Rebuild (Maybe a)
findFirstFileMonitored a -> FilePath
file = [a] -> Rebuild (Maybe a)
findFirst
where
findFirst :: [a] -> Rebuild (Maybe a)
findFirst :: [a] -> Rebuild (Maybe a)
findFirst [] = Maybe a -> Rebuild (Maybe a)
forall a. a -> Rebuild a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
findFirst (a
x : [a]
xs) = do
exists <- FilePath -> Rebuild Bool
doesFileExistMonitored (a -> FilePath
file a
x)
if exists
then return (Just x)
else findFirst xs
findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath)
findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath)
findFileMonitored [FilePath]
searchPath FilePath
fileName =
(FilePath -> FilePath) -> [FilePath] -> Rebuild (Maybe FilePath)
forall a. (a -> FilePath) -> [a] -> Rebuild (Maybe a)
findFirstFileMonitored
FilePath -> FilePath
forall a. a -> a
id
[ FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
fileName
| FilePath
path <- [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub [FilePath]
searchPath
]