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.Extra
import General.String
import Development.Shake.Classes
import Development.Shake.Rules.File
import Development.Shake.FilePattern
import Development.Shake.FilePath
import Development.Shake.Types
import Development.Shake.ByteString
infix 1 &?>, &%>
newtype FilesQ = FilesQ [FileQ]
deriving (Typeable,Eq,Hashable,Binary,NFData)
newtype FilesA = FilesA [FileA]
deriving (Typeable,Eq,Hashable,Binary,NFData)
instance Show FilesA where show (FilesA xs) = unwords $ "Files" : map (drop 5 . show) xs
instance Show FilesQ where show (FilesQ xs) = unwords $ map (showQuote . show) xs
instance Rule FilesQ FilesA where
storedValue opts (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM (storedValue opts) xs
equalValue opts (FilesQ qs) (FilesA xs) (FilesA ys)
| let n = length qs in n /= length xs || n /= length ys = NotEqual
| otherwise = foldr and_ EqualCheap (zipWith3 (equalValue opts) qs xs ys)
where and_ NotEqual x = NotEqual
and_ EqualCheap x = x
and_ EqualExpensive x = if x == NotEqual then NotEqual else EqualExpensive
(&%>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()
ps &%> act
| not $ compatible ps = error $ unlines $
["All patterns to &%> must have the same number and position of // and * wildcards"] ++
["* " ++ p ++ (if compatible [p, head ps] then "" else " (incompatible)") | p <- ps]
| otherwise = do
forM_ ps $ \p ->
p %> \file -> do
_ :: FilesA <- apply1 $ FilesQ $ map (FileQ . packU_ . filepathNormalise . unpackU_ . packU . substitute (extract p file)) ps
return ()
(if all simple ps then id else priority 0.5) $
rule $ \(FilesQ xs_) -> let xs = map (unpackU . fromFileQ) 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
getFileTimes "&%>" xs_
(&?>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()
(&?>) test act = priority 0.5 $ do
let norm = toStandard . normaliseEx
let inputOutput suf inp out =
["Input" ++ suf ++ ":", " " ++ inp] ++
["Output" ++ suf ++ ":"] ++ map (" "++) out
let normTest = fmap (map norm) . test
let checkedTest x = case normTest x of
Nothing -> Nothing
Just ys | x `notElem` ys -> error $ unlines $
["Invariant broken in &?>, did not return the input (after normalisation)."] ++
inputOutput "" x ys
Just ys | bad:_ <- filter ((/= Just ys) . normTest) ys -> error $ unlines $
["Invariant broken in &?>, not equal for all arguments (after normalisation)."] ++
inputOutput "1" x ys ++
inputOutput "2" bad (fromMaybe ["Nothing"] $ normTest bad)
Just ys -> Just ys
isJust . checkedTest ?> \x -> do
_ :: FilesA <- apply1 $ FilesQ $ map (FileQ . packU_ . filepathNormalise . unpackU_ . packU) $ fromJust $ test x
return ()
rule $ \(FilesQ xs_) -> let xs@(x:_) = map (unpackU . fromFileQ) xs_ in
case checkedTest x of
Just ys | ys == xs -> Just $ do
liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs
act xs
getFileTimes "&?>" xs_
Just ys -> error $ "Error, &?> is incompatible with " ++ show xs ++ " vs " ++ show ys
Nothing -> Nothing
getFileTimes :: String -> [FileQ] -> Action FilesA
getFileTimes name xs = do
opts <- getShakeOptions
ys <- liftIO $ mapM (storedValue opts) xs
case sequence ys of
Just ys -> return $ FilesA ys
Nothing | not $ shakeCreationCheck opts -> return $ FilesA []
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 "" | (FileQ x,y) <- zip xs ys]