{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, Rank2Types, ScopedTypeVariables, ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
module Development.Shake.Forward(
shakeForward, shakeArgsForward,
forwardOptions, forwardRule,
cache, cacheAction, cacheActionWith,
) where
import Control.Monad
import Development.Shake
import Development.Shake.Rule
import Development.Shake.Command
import Development.Shake.Classes
import Development.Shake.FilePath
import Data.IORef.Extra
import Data.Either
import Data.Typeable
import Data.List.Extra
import Control.Exception.Extra
import Numeric
import System.IO.Unsafe
import Data.Binary
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.HashMap.Strict as Map
{-# NOINLINE forwards #-}
forwards :: IORef (Map.HashMap Forward (Action Forward))
forwards :: IORef (HashMap Forward (Action Forward))
forwards = IO (IORef (HashMap Forward (Action Forward)))
-> IORef (HashMap Forward (Action Forward))
forall a. IO a -> a
unsafePerformIO (IO (IORef (HashMap Forward (Action Forward)))
-> IORef (HashMap Forward (Action Forward)))
-> IO (IORef (HashMap Forward (Action Forward)))
-> IORef (HashMap Forward (Action Forward))
forall a b. (a -> b) -> a -> b
$ HashMap Forward (Action Forward)
-> IO (IORef (HashMap Forward (Action Forward)))
forall a. a -> IO (IORef a)
newIORef HashMap Forward (Action Forward)
forall k v. HashMap k v
Map.empty
newtype Forward = Forward (String, String, BS.ByteString)
deriving (Int -> Forward -> Int
Forward -> Int
(Int -> Forward -> Int) -> (Forward -> Int) -> Hashable Forward
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Forward -> Int
$chash :: Forward -> Int
hashWithSalt :: Int -> Forward -> Int
$chashWithSalt :: Int -> Forward -> Int
Hashable,Typeable,Forward -> Forward -> Bool
(Forward -> Forward -> Bool)
-> (Forward -> Forward -> Bool) -> Eq Forward
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Forward -> Forward -> Bool
$c/= :: Forward -> Forward -> Bool
== :: Forward -> Forward -> Bool
$c== :: Forward -> Forward -> Bool
Eq,Forward -> ()
(Forward -> ()) -> NFData Forward
forall a. (a -> ()) -> NFData a
rnf :: Forward -> ()
$crnf :: Forward -> ()
NFData,Get Forward
[Forward] -> Put
Forward -> Put
(Forward -> Put)
-> Get Forward -> ([Forward] -> Put) -> Binary Forward
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Forward] -> Put
$cputList :: [Forward] -> Put
get :: Get Forward
$cget :: Get Forward
put :: Forward -> Put
$cput :: Forward -> Put
Binary)
mkForward :: (Typeable a, Show a, Binary a) => a -> Forward
mkForward :: a -> Forward
mkForward a
x = (String, String, ByteString) -> Forward
Forward (TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
x, a -> String
forall a. Show a => a -> String
show a
x, a -> ByteString
forall a. Binary a => a -> ByteString
encode' a
x)
unForward :: forall a . (Typeable a, Binary a) => Forward -> a
unForward :: Forward -> a
unForward (Forward (String
got,String
_,ByteString
x))
| String
got String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
want = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Failed to match forward type, wanted " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
want String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
got
| Bool
otherwise = ByteString -> a
forall a. Binary a => ByteString -> a
decode' ByteString
x
where want :: String
want = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
encode' :: Binary a => a -> BS.ByteString
encode' :: a -> ByteString
encode' = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> (a -> [ByteString]) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LBS.toChunks (ByteString -> [ByteString])
-> (a -> ByteString) -> a -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Binary a => a -> ByteString
encode
decode' :: Binary a => BS.ByteString -> a
decode' :: ByteString -> a
decode' = ByteString -> a
forall a. Binary a => ByteString -> a
decode (ByteString -> a) -> (ByteString -> ByteString) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
LBS.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
type instance RuleResult Forward = Forward
instance Show Forward where
show :: Forward -> String
show (Forward (String
_,String
x,ByteString
_)) = String
x
shakeForward :: ShakeOptions -> Action () -> IO ()
shakeForward :: ShakeOptions -> Action () -> IO ()
shakeForward ShakeOptions
opts Action ()
act = ShakeOptions -> Rules () -> IO ()
shake (ShakeOptions -> ShakeOptions
forwardOptions ShakeOptions
opts) (Action () -> Rules ()
forwardRule Action ()
act)
shakeArgsForward :: ShakeOptions -> Action () -> IO ()
shakeArgsForward :: ShakeOptions -> Action () -> IO ()
shakeArgsForward ShakeOptions
opts Action ()
act = ShakeOptions -> Rules () -> IO ()
shakeArgs (ShakeOptions -> ShakeOptions
forwardOptions ShakeOptions
opts) (Action () -> Rules ()
forwardRule Action ()
act)
forwardRule :: Action () -> Rules ()
forwardRule :: Action () -> Rules ()
forwardRule Action ()
act = do
ShakeOptions
opts <- Rules ShakeOptions
getShakeOptionsRules
Bool -> Rules () -> Rules ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ ShakeOptions -> [String]
shakeLintInside ShakeOptions
opts) (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$
String -> Rules ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"When running in forward mode you must set shakeLintInside to specify where to detect dependencies"
BuiltinLint Forward Forward
-> BuiltinIdentity Forward Forward
-> BuiltinRun Forward Forward
-> Rules ()
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value,
NFData value, Show value, HasCallStack) =>
BuiltinLint key value
-> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
addBuiltinRule BuiltinLint Forward Forward
forall key value. BuiltinLint key value
noLint BuiltinIdentity Forward Forward
forall key value. BuiltinIdentity key value
noIdentity (BuiltinRun Forward Forward -> Rules ())
-> BuiltinRun Forward Forward -> Rules ()
forall a b. (a -> b) -> a -> b
$ \Forward
k Maybe ByteString
old RunMode
mode ->
case Maybe ByteString
old of
Just ByteString
old | RunMode
mode RunMode -> RunMode -> Bool
forall a. Eq a => a -> a -> Bool
== RunMode
RunDependenciesSame -> RunResult Forward -> Action (RunResult Forward)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult Forward -> Action (RunResult Forward))
-> RunResult Forward -> Action (RunResult Forward)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> Forward -> RunResult Forward
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedNothing ByteString
old (ByteString -> Forward
forall a. Binary a => ByteString -> a
decode' ByteString
old)
Maybe ByteString
_ -> do
Maybe (Action Forward)
res <- IO (Maybe (Action Forward)) -> Action (Maybe (Action Forward))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Action Forward)) -> Action (Maybe (Action Forward)))
-> IO (Maybe (Action Forward)) -> Action (Maybe (Action Forward))
forall a b. (a -> b) -> a -> b
$ IORef (HashMap Forward (Action Forward))
-> (HashMap Forward (Action Forward)
-> (HashMap Forward (Action Forward), Maybe (Action Forward)))
-> IO (Maybe (Action Forward))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (HashMap Forward (Action Forward))
forwards ((HashMap Forward (Action Forward)
-> (HashMap Forward (Action Forward), Maybe (Action Forward)))
-> IO (Maybe (Action Forward)))
-> (HashMap Forward (Action Forward)
-> (HashMap Forward (Action Forward), Maybe (Action Forward)))
-> IO (Maybe (Action Forward))
forall a b. (a -> b) -> a -> b
$ \HashMap Forward (Action Forward)
mp -> (Forward
-> HashMap Forward (Action Forward)
-> HashMap Forward (Action Forward)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete Forward
k HashMap Forward (Action Forward)
mp, Forward
-> HashMap Forward (Action Forward) -> Maybe (Action Forward)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Forward
k HashMap Forward (Action Forward)
mp)
case Maybe (Action Forward)
res of
Maybe (Action Forward)
Nothing -> IO (RunResult Forward) -> Action (RunResult Forward)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RunResult Forward) -> Action (RunResult Forward))
-> IO (RunResult Forward) -> Action (RunResult Forward)
forall a b. (a -> b) -> a -> b
$ String -> IO (RunResult Forward)
forall a. HasCallStack => String -> IO a
errorIO (String -> IO (RunResult Forward))
-> String -> IO (RunResult Forward)
forall a b. (a -> b) -> a -> b
$ String
"Failed to find action name, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Forward -> String
forall a. Show a => a -> String
show Forward
k
Just Action Forward
act -> do
Forward
new <- Action Forward
act
RunResult Forward -> Action (RunResult Forward)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunResult Forward -> Action (RunResult Forward))
-> RunResult Forward -> Action (RunResult Forward)
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> Forward -> RunResult Forward
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedRecomputeSame (Forward -> ByteString
forall a. Binary a => a -> ByteString
encode' Forward
new) Forward
new
Action () -> Rules ()
forall a. HasCallStack => Action a -> Rules ()
action Action ()
act
forwardOptions :: ShakeOptions -> ShakeOptions
forwardOptions :: ShakeOptions -> ShakeOptions
forwardOptions ShakeOptions
opts = ShakeOptions
opts{shakeCommandOptions :: [CmdOption]
shakeCommandOptions=[CmdOption
AutoDeps]}
cacheAction :: (Typeable a, Binary a, Show a, Typeable b, Binary b, Show b) => a -> Action b -> Action b
cacheAction :: a -> Action b -> Action b
cacheAction (a -> Forward
forall a. (Typeable a, Show a, Binary a) => a -> Forward
mkForward -> Forward
key) (Action b
action :: Action 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
$ IORef (HashMap Forward (Action Forward))
-> (HashMap Forward (Action Forward)
-> HashMap Forward (Action Forward))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef (HashMap Forward (Action Forward))
forwards ((HashMap Forward (Action Forward)
-> HashMap Forward (Action Forward))
-> IO ())
-> (HashMap Forward (Action Forward)
-> HashMap Forward (Action Forward))
-> IO ()
forall a b. (a -> b) -> a -> b
$ Forward
-> Action Forward
-> HashMap Forward (Action Forward)
-> HashMap Forward (Action Forward)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Forward
key (b -> Forward
forall a. (Typeable a, Show a, Binary a) => a -> Forward
mkForward (b -> Forward) -> Action b -> Action Forward
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action b
action)
Forward
res <- Forward -> Action Forward
forall key value.
(HasCallStack, RuleResult key ~ value, ShakeValue key,
Typeable value) =>
key -> Action value
apply1 Forward
key
IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IORef (HashMap Forward (Action Forward))
-> (HashMap Forward (Action Forward)
-> HashMap Forward (Action Forward))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef (HashMap Forward (Action Forward))
forwards ((HashMap Forward (Action Forward)
-> HashMap Forward (Action Forward))
-> IO ())
-> (HashMap Forward (Action Forward)
-> HashMap Forward (Action Forward))
-> IO ()
forall a b. (a -> b) -> a -> b
$ Forward
-> HashMap Forward (Action Forward)
-> HashMap Forward (Action Forward)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete Forward
key
b -> Action b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Action b) -> b -> Action b
forall a b. (a -> b) -> a -> b
$ Forward -> b
forall a. (Typeable a, Binary a) => Forward -> a
unForward Forward
res
newtype With a = With a
deriving (Typeable, Get (With a)
[With a] -> Put
With a -> Put
(With a -> Put)
-> Get (With a) -> ([With a] -> Put) -> Binary (With a)
forall a. Binary a => Get (With a)
forall a. Binary a => [With a] -> Put
forall a. Binary a => With a -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [With a] -> Put
$cputList :: forall a. Binary a => [With a] -> Put
get :: Get (With a)
$cget :: forall a. Binary a => Get (With a)
put :: With a -> Put
$cput :: forall a. Binary a => With a -> Put
Binary, Int -> With a -> String -> String
[With a] -> String -> String
With a -> String
(Int -> With a -> String -> String)
-> (With a -> String)
-> ([With a] -> String -> String)
-> Show (With a)
forall a. Show a => Int -> With a -> String -> String
forall a. Show a => [With a] -> String -> String
forall a. Show a => With a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [With a] -> String -> String
$cshowList :: forall a. Show a => [With a] -> String -> String
show :: With a -> String
$cshow :: forall a. Show a => With a -> String
showsPrec :: Int -> With a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> With a -> String -> String
Show)
cacheActionWith :: (Typeable a, Binary a, Show a, Typeable b, Binary b, Show b, Typeable c, Binary c, Show c) => a -> b -> Action c -> Action c
cacheActionWith :: a -> b -> Action c -> Action c
cacheActionWith a
key b
argument Action c
action = do
With b -> Action b -> Action b
forall a b.
(Typeable a, Binary a, Show a, Typeable b, Binary b, Show b) =>
a -> Action b -> Action b
cacheAction (b -> With b
forall a. a -> With a
With b
argument) (Action b -> Action b) -> Action b -> Action b
forall a b. (a -> b) -> a -> b
$ do
Action ()
alwaysRerun
b -> Action b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
argument
a -> Action c -> Action c
forall a b.
(Typeable a, Binary a, Show a, Typeable b, Binary b, Show b) =>
a -> Action b -> Action b
cacheAction a
key (Action c -> Action c) -> Action c -> Action c
forall a b. (a -> b) -> a -> b
$ do
Forward -> Action Forward
forall key value.
(HasCallStack, RuleResult key ~ value, ShakeValue key,
Typeable value) =>
key -> Action value
apply1 (Forward -> Action Forward) -> Forward -> Action Forward
forall a b. (a -> b) -> a -> b
$ With b -> Forward
forall a. (Typeable a, Show a, Binary a) => a -> Forward
mkForward (With b -> Forward) -> With b -> Forward
forall a b. (a -> b) -> a -> b
$ b -> With b
forall a. a -> With a
With b
argument
Action c
action
cache :: (forall r . CmdArguments r => r) -> Action ()
cache :: (forall r. CmdArguments r => r) -> Action ()
cache forall r. CmdArguments r => r
cmd = do
let CmdArgument [Either CmdOption String]
args = CmdArgument
forall r. CmdArguments r => r
cmd
let isDull :: String -> Bool
isDull [Char
'-',Char
_] = Bool
True; isDull String
_ = Bool
False
let name :: String
name = String -> [String] -> String
forall a. a -> [a] -> a
headDef String
"unknown" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isDull) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
drop1 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [Either CmdOption String] -> [String]
forall a b. [Either a b] -> [b]
rights [Either CmdOption String]
args
Command -> Action () -> Action ()
forall a b.
(Typeable a, Binary a, Show a, Typeable b, Binary b, Show b) =>
a -> Action b -> Action b
cacheAction (String -> Command
Command (String -> Command) -> String -> Command
forall a b. (a -> b) -> a -> b
$ String -> String
toStandard String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" #" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
upper (Int -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex (Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Hashable a => a -> Int
hash (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ [Either CmdOption String] -> String
forall a. Show a => a -> String
show [Either CmdOption String]
args) String
"")) Action ()
forall r. CmdArguments r => r
cmd
newtype Command = Command String
deriving (Typeable, Get Command
[Command] -> Put
Command -> Put
(Command -> Put)
-> Get Command -> ([Command] -> Put) -> Binary Command
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Command] -> Put
$cputList :: [Command] -> Put
get :: Get Command
$cget :: Get Command
put :: Command -> Put
$cput :: Command -> Put
Binary)
instance Show Command where
show :: Command -> String
show (Command String
x) = String
"command " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x