{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns, TypeFamilies #-}

module Development.Shake.Internal.Rules.Files(
    (&?>), (&%>), defaultRuleFiles
    ) where

import Control.Monad
import Control.Monad.IO.Class
import Data.Maybe
import Data.List.Extra
import Control.Applicative
import Data.Typeable.Extra
import General.Binary
import Prelude

import Development.Shake.Internal.Errors
import Development.Shake.Internal.Core.Action hiding (trackAllow)
import Development.Shake.Internal.Core.Run
import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Core.Rules
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.Options


infix 1 &?>, &%>


type instance RuleResult FilesQ = FilesA

newtype FilesQ = FilesQ {FilesQ -> [FileQ]
fromFilesQ :: [FileQ]}
    deriving (Typeable,FilesQ -> FilesQ -> Bool
(FilesQ -> FilesQ -> Bool)
-> (FilesQ -> FilesQ -> Bool) -> Eq FilesQ
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FilesQ -> FilesQ -> Bool
$c/= :: FilesQ -> FilesQ -> Bool
== :: FilesQ -> FilesQ -> Bool
$c== :: FilesQ -> FilesQ -> Bool
Eq,Int -> FilesQ -> Int
FilesQ -> Int
(Int -> FilesQ -> Int) -> (FilesQ -> Int) -> Hashable FilesQ
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: FilesQ -> Int
$chash :: FilesQ -> Int
hashWithSalt :: Int -> FilesQ -> Int
$chashWithSalt :: Int -> FilesQ -> Int
Hashable,Get FilesQ
[FilesQ] -> Put
FilesQ -> Put
(FilesQ -> Put) -> Get FilesQ -> ([FilesQ] -> Put) -> Binary FilesQ
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [FilesQ] -> Put
$cputList :: [FilesQ] -> Put
get :: Get FilesQ
$cget :: Get FilesQ
put :: FilesQ -> Put
$cput :: FilesQ -> Put
Binary,ByteString -> FilesQ
FilesQ -> Builder
(FilesQ -> Builder) -> (ByteString -> FilesQ) -> BinaryEx FilesQ
forall a. (a -> Builder) -> (ByteString -> a) -> BinaryEx a
getEx :: ByteString -> FilesQ
$cgetEx :: ByteString -> FilesQ
putEx :: FilesQ -> Builder
$cputEx :: FilesQ -> Builder
BinaryEx,FilesQ -> ()
(FilesQ -> ()) -> NFData FilesQ
forall a. (a -> ()) -> NFData a
rnf :: FilesQ -> ()
$crnf :: FilesQ -> ()
NFData)

newtype FilesA = FilesA [FileA]
    deriving (Typeable,ByteString -> FilesA
FilesA -> Builder
(FilesA -> Builder) -> (ByteString -> FilesA) -> BinaryEx FilesA
forall a. (a -> Builder) -> (ByteString -> a) -> BinaryEx a
getEx :: ByteString -> FilesA
$cgetEx :: ByteString -> FilesA
putEx :: FilesA -> Builder
$cputEx :: FilesA -> Builder
BinaryEx,FilesA -> ()
(FilesA -> ()) -> NFData FilesA
forall a. (a -> ()) -> NFData a
rnf :: FilesA -> ()
$crnf :: FilesA -> ()
NFData)

instance Show FilesA where show :: FilesA -> String
show (FilesA xs :: [FileA]
xs) = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ "Files" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (FileA -> String) -> [FileA] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ShowS
forall a. Int -> [a] -> [a]
drop 5 ShowS -> (FileA -> String) -> FileA -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileA -> String
forall a. Show a => a -> String
show) [FileA]
xs

instance Show FilesQ where show :: FilesQ -> String
show (FilesQ xs :: [FileQ]
xs) = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (FileQ -> String) -> [FileQ] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS
wrapQuote ShowS -> (FileQ -> String) -> FileQ -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileQ -> String
forall a. Show a => a -> String
show) [FileQ]
xs


filesStoredValue :: ShakeOptions -> FilesQ -> IO (Maybe FilesA)
filesStoredValue :: ShakeOptions -> FilesQ -> IO (Maybe FilesA)
filesStoredValue opts :: ShakeOptions
opts (FilesQ xs :: [FileQ]
xs) = ([FileA] -> FilesA) -> Maybe [FileA] -> Maybe FilesA
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FileA] -> FilesA
FilesA (Maybe [FileA] -> Maybe FilesA)
-> ([Maybe FileA] -> Maybe [FileA])
-> [Maybe FileA]
-> Maybe FilesA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe FileA] -> Maybe [FileA]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Maybe FileA] -> Maybe FilesA)
-> IO [Maybe FileA] -> IO (Maybe FilesA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FileQ -> IO (Maybe FileA)) -> [FileQ] -> IO [Maybe FileA]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ShakeOptions -> FileQ -> IO (Maybe FileA)
fileStoredValue ShakeOptions
opts) [FileQ]
xs

filesEqualValue :: ShakeOptions -> FilesA -> FilesA -> EqualCost
filesEqualValue :: ShakeOptions -> FilesA -> FilesA -> EqualCost
filesEqualValue opts :: ShakeOptions
opts (FilesA xs :: [FileA]
xs) (FilesA ys :: [FileA]
ys)
    | [FileA] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FileA]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [FileA] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FileA]
ys = EqualCost
NotEqual
    | Bool
otherwise = (EqualCost -> EqualCost -> EqualCost)
-> EqualCost -> [EqualCost] -> EqualCost
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr EqualCost -> EqualCost -> EqualCost
and_ EqualCost
EqualCheap ([EqualCost] -> EqualCost) -> [EqualCost] -> EqualCost
forall a b. (a -> b) -> a -> b
$ (FileA -> FileA -> EqualCost) -> [FileA] -> [FileA] -> [EqualCost]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ShakeOptions -> FileA -> FileA -> EqualCost
fileEqualValue ShakeOptions
opts) [FileA]
xs [FileA]
ys
        where and_ :: EqualCost -> EqualCost -> EqualCost
and_ NotEqual x :: EqualCost
x = EqualCost
NotEqual
              and_ EqualCheap x :: EqualCost
x = EqualCost
x
              and_ EqualExpensive x :: EqualCost
x = if EqualCost
x EqualCost -> EqualCost -> Bool
forall a. Eq a => a -> a -> Bool
== EqualCost
NotEqual then EqualCost
NotEqual else EqualCost
EqualExpensive

defaultRuleFiles :: Rules ()
defaultRuleFiles :: Rules ()
defaultRuleFiles = do
    ShakeOptions
opts <- Rules ShakeOptions
getShakeOptionsRules
    -- A rule from FilesQ to FilesA. The result value is only useful for linting.
    BuiltinLint FilesQ FilesA -> BuiltinRun FilesQ FilesA -> Rules ()
forall key value.
(RuleResult key ~ value, ShakeValue key, BinaryEx key,
 Typeable value, NFData value, Show value) =>
BuiltinLint key value -> BuiltinRun key value -> Rules ()
addBuiltinRuleEx (ShakeOptions -> BuiltinLint FilesQ FilesA
ruleLint ShakeOptions
opts) (ShakeOptions -> (String -> Rebuild) -> BuiltinRun FilesQ FilesA
ruleRun ShakeOptions
opts ((String -> Rebuild) -> BuiltinRun FilesQ FilesA)
-> (String -> Rebuild) -> BuiltinRun FilesQ FilesA
forall a b. (a -> b) -> a -> b
$ ShakeOptions -> String -> Rebuild
shakeRebuildApply ShakeOptions
opts)

ruleLint :: ShakeOptions -> BuiltinLint FilesQ FilesA
ruleLint :: ShakeOptions -> BuiltinLint FilesQ FilesA
ruleLint opts :: ShakeOptions
opts k :: FilesQ
k (FilesA []) = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing -- in the case of disabling lint
ruleLint opts :: ShakeOptions
opts k :: FilesQ
k v :: FilesA
v = do
    Maybe FilesA
now <- ShakeOptions -> FilesQ -> IO (Maybe FilesA)
filesStoredValue ShakeOptions
opts FilesQ
k
    Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ case Maybe FilesA
now of
        Nothing -> String -> Maybe String
forall a. a -> Maybe a
Just "<missing>"
        Just now :: FilesA
now | ShakeOptions -> FilesA -> FilesA -> EqualCost
filesEqualValue ShakeOptions
opts FilesA
v FilesA
now EqualCost -> EqualCost -> Bool
forall a. Eq a => a -> a -> Bool
== EqualCost
EqualCheap -> Maybe String
forall a. Maybe a
Nothing
                 | Bool
otherwise -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ FilesA -> String
forall a. Show a => a -> String
show FilesA
now

ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FilesQ FilesA
ruleRun :: ShakeOptions -> (String -> Rebuild) -> BuiltinRun FilesQ FilesA
ruleRun opts :: ShakeOptions
opts rebuildFlags :: String -> Rebuild
rebuildFlags k :: FilesQ
k o :: Maybe ByteString
o@((ByteString -> FilesA) -> Maybe ByteString -> Maybe FilesA
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> FilesA
forall a. BinaryEx a => ByteString -> a
getEx -> Maybe FilesA
old) dirtyChildren :: Bool
dirtyChildren = do
    let r :: [Rebuild]
r = (FileQ -> Rebuild) -> [FileQ] -> [Rebuild]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Rebuild
rebuildFlags (String -> Rebuild) -> (FileQ -> String) -> FileQ -> Rebuild
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileName -> String
fileNameToString (FileName -> String) -> (FileQ -> FileName) -> FileQ -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileQ -> FileName
fromFileQ) ([FileQ] -> [Rebuild]) -> [FileQ] -> [Rebuild]
forall a b. (a -> b) -> a -> b
$ FilesQ -> [FileQ]
fromFilesQ FilesQ
k
    case Maybe FilesA
old of
        _ | Rebuild
RebuildNow Rebuild -> [Rebuild] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Rebuild]
r -> Action (RunResult FilesA)
rebuild
        _ | Rebuild
RebuildLater Rebuild -> [Rebuild] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Rebuild]
r -> case Maybe FilesA
old of
            Just old :: FilesA
old ->
                -- ignoring the currently stored value, which may trigger lint has changed
                -- so disable lint on this file
                RunResult FilesA -> Action (RunResult FilesA)
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult FilesA -> Action (RunResult FilesA))
-> RunResult FilesA -> Action (RunResult FilesA)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> FilesA -> RunResult FilesA
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedNothing (Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust Maybe ByteString
o) (FilesA -> RunResult FilesA) -> FilesA -> RunResult FilesA
forall a b. (a -> b) -> a -> b
$ [FileA] -> FilesA
FilesA []
            Nothing -> do
                -- i don't have a previous value, so assume this is a source node, and mark rebuild in future
                Maybe FilesA
now <- IO (Maybe FilesA) -> Action (Maybe FilesA)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilesA) -> Action (Maybe FilesA))
-> IO (Maybe FilesA) -> Action (Maybe FilesA)
forall a b. (a -> b) -> a -> b
$ ShakeOptions -> FilesQ -> IO (Maybe FilesA)
filesStoredValue ShakeOptions
opts FilesQ
k
                case Maybe FilesA
now of
                    Nothing -> Action (RunResult FilesA)
rebuild
                    Just now :: FilesA
now -> do Action ()
alwaysRerun; RunResult FilesA -> Action (RunResult FilesA)
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult FilesA -> Action (RunResult FilesA))
-> RunResult FilesA -> Action (RunResult FilesA)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> FilesA -> RunResult FilesA
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedStore (Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ FilesA -> Builder
forall a. BinaryEx a => a -> Builder
putEx FilesA
now) FilesA
now
        Just old :: FilesA
old | Bool -> Bool
not Bool
dirtyChildren -> do
            Maybe FilesA
v <- IO (Maybe FilesA) -> Action (Maybe FilesA)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilesA) -> Action (Maybe FilesA))
-> IO (Maybe FilesA) -> Action (Maybe FilesA)
forall a b. (a -> b) -> a -> b
$ ShakeOptions -> FilesQ -> IO (Maybe FilesA)
filesStoredValue ShakeOptions
opts FilesQ
k
            case Maybe FilesA
v of
                Just v :: FilesA
v -> case ShakeOptions -> FilesA -> FilesA -> EqualCost
filesEqualValue ShakeOptions
opts FilesA
old FilesA
v of
                    NotEqual -> Action (RunResult FilesA)
rebuild
                    EqualCheap -> RunResult FilesA -> Action (RunResult FilesA)
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult FilesA -> Action (RunResult FilesA))
-> RunResult FilesA -> Action (RunResult FilesA)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> FilesA -> RunResult FilesA
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedNothing (Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust Maybe ByteString
o) FilesA
v
                    EqualExpensive -> RunResult FilesA -> Action (RunResult FilesA)
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult FilesA -> Action (RunResult FilesA))
-> RunResult FilesA -> Action (RunResult FilesA)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> FilesA -> RunResult FilesA
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedStore (Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ FilesA -> Builder
forall a. BinaryEx a => a -> Builder
putEx FilesA
v) FilesA
v
                Nothing -> Action (RunResult FilesA)
rebuild
        _ -> Action (RunResult FilesA)
rebuild
    where
        rebuild :: Action (RunResult FilesA)
rebuild = do
            Verbosity -> String -> Action ()
putWhen Verbosity
Chatty (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ "# " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FilesQ -> String
forall a. Show a => a -> String
show FilesQ
k
            UserRule (FilesQ -> Maybe (Action FilesA))
rules :: UserRule (FilesQ -> Maybe (Action FilesA)) <- Action (UserRule (FilesQ -> Maybe (Action FilesA)))
forall a. Typeable a => Action (UserRule a)
getUserRules
            FilesA
v <- case UserRule (FilesQ -> Maybe (Action FilesA))
-> ((FilesQ -> Maybe (Action FilesA)) -> Maybe (Action FilesA))
-> [Action FilesA]
forall a b. UserRule a -> (a -> Maybe b) -> [b]
userRuleMatch UserRule (FilesQ -> Maybe (Action FilesA))
rules ((FilesQ -> Maybe (Action FilesA))
-> FilesQ -> Maybe (Action FilesA)
forall a b. (a -> b) -> a -> b
$ FilesQ
k) of
                [r :: Action FilesA
r] -> Action FilesA
r
                rs :: [Action FilesA]
rs  -> IO FilesA -> Action FilesA
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilesA -> Action FilesA) -> IO FilesA -> Action FilesA
forall a b. (a -> b) -> a -> b
$ TypeRep -> String -> Int -> IO FilesA
forall a. TypeRep -> String -> Int -> IO a
errorMultipleRulesMatch (FilesQ -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf FilesQ
k) (FilesQ -> String
forall a. Show a => a -> String
show FilesQ
k) ([Action FilesA] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action FilesA]
rs)
            let c :: RunChanged
c | Just old :: FilesA
old <- Maybe FilesA
old, ShakeOptions -> FilesA -> FilesA -> EqualCost
filesEqualValue ShakeOptions
opts FilesA
old FilesA
v EqualCost -> EqualCost -> Bool
forall a. Eq a => a -> a -> Bool
/= EqualCost
NotEqual = RunChanged
ChangedRecomputeSame
                    | Bool
otherwise = RunChanged
ChangedRecomputeDiff
            RunResult FilesA -> Action (RunResult FilesA)
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult FilesA -> Action (RunResult FilesA))
-> RunResult FilesA -> Action (RunResult FilesA)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> FilesA -> RunResult FilesA
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
c (Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ FilesA -> Builder
forall a. BinaryEx a => a -> Builder
putEx FilesA
v) FilesA
v



-- | Define a rule for building multiple files at the same time.
--   Think of it as the AND (@&&@) equivalent of '%>'.
--   As an example, a single invocation of GHC produces both @.hi@ and @.o@ files:
--
-- @
-- [\"*.o\",\"*.hi\"] '&%>' \\[o,hi] -> do
--     let hs = o 'Development.Shake.FilePath.-<.>' \"hs\"
--     'Development.Shake.need' ... -- all files the .hs import
--     'Development.Shake.cmd' \"ghc -c\" [hs]
-- @
--
--   However, in practice, it's usually easier to define rules with '%>' and make the @.hi@ depend
--   on the @.o@. When defining rules that build multiple files, all the 'FilePattern' values must
--   have the same sequence of @\/\/@ and @*@ wildcards in the same order.
--   This function will create directories for the result files, if necessary.
(&%>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()
[p :: String
p] &%> :: [String] -> ([String] -> Action ()) -> Rules ()
&%> act :: [String] -> Action ()
act = String
p String -> (String -> Action ()) -> Rules ()
%> [String] -> Action ()
act ([String] -> Action ())
-> (String -> [String]) -> String -> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall (m :: * -> *) a. Monad m => a -> m a
return
ps :: [String]
ps &%> act :: [String] -> Action ()
act
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
compatible [String]
ps = String -> Rules ()
forall a. HasCallStack => String -> a
error (String -> Rules ()) -> String -> Rules ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
        "All patterns to &%> must have the same number and position of // and * wildcards" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
        ["* " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if [String] -> Bool
compatible [String
p, [String] -> String
forall a. [a] -> a
head [String]
ps] then "" else " (incompatible)") | String
p <- [String]
ps]
    | Bool
otherwise = do
        [(Int, String)] -> ((Int, String) -> Rules ()) -> Rules ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [String]
ps) (((Int, String) -> Rules ()) -> Rules ())
-> ((Int, String) -> Rules ()) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \(i :: Int
i,p :: String
p) ->
            (if String -> Bool
simple String
p then Rules () -> Rules ()
forall a. a -> a
id else Double -> Rules () -> Rules ()
priority 0.5) (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$
                (String -> Maybe (Action (Maybe FileA))) -> Rules ()
fileForward ((String -> Maybe (Action (Maybe FileA))) -> Rules ())
-> (String -> Maybe (Action (Maybe FileA))) -> Rules ()
forall a b. (a -> b) -> a -> b
$ let op :: String -> Bool
op = (String
p String -> String -> Bool
?==) in \file :: String
file -> if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
op String
file then Maybe (Action (Maybe FileA))
forall a. Maybe a
Nothing else Action (Maybe FileA) -> Maybe (Action (Maybe FileA))
forall a. a -> Maybe a
Just (Action (Maybe FileA) -> Maybe (Action (Maybe FileA)))
-> Action (Maybe FileA) -> Maybe (Action (Maybe FileA))
forall a b. (a -> b) -> a -> b
$ do
                    FilesA res :: [FileA]
res <- FilesQ -> Action FilesA
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value) =>
key -> Action value
apply1 (FilesQ -> Action FilesA) -> FilesQ -> Action FilesA
forall a b. (a -> b) -> a -> b
$ [FileQ] -> FilesQ
FilesQ ([FileQ] -> FilesQ) -> [FileQ] -> FilesQ
forall a b. (a -> b) -> a -> b
$ (String -> FileQ) -> [String] -> [FileQ]
forall a b. (a -> b) -> [a] -> [b]
map (FileName -> FileQ
FileQ (FileName -> FileQ) -> (String -> FileName) -> String -> FileQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FileName
fileNameFromString (String -> FileName) -> ShowS -> String -> FileName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> ShowS
substitute (String -> String -> [String]
extract String
p String
file)) [String]
ps
                    Maybe FileA -> Action (Maybe FileA)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FileA -> Action (Maybe FileA))
-> Maybe FileA -> Action (Maybe FileA)
forall a b. (a -> b) -> a -> b
$ if [FileA] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FileA]
res then Maybe FileA
forall a. Maybe a
Nothing else FileA -> Maybe FileA
forall a. a -> Maybe a
Just (FileA -> Maybe FileA) -> FileA -> Maybe FileA
forall a b. (a -> b) -> a -> b
$ [FileA]
res [FileA] -> Int -> FileA
forall a. [a] -> Int -> a
!! Int
i
        (if (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all String -> Bool
simple [String]
ps then Rules () -> Rules ()
forall a. a -> a
id else Double -> Rules () -> Rules ()
priority 0.5) (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$
            (FilesQ -> Maybe (Action FilesA)) -> Rules ()
forall a. Typeable a => a -> Rules ()
addUserRule ((FilesQ -> Maybe (Action FilesA)) -> Rules ())
-> (FilesQ -> Maybe (Action FilesA)) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \(FilesQ xs_ :: [FileQ]
xs_) -> let xs :: [String]
xs = (FileQ -> String) -> [FileQ] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (FileName -> String
fileNameToString (FileName -> String) -> (FileQ -> FileName) -> FileQ -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileQ -> FileName
fromFileQ) [FileQ]
xs_ in
                if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ps Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((String -> String -> Bool) -> [String] -> [String] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> Bool
(?==) [String]
ps [String]
xs) then Maybe (Action FilesA)
forall a. Maybe a
Nothing else Action FilesA -> Maybe (Action FilesA)
forall a. a -> Maybe a
Just (Action FilesA -> Maybe (Action FilesA))
-> Action FilesA -> Maybe (Action FilesA)
forall a b. (a -> b) -> a -> b
$ do
                    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
createDirectoryRecursive ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
takeDirectory [String]
xs
                    [String] -> Action ()
trackAllow [String]
xs
                    [String] -> Action ()
act [String]
xs
                    String -> [FileQ] -> Action FilesA
getFileTimes "&%>" [FileQ]
xs_


-- | Define a rule for building multiple files at the same time, a more powerful
--   and more dangerous version of '&%>'. Think of it as the AND (@&&@) equivalent of '?>'.
--
--   Given an application @test &?> ...@, @test@ should return @Just@ if the rule applies, and should
--   return the list of files that will be produced. This list /must/ include the file passed as an argument and should
--   obey the invariant:
--
-- > forAll $ \x ys -> test x == Just ys ==> x `elem` ys && all ((== Just ys) . test) ys
--
--   As an example of a function satisfying the invariaint:
--
-- @
-- test x | 'Development.Shake.FilePath.takeExtension' x \`elem\` [\".hi\",\".o\"]
--        = Just ['Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"hi\", 'Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"o\"]
-- test _ = Nothing
-- @
--
--   Regardless of whether @Foo.hi@ or @Foo.o@ is passed, the function always returns @[Foo.hi, Foo.o]@.
(&?>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()
&?> :: (String -> Maybe [String]) -> ([String] -> Action ()) -> Rules ()
(&?>) test :: String -> Maybe [String]
test act :: [String] -> Action ()
act = Double -> Rules () -> Rules ()
priority 0.5 (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
    let inputOutput :: String -> String -> [String] -> [String]
inputOutput suf :: String
suf inp :: String
inp out :: [String]
out =
            ["Input" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
suf String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":", "  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
inp] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
            ["Output" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
suf String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("  "String -> ShowS
forall a. [a] -> [a] -> [a]
++) [String]
out
    let normTest :: String -> Maybe [String]
normTest = ([String] -> [String]) -> Maybe [String] -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS -> [String] -> [String]) -> ShowS -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ShowS
toStandard ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
normaliseEx) (Maybe [String] -> Maybe [String])
-> (String -> Maybe [String]) -> String -> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe [String]
test
    let checkedTest :: String -> Maybe [String]
checkedTest x :: String
x = case String -> Maybe [String]
normTest String
x of
            Nothing -> Maybe [String]
forall a. Maybe a
Nothing
            Just ys :: [String]
ys | String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
ys -> String -> Maybe [String]
forall a. HasCallStack => String -> a
error (String -> Maybe [String]) -> String -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                "Invariant broken in &?>, did not return the input (after normalisation)." String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                String -> String -> [String] -> [String]
inputOutput "" String
x [String]
ys
            Just ys :: [String]
ys | bad :: String
bad:_ <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe [String] -> Maybe [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
ys) (Maybe [String] -> Bool)
-> (String -> Maybe [String]) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe [String]
normTest) [String]
ys -> String -> Maybe [String]
forall a. HasCallStack => String -> a
error (String -> Maybe [String]) -> String -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                ["Invariant broken in &?>, not equalValue for all arguments (after normalisation)."] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                String -> String -> [String] -> [String]
inputOutput "1" String
x [String]
ys [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                String -> String -> [String] -> [String]
inputOutput "2" String
bad ([String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe ["Nothing"] (Maybe [String] -> [String]) -> Maybe [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Maybe [String]
normTest String
bad)
            Just ys :: [String]
ys -> [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
ys

    (String -> Maybe (Action (Maybe FileA))) -> Rules ()
fileForward ((String -> Maybe (Action (Maybe FileA))) -> Rules ())
-> (String -> Maybe (Action (Maybe FileA))) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \x :: String
x -> case String -> Maybe [String]
checkedTest String
x of
        Nothing -> Maybe (Action (Maybe FileA))
forall a. Maybe a
Nothing
        Just ys :: [String]
ys -> Action (Maybe FileA) -> Maybe (Action (Maybe FileA))
forall a. a -> Maybe a
Just (Action (Maybe FileA) -> Maybe (Action (Maybe FileA)))
-> Action (Maybe FileA) -> Maybe (Action (Maybe FileA))
forall a b. (a -> b) -> a -> b
$ do
            FilesA res :: [FileA]
res <- FilesQ -> Action FilesA
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value) =>
key -> Action value
apply1 (FilesQ -> Action FilesA) -> FilesQ -> Action FilesA
forall a b. (a -> b) -> a -> b
$ [FileQ] -> FilesQ
FilesQ ([FileQ] -> FilesQ) -> [FileQ] -> FilesQ
forall a b. (a -> b) -> a -> b
$ (String -> FileQ) -> [String] -> [FileQ]
forall a b. (a -> b) -> [a] -> [b]
map (FileName -> FileQ
FileQ (FileName -> FileQ) -> (String -> FileName) -> String -> FileQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FileName
fileNameFromString) [String]
ys
            Maybe FileA -> Action (Maybe FileA)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FileA -> Action (Maybe FileA))
-> Maybe FileA -> Action (Maybe FileA)
forall a b. (a -> b) -> a -> b
$ if [FileA] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FileA]
res then Maybe FileA
forall a. Maybe a
Nothing else FileA -> Maybe FileA
forall a. a -> Maybe a
Just (FileA -> Maybe FileA) -> FileA -> Maybe FileA
forall a b. (a -> b) -> a -> b
$ [FileA]
res [FileA] -> Int -> FileA
forall a. [a] -> Int -> a
!! Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex String
x [String]
ys)

    (FilesQ -> Maybe (Action FilesA)) -> Rules ()
forall a. Typeable a => a -> Rules ()
addUserRule ((FilesQ -> Maybe (Action FilesA)) -> Rules ())
-> (FilesQ -> Maybe (Action FilesA)) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \(FilesQ xs_ :: [FileQ]
xs_) -> let xs :: [String]
xs@(x :: String
x:_) = (FileQ -> String) -> [FileQ] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (FileName -> String
fileNameToString (FileName -> String) -> (FileQ -> FileName) -> FileQ -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileQ -> FileName
fromFileQ) [FileQ]
xs_ in
        case String -> Maybe [String]
checkedTest String
x of
            Just ys :: [String]
ys | [String]
ys [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== [String]
xs -> Action FilesA -> Maybe (Action FilesA)
forall a. a -> Maybe a
Just (Action FilesA -> Maybe (Action FilesA))
-> Action FilesA -> Maybe (Action FilesA)
forall a b. (a -> b) -> a -> b
$ do
                IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
createDirectoryRecursive ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
takeDirectory [String]
xs
                [String] -> Action ()
act [String]
xs
                String -> [FileQ] -> Action FilesA
getFileTimes "&?>" [FileQ]
xs_
            Just ys :: [String]
ys -> String -> Maybe (Action FilesA)
forall a. HasCallStack => String -> a
error (String -> Maybe (Action FilesA))
-> String -> Maybe (Action FilesA)
forall a b. (a -> b) -> a -> b
$ "Error, &?> is incompatible with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ " vs " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
ys
            Nothing -> Maybe (Action FilesA)
forall a. Maybe a
Nothing


getFileTimes :: String -> [FileQ] -> Action FilesA
getFileTimes :: String -> [FileQ] -> Action FilesA
getFileTimes name :: String
name xs :: [FileQ]
xs = do
    ShakeOptions
opts <- Action ShakeOptions
getShakeOptions
    let opts2 :: ShakeOptions
opts2 = if ShakeOptions -> Change
shakeChange ShakeOptions
opts Change -> Change -> Bool
forall a. Eq a => a -> a -> Bool
== Change
ChangeModtimeAndDigestInput then ShakeOptions
opts{shakeChange :: Change
shakeChange=Change
ChangeModtime} else ShakeOptions
opts
    [Maybe FileA]
ys <- IO [Maybe FileA] -> Action [Maybe FileA]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Maybe FileA] -> Action [Maybe FileA])
-> IO [Maybe FileA] -> Action [Maybe FileA]
forall a b. (a -> b) -> a -> b
$ (FileQ -> IO (Maybe FileA)) -> [FileQ] -> IO [Maybe FileA]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ShakeOptions -> FileQ -> IO (Maybe FileA)
fileStoredValue ShakeOptions
opts2) [FileQ]
xs
    case [Maybe FileA] -> Maybe [FileA]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe FileA]
ys of
        Just ys :: [FileA]
ys -> FilesA -> Action FilesA
forall (m :: * -> *) a. Monad m => a -> m a
return (FilesA -> Action FilesA) -> FilesA -> Action FilesA
forall a b. (a -> b) -> a -> b
$ [FileA] -> FilesA
FilesA [FileA]
ys
        Nothing | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ShakeOptions -> Bool
shakeCreationCheck ShakeOptions
opts -> FilesA -> Action FilesA
forall (m :: * -> *) a. Monad m => a -> m a
return (FilesA -> Action FilesA) -> FilesA -> Action FilesA
forall a b. (a -> b) -> a -> b
$ [FileA] -> FilesA
FilesA []
        Nothing -> do
            let missing :: Int
missing = [Maybe FileA] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Maybe FileA] -> Int) -> [Maybe FileA] -> Int
forall a b. (a -> b) -> a -> b
$ (Maybe FileA -> Bool) -> [Maybe FileA] -> [Maybe FileA]
forall a. (a -> Bool) -> [a] -> [a]
filter Maybe FileA -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe FileA]
ys
            String -> Action FilesA
forall a. HasCallStack => String -> a
error (String -> Action FilesA) -> String -> Action FilesA
forall a b. (a -> b) -> a -> b
$ "Error, " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ " rule failed to produce " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
missing String -> ShowS
forall a. [a] -> [a] -> [a]
++
                    " file" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Int
missing Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 then "" else "s") String -> ShowS
forall a. [a] -> [a] -> [a]
++ " (out of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([FileQ] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FileQ]
xs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ["\n  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FileName -> String
fileNameToString FileName
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ if Maybe FileA -> Bool
forall a. Maybe a -> Bool
isNothing Maybe FileA
y then " - MISSING" else "" | (FileQ x :: FileName
x,y :: Maybe FileA
y) <- [FileQ] -> [Maybe FileA] -> [(FileQ, Maybe FileA)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FileQ]
xs [Maybe FileA]
ys]