module Development.Shake.Rules.Files(
(?>>), (*>>)
) where
import Control.Monad
import Control.Monad.IO.Class
import Data.Maybe
import System.Directory
import Development.Shake.Core hiding (trackAllow)
import General.Base
import General.String
import Development.Shake.Classes
import Development.Shake.Rules.File
import Development.Shake.FilePattern
import Development.Shake.FileTime
import System.FilePath(takeDirectory)
infix 1 ?>>, *>>
newtype FilesQ = FilesQ [BSU]
deriving (Typeable,Eq,Hashable,Binary,NFData)
newtype FilesA = FilesA [FileTime]
deriving (Typeable,Eq,Hashable,Binary,NFData)
instance Show FilesA where show (FilesA xs) = unwords $ "FileTimeHashes" : map show xs
instance Show FilesQ where show (FilesQ xs) = unwords $ map (showQuote . unpackU) xs
instance Rule FilesQ FilesA where
storedValue _ (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM getModTimeMaybe xs
(*>>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()
ps *>> act
| not $ compatible ps = error $
"All patterns to *>> must have the same number and position of // and * wildcards\n" ++
unwords ps
| otherwise = do
forM_ ps $ \p ->
p *> \file -> do
_ :: FilesA <- apply1 $ FilesQ $ map (packU . substitute (extract p file)) ps
return ()
rule $ \(FilesQ xs_) -> let xs = map unpackU xs_ in
if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do
liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs
trackAllow xs
act xs
liftIO $ getFileTimes "*>>" xs_
(?>>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()
(?>>) test act = do
let checkedTest x = case test x of
Nothing -> Nothing
Just ys | x `elem` ys && all ((== Just ys) . test) ys -> Just ys
| otherwise -> error $ "Invariant broken in ?>> when trying on " ++ x
isJust . checkedTest ?> \x -> do
_ :: FilesA <- apply1 $ FilesQ $ map packU $ fromJust $ test x
return ()
rule $ \(FilesQ xs_) -> let xs@(x:_) = map unpackU xs_ in
case checkedTest x of
Just ys | ys == xs -> Just $ do
liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs
act xs
liftIO $ getFileTimes "?>>" xs_
Just ys -> error $ "Error, ?>> is incompatible with " ++ show xs ++ " vs " ++ show ys
Nothing -> Nothing
getFileTimes :: String -> [BSU] -> IO FilesA
getFileTimes name xs = do
ys <- mapM getModTimeMaybe xs
case sequence ys of
Just ys -> return $ FilesA ys
Nothing -> do
let missing = length $ filter isNothing ys
error $ "Error, " ++ name ++ " rule failed to build " ++ show missing ++
" file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++
concat ["\n " ++ unpackU x ++ if isNothing y then " - MISSING" else "" | (x,y) <- zip xs ys]