{-# 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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall k v. HashMap k v
Map.empty
newtype Forward = Forward (String, String, BS.ByteString)
deriving (Eq Forward
Int -> Forward -> Int
Forward -> Int
forall a. Eq 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
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 -> ()
forall a. (a -> ()) -> NFData a
rnf :: Forward -> ()
$crnf :: Forward -> ()
NFData,Get Forward
[Forward] -> Put
Forward -> Put
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 :: forall a. (Typeable a, Show a, Binary a) => a -> Forward
mkForward a
x = (String, String, ByteString) -> Forward
Forward (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => a -> TypeRep
typeOf a
x, forall a. Show a => a -> String
show a
x, forall a. Binary a => a -> ByteString
encode' a
x)
unForward :: forall a . (Typeable a, Binary a) => Forward -> a
unForward :: forall a. (Typeable a, Binary a) => Forward -> a
unForward (Forward (String
got,String
_,ByteString
x))
| String
got forall a. Eq a => a -> a -> Bool
/= String
want = forall a. Partial => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Failed to match forward type, wanted " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
want forall a. [a] -> [a] -> [a]
++ String
", got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
got
| Bool
otherwise = forall a. Binary a => ByteString -> a
decode' ByteString
x
where want :: String
want = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
encode' :: Binary a => a -> BS.ByteString
encode' :: forall a. Binary a => a -> ByteString
encode' = [ByteString] -> ByteString
BS.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LBS.toChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => a -> ByteString
encode
decode' :: Binary a => BS.ByteString -> a
decode' :: forall a. Binary a => ByteString -> a
decode' = forall a. Binary a => ByteString -> a
decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
LBS.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ ShakeOptions -> [String]
shakeLintInside ShakeOptions
opts) forall a b. (a -> b) -> a -> b
$
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"
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value,
NFData value, Show value, Partial) =>
BuiltinLint key value
-> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
addBuiltinRule forall key value. BuiltinLint key value
noLint forall key value. BuiltinIdentity key value
noIdentity forall a b. (a -> b) -> a -> b
$ \Forward
k Maybe ByteString
old RunMode
mode ->
case Maybe ByteString
old of
Just ByteString
old | RunMode
mode forall a. Eq a => a -> a -> Bool
== RunMode
RunDependenciesSame -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedNothing ByteString
old (forall a. Binary a => ByteString -> a
decode' ByteString
old)
Maybe ByteString
_ -> do
Maybe (Action Forward)
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (HashMap Forward (Action Forward))
forwards forall a b. (a -> b) -> a -> b
$ \HashMap Forward (Action Forward)
mp -> (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete Forward
k HashMap Forward (Action Forward)
mp, 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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Partial => String -> IO a
errorIO forall a b. (a -> b) -> a -> b
$ String
"Failed to find action name, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Forward
k
Just Action Forward
act -> do
Forward
new <- Action Forward
act
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedRecomputeSame (forall a. Binary a => a -> ByteString
encode' Forward
new) Forward
new
forall a. Partial => 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 :: forall a b.
(Typeable a, Binary a, Show a, Typeable b, Binary b, Show b) =>
a -> Action b -> Action b
cacheAction (forall a. (Typeable a, Show a, Binary a) => a -> Forward
mkForward -> Forward
key) (Action b
action :: Action b) = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef (HashMap Forward (Action Forward))
forwards forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Forward
key (forall a. (Typeable a, Show a, Binary a) => a -> Forward
mkForward forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action b
action)
Forward
res <- forall key value.
(Partial, RuleResult key ~ value, ShakeValue key,
Typeable value) =>
key -> Action value
apply1 Forward
key
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef (HashMap Forward (Action Forward))
forwards forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete Forward
key
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> 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
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 -> ShowS
forall a. Show a => Int -> With a -> ShowS
forall a. Show a => [With a] -> ShowS
forall a. Show a => With a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [With a] -> ShowS
$cshowList :: forall a. Show a => [With a] -> ShowS
show :: With a -> String
$cshow :: forall a. Show a => With a -> String
showsPrec :: Int -> With a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> With a -> ShowS
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 :: forall a b c.
(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
key b
argument Action c
action = do
forall a b.
(Typeable a, Binary a, Show a, Typeable b, Binary b, Show b) =>
a -> Action b -> Action b
cacheAction (forall a. a -> With a
With b
argument) forall a b. (a -> b) -> a -> b
$ do
Action ()
alwaysRerun
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
argument
forall a b.
(Typeable a, Binary a, Show a, Typeable b, Binary b, Show b) =>
a -> Action b -> Action b
cacheAction a
key forall a b. (a -> b) -> a -> b
$ do
forall key value.
(Partial, RuleResult key ~ value, ShakeValue key,
Typeable value) =>
key -> Action value
apply1 forall a b. (a -> b) -> a -> b
$ forall a. (Typeable a, Show a, Binary a) => a -> Forward
mkForward forall a b. (a -> b) -> a -> 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 = forall r. CmdArguments r => r
cmd
let isDull :: String -> Bool
isDull [Char
'-',Char
_] = Bool
True; isDull String
_ = Bool
False
let name :: String
name = forall a. a -> [a] -> a
headDef String
"unknown" forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isDull) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
drop1 forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
rights [Either CmdOption String]
args
forall a b.
(Typeable a, Binary a, Show a, Typeable b, Binary b, Show b) =>
a -> Action b -> Action b
cacheAction (String -> Command
Command forall a b. (a -> b) -> a -> b
$ ShowS
toStandard String
name forall a. [a] -> [a] -> [a]
++ String
" #" forall a. [a] -> [a] -> [a]
++ ShowS
upper (forall a. (Integral a, Show a) => a -> ShowS
showHex (forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ forall a. Hashable a => a -> Int
hash forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show [Either CmdOption String]
args) String
"")) forall r. CmdArguments r => r
cmd
newtype Command = Command String
deriving (Typeable, Get Command
[Command] -> Put
Command -> Put
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 " forall a. [a] -> [a] -> [a]
++ String
x