{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns, RecordWildCards, FlexibleInstances, TypeFamilies, ConstraintKinds #-}
module Development.Shake.Internal.Rules.File(
need, needHasChanged, needBS, needed, neededBS, want,
trackRead, trackWrite, trackAllow,
defaultRuleFile,
(%>), (|%>), (?>), phony, (~>), phonys,
resultHasChanged,
FileQ(..), FileA(..), fileStoredValue, fileEqualValue, EqualCost(..), fileForward
) where
import Control.Applicative
import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.Typeable.Extra
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as BS
import qualified Data.HashSet as Set
import Foreign.Storable
import Data.Word
import Data.Monoid
import General.Binary
import General.Extra
import Development.Shake.Internal.Core.Types hiding (Result, result)
import Development.Shake.Internal.Core.Rules
import Development.Shake.Internal.Core.Build
import Development.Shake.Internal.Core.Action
import Development.Shake.Internal.FileName
import Development.Shake.Internal.Rules.Rerun
import Development.Shake.Classes
import Development.Shake.FilePath(toStandard)
import Development.Shake.Internal.FilePattern
import Development.Shake.Internal.FileInfo
import Development.Shake.Internal.Options
import Development.Shake.Internal.Errors
import System.FilePath(takeDirectory)
import System.IO.Unsafe(unsafeInterleaveIO)
import Prelude
infix 1 %>, ?>, |%>, ~>
type instance RuleResult FileQ = FileR
newtype FileQ = FileQ {fromFileQ :: FileName}
deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)
data FileA = FileA {-# UNPACK #-} !ModTime {-# UNPACK #-} !FileSize FileHash
deriving (Typeable)
data FileR = FileR { result :: !(Maybe FileA)
, useLint :: !Bool
, hasChanged :: !Bool
}
deriving (Typeable)
data Mode
= ModePhony (Action ())
| ModeDirect (Action ())
| ModeForward (Action (Maybe FileA))
data Result
= ResultPhony
| ResultDirect Ver FileA
| ResultForward Ver FileA
data FileRule = FileRule String (FilePath -> Maybe Mode)
deriving Typeable
instance Show FileQ where show (FileQ x) = fileNameToString x
instance BinaryEx [FileQ] where
putEx = putEx . map fromFileQ
getEx = map FileQ . getEx
instance NFData FileA where
rnf (FileA a b c) = rnf a `seq` rnf b `seq` rnf c
instance NFData FileR where
rnf (FileR a b c) = rnf a `seq` rnf b `seq` rnf c
instance Show FileA where
show (FileA m s h) = "File {mod=" ++ show m ++ ",size=" ++ show s ++ ",digest=" ++ show h ++ "}"
instance Show FileR where
show FileR{..} = show result ++ if hasChanged then " recomputed" else " not recomputed"
instance Storable FileA where
sizeOf _ = 4 * 3
alignment _ = alignment (undefined :: ModTime)
peekByteOff p i = FileA <$> peekByteOff p i <*> peekByteOff p (i+4) <*> peekByteOff p (i+8)
pokeByteOff p i (FileA a b c) = pokeByteOff p i a >> pokeByteOff p (i+4) b >> pokeByteOff p (i+8) c
instance BinaryEx FileA where
putEx = putExStorable
getEx = getExStorable
instance BinaryEx [FileA] where
putEx = putExStorableList
getEx = getExStorableList
fromResult :: Result -> Maybe FileA
fromResult ResultPhony = Nothing
fromResult (ResultDirect _ x) = Just x
fromResult (ResultForward _ x) = Just x
instance BinaryEx Result where
putEx ResultPhony = mempty
putEx (ResultDirect ver x) = putExStorable ver <> putEx x
putEx (ResultForward ver x) = putEx (0 :: Word8) <> putExStorable ver <> putEx x
getEx x = case BS.length x of
0 -> ResultPhony
i -> if i == sz then f ResultDirect x else f ResultForward $ BS.tail x
where
sz = sizeOf (undefined :: Ver) + sizeOf (undefined :: FileA)
f ctor x = let (a,b) = binarySplit x in ctor a $ getEx b
data EqualCost
= EqualCheap
| EqualExpensive
| NotEqual
deriving (Eq,Ord,Show,Read,Typeable,Enum,Bounded)
fileStoredValue :: ShakeOptions -> FileQ -> IO (Maybe FileA)
fileStoredValue ShakeOptions{shakeChange=c} (FileQ x) = do
res <- getFileInfo x
case res of
Nothing -> return Nothing
Just (time,size) | c == ChangeModtime -> return $ Just $ FileA time size noFileHash
Just (time,size) -> do
hash <- unsafeInterleaveIO $ getFileHash x
return $ Just $ FileA time size hash
fileEqualValue :: ShakeOptions -> FileA -> FileA -> EqualCost
fileEqualValue ShakeOptions{shakeChange=c} (FileA x1 x2 x3) (FileA y1 y2 y3) = case c of
ChangeModtime -> bool $ x1 == y1
ChangeDigest -> bool $ x2 == y2 && x3 == y3
ChangeModtimeOrDigest -> bool $ x1 == y1 && x2 == y2 && x3 == y3
_ | x1 == y1 -> EqualCheap
| x2 == y2 && x3 == y3 -> EqualExpensive
| otherwise -> NotEqual
where bool b = if b then EqualCheap else NotEqual
storedValueError :: ShakeOptions -> Bool -> String -> FileQ -> IO (Maybe FileA)
storedValueError opts input msg x = maybe def Just <$> fileStoredValue opts2 x
where def = if shakeCreationCheck opts || input then error err else Nothing
err = msg ++ "\n " ++ fileNameToString (fromFileQ x)
opts2 = if not input && shakeChange opts == ChangeModtimeAndDigestInput then opts{shakeChange=ChangeModtime} else opts
defaultRuleFile :: Rules ()
defaultRuleFile = do
opts@ShakeOptions{..} <- getShakeOptionsRules
addBuiltinRuleEx (ruleLint opts) (ruleIdentity opts) (ruleRun opts $ shakeRebuildApply opts)
ruleLint :: ShakeOptions -> BuiltinLint FileQ FileR
ruleLint opts k (FileR (Just v) True _) = do
now <- fileStoredValue opts k
return $ case now of
Nothing -> Just "<missing>"
Just now | fileEqualValue opts v now == EqualCheap -> Nothing
| otherwise -> Just $ show now
ruleLint _ _ _ = return Nothing
ruleIdentity :: ShakeOptions -> BuiltinIdentity FileQ FileR
ruleIdentity opts | shakeChange opts == ChangeModtime = throwImpure errorNoHash
ruleIdentity _ = \k v -> case result v of
Just (FileA _ size hash) -> runBuilder $ putExStorable size <> putExStorable hash
Nothing -> throwImpure $ errorInternal $ "File.ruleIdentity has no result for " ++ show k
ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FileQ FileR
ruleRun opts@ShakeOptions{..} rebuildFlags o@(FileQ (fileNameToString -> xStr)) oldBin@(fmap getEx -> old :: Maybe Result) mode = do
let r = rebuildFlags xStr
(ruleVer, ruleAct, ruleErr) <- getUserRuleInternal o (\(FileRule s _) -> Just s) $ \(FileRule _ f) -> f xStr
let verEq v = Just v == ruleVer || case ruleAct of [] -> v == Ver 0; [(v2,_)] -> v == Ver v2; _ -> False
let rebuild = do
putWhen Chatty $ "# " ++ show o
case ruleAct of
[] -> rebuildWith Nothing
[x] -> rebuildWith $ Just x
_ -> throwM ruleErr
case old of
_ | r == RebuildNow -> rebuild
_ | r == RebuildLater -> case old of
Just _ ->
unLint <$> retOld ChangedNothing
Nothing -> do
now <- liftIO $ fileStoredValue opts o
case now of
Nothing -> rebuild
Just now -> do alwaysRerun; retNew ChangedStore $ ResultDirect (Ver 0) now
Just (ResultDirect ver old) | mode == RunDependenciesSame, verEq ver -> do
now <- liftIO $ fileStoredValue opts o
let noHash (FileA _ _ x) = isNoFileHash x
case now of
Nothing -> rebuild
Just now -> case fileEqualValue opts old now of
NotEqual ->
rebuild
EqualCheap | if noHash old then shakeChange == ChangeModtimeAndDigestInput || noHash now else True ->
retOld ChangedNothing
_ ->
retNew ChangedStore $ ResultDirect ver now
Just (ResultForward ver _) | verEq ver, mode == RunDependenciesSame -> retOld ChangedNothing
_ -> rebuild
where
fileR (ResultDirect _ x) = FileR (Just x) True
fileR (ResultForward _ x) = FileR (Just x) False
fileR ResultPhony = FileR Nothing False
unLint (RunResult a b c) = RunResult a b c{useLint = False}
retNew :: RunChanged -> Result -> Action (RunResult FileR)
retNew c v = return $ RunResult c (runBuilder $ putEx v) $ fileR v (c == ChangedRecomputeDiff)
retOld :: RunChanged -> Action (RunResult FileR)
retOld c = return $ RunResult c (fromJust oldBin) $ fileR (fromJust old) False
rebuildWith act = do
let answer ctor new = do
let b = case () of
_ | Just old <- old
, Just old <- fromResult old
, fileEqualValue opts old new /= NotEqual -> ChangedRecomputeSame
_ -> ChangedRecomputeDiff
retNew b $ ctor new
case act of
Nothing -> do
new <- liftIO $ storedValueError opts True "Error, file does not exist and no rule available:" o
answer (ResultDirect $ Ver 0) $ fromJust new
Just (ver, ModeForward act) -> do
new <- act
case new of
Nothing -> do
alwaysRerun
retNew ChangedRecomputeDiff ResultPhony
Just new -> answer (ResultForward $ Ver ver) new
Just (ver, ModeDirect act) -> do
cache <- historyLoad ver
case cache of
Just encodedHash -> do
Just (FileA mod size _) <- liftIO $ storedValueError opts False "Error, restored the rule but did not produce file:" o
answer (ResultDirect $ Ver ver) $ FileA mod size $ getExStorable encodedHash
Nothing -> do
act
new <- liftIO $ storedValueError opts False "Error, rule finished running but did not produce file:" o
case new of
Nothing -> retNew ChangedRecomputeDiff ResultPhony
Just new@(FileA _ _ fileHash) -> do
producesUnchecked [xStr]
res <- answer (ResultDirect $ Ver ver) new
historySave ver $ runBuilder $
if isNoFileHash fileHash then throwImpure errorNoHash else putExStorable fileHash
return res
Just (_, ModePhony act) -> do
alwaysRerun
act
retNew ChangedRecomputeDiff ResultPhony
apply_ :: Partial => (a -> FileName) -> [a] -> Action [FileR]
apply_ f = apply . map (FileQ . f)
resultHasChanged :: FilePath -> Action Bool
resultHasChanged file = do
let filename = FileQ $ fileNameFromString file
res <- getDatabaseValue filename
old <- return $ case res of
Nothing -> Nothing
Just (Left bs) -> fromResult $ getEx bs
Just (Right v) -> result v
case old of
Nothing -> return True
Just old -> do
opts <- getShakeOptions
new <- liftIO $ fileStoredValue opts filename
return $ case new of
Nothing -> True
Just new -> fileEqualValue opts old new == NotEqual
fileForward :: String -> (FilePath -> Maybe (Action (Maybe FileA))) -> Rules ()
fileForward help act = addUserRule $ FileRule help $ fmap ModeForward . act
need :: Partial => [FilePath] -> Action ()
need = withFrozenCallStack $ void . apply_ fileNameFromString
needHasChanged :: Partial => [FilePath] -> Action [FilePath]
needHasChanged paths = withFrozenCallStack $ do
res <- apply_ fileNameFromString paths
return [a | (a,b) <- zip paths res, hasChanged b]
needBS :: Partial => [BS.ByteString] -> Action ()
needBS = withFrozenCallStack $ void . apply_ fileNameFromByteString
needed :: Partial => [FilePath] -> Action ()
needed xs = withFrozenCallStack $ do
opts <- getShakeOptions
if isNothing $ shakeLint opts then need xs else neededCheck $ map fileNameFromString xs
neededBS :: Partial => [BS.ByteString] -> Action ()
neededBS xs = withFrozenCallStack $ do
opts <- getShakeOptions
if isNothing $ shakeLint opts then needBS xs else neededCheck $ map fileNameFromByteString xs
neededCheck :: Partial => [FileName] -> Action ()
neededCheck xs = withFrozenCallStack $ do
opts <- getShakeOptions
pre <- liftIO $ mapM (fileStoredValue opts . FileQ) xs
post <- apply_ id xs
let bad = [ (x, if isJust a then "File change" else "File created")
| (x, a, FileR (Just b) _ _) <- zip3 xs pre post, maybe NotEqual (\a -> fileEqualValue opts a b) a == NotEqual]
case bad of
[] -> return ()
(file,msg):_ -> throwM $ errorStructured
"Lint checking error - 'needed' file required rebuilding"
[("File", Just $ fileNameToString file)
,("Error",Just msg)]
""
trackRead :: [FilePath] -> Action ()
trackRead = lintTrackRead . map (FileQ . fileNameFromString)
trackWrite :: [FilePath] -> Action ()
trackWrite = lintTrackWrite . map (FileQ . fileNameFromString)
trackAllow :: [FilePattern] -> Action ()
trackAllow ps = lintTrackAllow $ \(FileQ x) -> any (?== fileNameToString x) ps
want :: Partial => [FilePath] -> Rules ()
want [] = return ()
want xs = withFrozenCallStack $ action $ need xs
root :: String -> (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()
root help test act = addUserRule $ FileRule help $ \x -> if not $ test x then Nothing else Just $ ModeDirect $ do
liftIO $ createDirectoryRecursive $ takeDirectory x
act x
phony :: Located => String -> Action () -> Rules ()
phony oname@(toStandard -> name) act =
addPhony ("phony " ++ show oname ++ " at " ++ callStackTop) $ \s -> if s == name then Just act else Nothing
phonys :: Located => (String -> Maybe (Action ())) -> Rules ()
phonys = addPhony ("phonys at " ++ callStackTop)
(~>) :: Located => String -> Action () -> Rules ()
(~>) oname@(toStandard -> name) act =
addPhony (show oname ++ " ~> at " ++ callStackTop) $ \s -> if s == name then Just act else Nothing
addPhony :: String -> (String -> Maybe (Action ())) -> Rules ()
addPhony help act = addUserRule $ FileRule help $ fmap ModePhony . act
(?>) :: Located => (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()
(?>) test act = priority 0.5 $ root ("?> at " ++ callStackTop) test act
(|%>) :: Located => [FilePattern] -> (FilePath -> Action ()) -> Rules ()
(|%>) pats act = do
let (simp,other) = partition simple pats
case map toStandard simp of
[] -> return ()
[p] -> root help (\x -> toStandard x == p) act
ps -> let set = Set.fromList ps in root help (flip Set.member set . toStandard) act
unless (null other) $
let ps = map (?==) other in priority 0.5 $ root help (\x -> any ($ x) ps) act
where help = show pats ++ " |%> at " ++ callStackTop
(%>) :: Located => FilePattern -> (FilePath -> Action ()) -> Rules ()
(%>) test act = withFrozenCallStack $ (if simple test then id else priority 0.5) $ root (show test ++ " %> at " ++ callStackTop) (test ?==) act