{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns, TypeFamilies, ConstraintKinds #-}
module Development.Shake.Internal.Rules.Files(
(&?>), (&%>), defaultRuleFiles
) where
import Control.Monad
import Control.Monad.IO.Class
import Data.Maybe
import Data.List.Extra
import Data.Typeable
import General.Binary
import Development.Shake.Internal.Core.Action
import Development.Shake.Internal.Core.Types hiding (Result)
import Development.Shake.Internal.Core.Build
import Development.Shake.Internal.Core.Rules
import Development.Shake.Internal.Errors
import General.Extra
import Development.Shake.Internal.FileName
import Development.Shake.Classes
import Development.Shake.Internal.Rules.Rerun
import Development.Shake.Internal.Rules.File
import Development.Shake.Internal.FilePattern
import Development.Shake.FilePath
import Development.Shake.Internal.FileInfo
import Development.Shake.Internal.Options
import Data.Monoid
import Prelude
infix 1 &?>, &%>
type instance RuleResult FilesQ = FilesA
newtype FilesQ = FilesQ {fromFilesQ :: [FileQ]}
deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)
newtype FilesA = FilesA [FileA]
deriving (Typeable,BinaryEx,NFData)
instance Show FilesA where show (FilesA xs) = unwords $ "Files" : map (drop 5 . show) xs
instance Show FilesQ where show (FilesQ xs) = unwords $ map (wrapQuote . show) xs
data FilesRule = FilesRule String (FilesQ -> Maybe (Action FilesA))
deriving Typeable
data Result = Result Ver FilesA
instance BinaryEx Result where
putEx (Result v x) = putExStorable v <> putEx x
getEx s = let (a,b) = binarySplit s in Result a $ getEx b
filesStoredValue :: ShakeOptions -> FilesQ -> IO (Maybe FilesA)
filesStoredValue opts (FilesQ xs) = fmap FilesA . sequence <$> mapM (fileStoredValue opts) xs
filesEqualValue :: ShakeOptions -> FilesA -> FilesA -> EqualCost
filesEqualValue opts (FilesA xs) (FilesA ys)
| length xs /= length ys = NotEqual
| otherwise = foldr and_ EqualCheap $ zipWithExact (fileEqualValue opts) xs ys
where and_ NotEqual _ = NotEqual
and_ EqualCheap x = x
and_ EqualExpensive x = if x == NotEqual then NotEqual else EqualExpensive
defaultRuleFiles :: Rules ()
defaultRuleFiles = do
opts <- getShakeOptionsRules
addBuiltinRuleEx (ruleLint opts) (ruleIdentity opts) (ruleRun opts $ shakeRebuildApply opts)
ruleLint :: ShakeOptions -> BuiltinLint FilesQ FilesA
ruleLint _ _ (FilesA []) = return Nothing
ruleLint opts k v = do
now <- filesStoredValue opts k
return $ case now of
Nothing -> Just "<missing>"
Just now | filesEqualValue opts v now == EqualCheap -> Nothing
| otherwise -> Just $ show now
ruleIdentity :: ShakeOptions -> BuiltinIdentity FilesQ FilesA
ruleIdentity opts | shakeChange opts == ChangeModtime = throwImpure $ errorStructured
"Cannot use shakeChange=ChangeModTime with shakeShare" [] ""
ruleIdentity _ = \_ (FilesA files) ->
Just $ runBuilder $ putExList [putExStorable size <> putExStorable hash | FileA _ size hash <- files]
ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FilesQ FilesA
ruleRun opts rebuildFlags k o@(fmap getEx -> old :: Maybe Result) mode = do
let r = map (rebuildFlags . fileNameToString . fromFileQ) $ fromFilesQ k
(ruleVer, ruleAct, ruleErr) <- getUserRuleInternal k (\(FilesRule s _) -> Just s) $ \(FilesRule _ f) -> f k
let verEq v = Just v == ruleVer || map (Ver . fst) ruleAct == [v]
let rebuild = do
putWhen Chatty $ "# " ++ show k
case ruleAct of
[x] -> rebuildWith x
_ -> throwM ruleErr
case old of
_ | RebuildNow `elem` r -> rebuild
_ | RebuildLater `elem` r -> case old of
Just _ ->
return $ RunResult ChangedNothing (fromJust o) $ FilesA []
Nothing -> do
now <- liftIO $ filesStoredValue opts k
case now of
Nothing -> rebuild
Just now -> do alwaysRerun; return $ RunResult ChangedStore (runBuilder $ putEx $ Result (Ver 0) now) now
Just (Result ver old) | mode == RunDependenciesSame, verEq ver -> do
v <- liftIO $ filesStoredValue opts k
case v of
Just v -> case filesEqualValue opts old v of
NotEqual -> rebuild
EqualCheap -> return $ RunResult ChangedNothing (fromJust o) v
EqualExpensive -> return $ RunResult ChangedStore (runBuilder $ putEx $ Result ver v) v
Nothing -> rebuild
_ -> rebuild
where
rebuildWith (ver, act) = do
cache <- historyLoad ver
v <- case cache of
Just res ->
fmap FilesA $ forM (zipExact (getExList res) (fromFilesQ k)) $ \(bin, file) -> do
Just (FileA mod size _) <- liftIO $ fileStoredValue opts file
return $ FileA mod size $ getExStorable bin
Nothing -> do
FilesA v <- act
producesUnchecked $ map (fileNameToString . fromFileQ) $ fromFilesQ k
historySave ver $ runBuilder $ putExList
[if isNoFileHash hash then throwImpure errorNoHash else putExStorable hash | FileA _ _ hash <- v]
return $ FilesA v
let c | Just (Result _ old) <- old, filesEqualValue opts old v /= NotEqual = ChangedRecomputeSame
| otherwise = ChangedRecomputeDiff
return $ RunResult c (runBuilder $ putEx $ Result (Ver ver) v) v
(&%>) :: Located => [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()
[p] &%> act = withFrozenCallStack $ p %> act . return
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 = withFrozenCallStack $ do
forM_ (zipFrom 0 ps) $ \(i,p) ->
(if simple p then id else priority 0.5) $
fileForward (show ps ++ " &%> at " ++ callStackTop) $ let op = (p ?==) in \file -> if not $ op file then Nothing else Just $ do
FilesA res <- apply1 $ FilesQ $ map (FileQ . fileNameFromString . substitute (extract p file)) ps
return $ if null res then Nothing else Just $ res !! i
(if all simple ps then id else priority 0.5) $ do
mapM_ addTarget ps
addUserRule $ FilesRule (show ps ++ " &%> " ++ callStackTop) $ \(FilesQ xs_) -> let xs = map (fileNameToString . fromFileQ) xs_ in
if not $ length xs == length ps && and (zipWithExact (?==) ps xs) then Nothing else Just $ do
liftIO $ mapM_ createDirectoryRecursive $ nubOrd $ map takeDirectory xs
trackAllow xs
act xs
getFileTimes "&%>" xs_
(&?>) :: Located => (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()
(&?>) test act = priority 0.5 $ do
let inputOutput suf inp out =
["Input" ++ suf ++ ":", " " ++ inp] ++
["Output" ++ suf ++ ":"] ++ map (" "++) out
let normTest = fmap (map $ toStandard . normaliseEx) . 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 equalValue for all arguments (after normalisation)."] ++
inputOutput "1" x ys ++
inputOutput "2" bad (fromMaybe ["Nothing"] $ normTest bad)
Just ys -> Just ys
fileForward ("&?> at " ++ callStackTop) $ \x -> case checkedTest x of
Nothing -> Nothing
Just ys -> Just $ do
FilesA res <- apply1 $ FilesQ $ map (FileQ . fileNameFromString) ys
return $ if null res then Nothing else Just $ res !! fromJust (elemIndex x ys)
addUserRule $ FilesRule ("&?> " ++ callStackTop) $ \(FilesQ xs_) -> let xs@(x:_) = map (fileNameToString . fromFileQ) xs_ in
case checkedTest x of
Just ys | ys == xs -> Just $ do
liftIO $ mapM_ createDirectoryRecursive $ nubOrd $ 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
let opts2 = if shakeChange opts == ChangeModtimeAndDigestInput then opts{shakeChange=ChangeModtime} else opts
ys <- liftIO $ mapM (fileStoredValue opts2) 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 produce " ++ show missing ++
" file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++
concat ["\n " ++ fileNameToString x ++ if isNothing y then " - MISSING" else "" | (FileQ x,y) <- zipExact xs ys]