{-# LANGUAGE ScopedTypeVariables #-}
module Development.Shake.Internal.Derived(
copyFile', copyFileChanged,
readFile', readFileLines,
writeFile', writeFileLines, writeFileChanged,
withTempFile, withTempDir,
withTempFileWithin, withTempDirWithin,
getHashedShakeVersion,
getShakeExtra, getShakeExtraRules, addShakeExtra,
par, forP,
newResource, newThrottle, withResources,
newCache
) where
import Control.Applicative
import Control.Monad.Extra
import Control.Monad.IO.Class
import System.Directory
import System.FilePath (takeDirectory)
import System.IO
import qualified System.IO.Extra as IO
import Development.Shake.Internal.Errors
import Development.Shake.Internal.Core.Run
import Development.Shake.Internal.Core.Rules
import Development.Shake.Internal.Options
import Development.Shake.Internal.Rules.File
import qualified Data.ByteString as BS
import qualified Data.HashMap.Strict as Map
import General.Extra
import Data.List.Extra
import Data.Hashable
import Data.Typeable.Extra
import Data.Dynamic
import Prelude
getHashedShakeVersion :: [FilePath] -> IO String
getHashedShakeVersion :: [FilePath] -> IO FilePath
getHashedShakeVersion files :: [FilePath]
files = do
[Int]
hashes <- (FilePath -> IO Int) -> [FilePath] -> IO [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ByteString -> Int) -> IO ByteString -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> ByteString -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt 0) (IO ByteString -> IO Int)
-> (FilePath -> IO ByteString) -> FilePath -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
BS.readFile) [FilePath]
files
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ "hash-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> [Int] -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt 0 [Int]
hashes)
getShakeExtra :: Typeable a => Action (Maybe a)
= IO (Maybe a) -> Action (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> Action (Maybe a))
-> (ShakeOptions -> IO (Maybe a))
-> ShakeOptions
-> Action (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap TypeRep Dynamic -> IO (Maybe a)
forall a. Typeable a => HashMap TypeRep Dynamic -> IO (Maybe a)
lookupShakeExtra (HashMap TypeRep Dynamic -> IO (Maybe a))
-> (ShakeOptions -> HashMap TypeRep Dynamic)
-> ShakeOptions
-> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeOptions -> HashMap TypeRep Dynamic
shakeExtra (ShakeOptions -> Action (Maybe a))
-> Action ShakeOptions -> Action (Maybe a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Action ShakeOptions
getShakeOptions
getShakeExtraRules :: Typeable a => Rules (Maybe a)
= IO (Maybe a) -> Rules (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> Rules (Maybe a))
-> (ShakeOptions -> IO (Maybe a))
-> ShakeOptions
-> Rules (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap TypeRep Dynamic -> IO (Maybe a)
forall a. Typeable a => HashMap TypeRep Dynamic -> IO (Maybe a)
lookupShakeExtra (HashMap TypeRep Dynamic -> IO (Maybe a))
-> (ShakeOptions -> HashMap TypeRep Dynamic)
-> ShakeOptions
-> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShakeOptions -> HashMap TypeRep Dynamic
shakeExtra (ShakeOptions -> Rules (Maybe a))
-> Rules ShakeOptions -> Rules (Maybe a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Rules ShakeOptions
getShakeOptionsRules
lookupShakeExtra :: forall a . Typeable a => Map.HashMap TypeRep Dynamic -> IO (Maybe a)
mp :: HashMap TypeRep Dynamic
mp =
case TypeRep -> HashMap TypeRep Dynamic -> Maybe Dynamic
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup TypeRep
want HashMap TypeRep Dynamic
mp of
Just dyn :: Dynamic
dyn
| Just x :: a
x <- Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dyn -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
| Bool
otherwise -> FilePath
-> [(FilePath, Maybe FilePath)] -> FilePath -> IO (Maybe a)
forall a.
FilePath -> [(FilePath, Maybe FilePath)] -> FilePath -> IO a
errorStructured
"shakeExtra value is malformed, all keys and values must agree"
[("Key", FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ TypeRep -> FilePath
forall a. Show a => a -> FilePath
show TypeRep
want)
,("Value", FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ TypeRep -> FilePath
forall a. Show a => a -> FilePath
show (TypeRep -> FilePath) -> TypeRep -> FilePath
forall a b. (a -> b) -> a -> b
$ Dynamic -> TypeRep
dynTypeRep Dynamic
dyn)]
"Use addShakeExtra to ensure shakeExtra is well-formed"
Nothing -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
where want :: TypeRep
want = Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
addShakeExtra :: Typeable a => a -> Map.HashMap TypeRep Dynamic -> Map.HashMap TypeRep Dynamic
x :: a
x = TypeRep
-> Dynamic -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
x) (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
x)
copyFile' :: FilePath -> FilePath -> Action ()
copyFile' :: FilePath -> FilePath -> Action ()
copyFile' old :: FilePath
old new :: FilePath
new = do
[FilePath] -> Action ()
need [FilePath
old]
FilePath -> Action ()
putLoud (FilePath -> Action ()) -> FilePath -> Action ()
forall a b. (a -> b) -> a -> b
$ "Copying from " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
old FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
new
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> IO ()
createDirectoryRecursive (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
new
FilePath -> FilePath -> IO ()
copyFile FilePath
old FilePath
new
copyFileChanged :: FilePath -> FilePath -> Action ()
copyFileChanged :: FilePath -> FilePath -> Action ()
copyFileChanged old :: FilePath
old new :: FilePath
new = do
[FilePath] -> Action ()
need [FilePath
old]
Action Bool -> Action () -> Action ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (IO Bool -> Action Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Action Bool) -> IO Bool -> Action Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
new IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ FilePath -> FilePath -> IO Bool
IO.fileEq FilePath
old FilePath
new) (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> Action ()
putLoud (FilePath -> Action ()) -> FilePath -> Action ()
forall a b. (a -> b) -> a -> b
$ "Copying from " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
old FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
new
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> IO ()
createDirectoryRecursive (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
new
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
copyFile FilePath
old FilePath
new
readFile' :: FilePath -> Action String
readFile' :: FilePath -> Action FilePath
readFile' x :: FilePath
x = [FilePath] -> Action ()
need [FilePath
x] Action () -> Action FilePath -> Action FilePath
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO FilePath -> Action FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO FilePath
readFile FilePath
x)
writeFile' :: MonadIO m => FilePath -> String -> m ()
writeFile' :: FilePath -> FilePath -> m ()
writeFile' name :: FilePath
name x :: FilePath
x = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> IO ()
createDirectoryRecursive (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
name
FilePath -> FilePath -> IO ()
writeFile FilePath
name FilePath
x
readFileLines :: FilePath -> Action [String]
readFileLines :: FilePath -> Action [FilePath]
readFileLines = (FilePath -> [FilePath]) -> Action FilePath -> Action [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> [FilePath]
lines (Action FilePath -> Action [FilePath])
-> (FilePath -> Action FilePath) -> FilePath -> Action [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Action FilePath
readFile'
writeFileLines :: MonadIO m => FilePath -> [String] -> m ()
writeFileLines :: FilePath -> [FilePath] -> m ()
writeFileLines name :: FilePath
name = FilePath -> FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> FilePath -> m ()
writeFile' FilePath
name (FilePath -> m ())
-> ([FilePath] -> FilePath) -> [FilePath] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unlines
writeFileChanged :: MonadIO m => FilePath -> String -> m ()
writeFileChanged :: FilePath -> FilePath -> m ()
writeFileChanged name :: FilePath
name x :: FilePath
x = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> IO ()
createDirectoryRecursive (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
name
Bool
b <- FilePath -> IO Bool
doesFileExist FilePath
name
if Bool -> Bool
not Bool
b then FilePath -> FilePath -> IO ()
writeFile FilePath
name FilePath
x else do
Bool
b <- FilePath -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
name IOMode
ReadMode ((Handle -> IO Bool) -> IO Bool) -> (Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
FilePath
src <- Handle -> IO FilePath
hGetContents Handle
h
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! FilePath
src FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
x
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
writeFile FilePath
name FilePath
x
withTempFile :: (FilePath -> Action a) -> Action a
withTempFile :: (FilePath -> Action a) -> Action a
withTempFile act :: FilePath -> Action a
act = do
(file :: FilePath
file, del :: IO ()
del) <- IO (FilePath, IO ()) -> Action (FilePath, IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (FilePath, IO ())
IO.newTempFile
FilePath -> Action a
act FilePath
file Action a -> IO () -> Action a
forall a b. Action a -> IO b -> Action a
`actionFinally` IO ()
del
withTempFileWithin :: FilePath -> (FilePath -> Action a) -> Action a
withTempFileWithin :: FilePath -> (FilePath -> Action a) -> Action a
withTempFileWithin tdir :: FilePath
tdir act :: FilePath -> Action a
act = do
(file :: FilePath
file, del :: IO ()
del) <- IO (FilePath, IO ()) -> Action (FilePath, IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FilePath, IO ()) -> Action (FilePath, IO ()))
-> IO (FilePath, IO ()) -> Action (FilePath, IO ())
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (FilePath, IO ())
IO.newTempFileWithin FilePath
tdir
FilePath -> Action a
act FilePath
file Action a -> IO () -> Action a
forall a b. Action a -> IO b -> Action a
`actionFinally` IO ()
del
withTempDir :: (FilePath -> Action a) -> Action a
withTempDir :: (FilePath -> Action a) -> Action a
withTempDir act :: FilePath -> Action a
act = do
(dir :: FilePath
dir,del :: IO ()
del) <- IO (FilePath, IO ()) -> Action (FilePath, IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (FilePath, IO ())
IO.newTempDir
FilePath -> Action a
act FilePath
dir Action a -> IO () -> Action a
forall a b. Action a -> IO b -> Action a
`actionFinally` IO ()
del
withTempDirWithin :: FilePath -> (FilePath -> Action a) -> Action a
withTempDirWithin :: FilePath -> (FilePath -> Action a) -> Action a
withTempDirWithin tdir :: FilePath
tdir act :: FilePath -> Action a
act = do
(dir :: FilePath
dir,del :: IO ()
del) <- IO (FilePath, IO ()) -> Action (FilePath, IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FilePath, IO ()) -> Action (FilePath, IO ()))
-> IO (FilePath, IO ()) -> Action (FilePath, IO ())
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (FilePath, IO ())
IO.newTempDirWithin FilePath
tdir
FilePath -> Action a
act FilePath
dir Action a -> IO () -> Action a
forall a b. Action a -> IO b -> Action a
`actionFinally` IO ()
del
forP :: [a] -> (a -> Action b) -> Action [b]
forP :: [a] -> (a -> Action b) -> Action [b]
forP xs :: [a]
xs f :: a -> Action b
f = [Action b] -> Action [b]
forall a. [Action a] -> Action [a]
parallel ([Action b] -> Action [b]) -> [Action b] -> Action [b]
forall a b. (a -> b) -> a -> b
$ (a -> Action b) -> [a] -> [Action b]
forall a b. (a -> b) -> [a] -> [b]
map a -> Action b
f [a]
xs
par :: Action a -> Action b -> Action (a,b)
par :: Action a -> Action b -> Action (a, b)
par a :: Action a
a b :: Action b
b = (\[Left a :: a
a, Right b :: b
b] -> (a
a,b
b)) ([Either a b] -> (a, b)) -> Action [Either a b] -> Action (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Action (Either a b)] -> Action [Either a b]
forall a. [Action a] -> Action [a]
parallel [a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> Action a -> Action (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action a
a, b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> Action b -> Action (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action b
b]
newResource :: String -> Int -> Rules Resource
newResource :: FilePath -> Int -> Rules Resource
newResource name :: FilePath
name mx :: Int
mx = IO Resource -> Rules Resource
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Resource -> Rules Resource) -> IO Resource -> Rules Resource
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> IO Resource
newResourceIO FilePath
name Int
mx
newThrottle :: String -> Int -> Double -> Rules Resource
newThrottle :: FilePath -> Int -> Double -> Rules Resource
newThrottle name :: FilePath
name count :: Int
count period :: Double
period = IO Resource -> Rules Resource
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Resource -> Rules Resource) -> IO Resource -> Rules Resource
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> Double -> IO Resource
newThrottleIO FilePath
name Int
count Double
period
withResources :: [(Resource, Int)] -> Action a -> Action a
withResources :: [(Resource, Int)] -> Action a -> Action a
withResources res :: [(Resource, Int)]
res act :: Action a
act
| (r :: Resource
r,i :: Int
i):_ <- ((Resource, Int) -> Bool) -> [(Resource, Int)] -> [(Resource, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (Int -> Bool)
-> ((Resource, Int) -> Int) -> (Resource, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Resource, Int) -> Int
forall a b. (a, b) -> b
snd) [(Resource, Int)]
res = FilePath -> Action a
forall a. HasCallStack => FilePath -> a
error (FilePath -> Action a) -> FilePath -> Action a
forall a b. (a -> b) -> a -> b
$ "You cannot acquire a negative quantity of " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Resource -> FilePath
forall a. Show a => a -> FilePath
show Resource
r FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ", requested " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i
| Bool
otherwise = [(Resource, [Int])] -> Action a
forall (t :: * -> *). Foldable t => [(Resource, t Int)] -> Action a
f ([(Resource, [Int])] -> Action a)
-> [(Resource, [Int])] -> Action a
forall a b. (a -> b) -> a -> b
$ [(Resource, Int)] -> [(Resource, [Int])]
forall k v. Ord k => [(k, v)] -> [(k, [v])]
groupSort [(Resource, Int)]
res
where
f :: [(Resource, t Int)] -> Action a
f [] = Action a
act
f ((r :: Resource
r,xs :: t Int
xs):rs :: [(Resource, t Int)]
rs) = Resource -> Int -> Action a -> Action a
forall a. Resource -> Int -> Action a -> Action a
withResource Resource
r (t Int -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum t Int
xs) (Action a -> Action a) -> Action a -> Action a
forall a b. (a -> b) -> a -> b
$ [(Resource, t Int)] -> Action a
f [(Resource, t Int)]
rs
newCache :: (Eq k, Hashable k) => (k -> Action v) -> Rules (k -> Action v)
newCache :: (k -> Action v) -> Rules (k -> Action v)
newCache = IO (k -> Action v) -> Rules (k -> Action v)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (k -> Action v) -> Rules (k -> Action v))
-> ((k -> Action v) -> IO (k -> Action v))
-> (k -> Action v)
-> Rules (k -> Action v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> Action v) -> IO (k -> Action v)
forall k v.
(Eq k, Hashable k) =>
(k -> Action v) -> IO (k -> Action v)
newCacheIO