{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, Rank2Types, ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Development.Shake.Forward(
shakeForward, shakeArgsForward,
forwardOptions, forwardRule,
cache, cacheAction
) where
import Development.Shake
import Development.Shake.Rule
import Development.Shake.Command
import Development.Shake.Classes
import Development.Shake.FilePath
import Data.IORef
import Data.Either
import Data.List.Extra
import Control.Exception.Extra
import Numeric
import System.IO.Unsafe
import qualified Data.ByteString as BS
import qualified Data.HashMap.Strict as Map
{-# NOINLINE forwards #-}
forwards :: IORef (Map.HashMap ForwardQ (Action ()))
forwards :: IORef (HashMap ForwardQ (Action ()))
forwards = IO (IORef (HashMap ForwardQ (Action ())))
-> IORef (HashMap ForwardQ (Action ()))
forall a. IO a -> a
unsafePerformIO (IO (IORef (HashMap ForwardQ (Action ())))
-> IORef (HashMap ForwardQ (Action ())))
-> IO (IORef (HashMap ForwardQ (Action ())))
-> IORef (HashMap ForwardQ (Action ()))
forall a b. (a -> b) -> a -> b
$ HashMap ForwardQ (Action ())
-> IO (IORef (HashMap ForwardQ (Action ())))
forall a. a -> IO (IORef a)
newIORef HashMap ForwardQ (Action ())
forall k v. HashMap k v
Map.empty
newtype ForwardQ = ForwardQ String
deriving (Int -> ForwardQ -> Int
ForwardQ -> Int
(Int -> ForwardQ -> Int) -> (ForwardQ -> Int) -> Hashable ForwardQ
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: ForwardQ -> Int
$chash :: ForwardQ -> Int
hashWithSalt :: Int -> ForwardQ -> Int
$chashWithSalt :: Int -> ForwardQ -> Int
Hashable,Typeable,ForwardQ -> ForwardQ -> Bool
(ForwardQ -> ForwardQ -> Bool)
-> (ForwardQ -> ForwardQ -> Bool) -> Eq ForwardQ
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ForwardQ -> ForwardQ -> Bool
$c/= :: ForwardQ -> ForwardQ -> Bool
== :: ForwardQ -> ForwardQ -> Bool
$c== :: ForwardQ -> ForwardQ -> Bool
Eq,ForwardQ -> ()
(ForwardQ -> ()) -> NFData ForwardQ
forall a. (a -> ()) -> NFData a
rnf :: ForwardQ -> ()
$crnf :: ForwardQ -> ()
NFData,Get ForwardQ
[ForwardQ] -> Put
ForwardQ -> Put
(ForwardQ -> Put)
-> Get ForwardQ -> ([ForwardQ] -> Put) -> Binary ForwardQ
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [ForwardQ] -> Put
$cputList :: [ForwardQ] -> Put
get :: Get ForwardQ
$cget :: Get ForwardQ
put :: ForwardQ -> Put
$cput :: ForwardQ -> Put
Binary)
type instance RuleResult ForwardQ = ()
instance Show ForwardQ where
show :: ForwardQ -> String
show (ForwardQ x :: String
x) = String
x
shakeForward :: ShakeOptions -> Action () -> IO ()
shakeForward :: ShakeOptions -> Action () -> IO ()
shakeForward opts :: ShakeOptions
opts act :: 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 opts :: ShakeOptions
opts act :: Action ()
act = ShakeOptions -> Rules () -> IO ()
shakeArgs (ShakeOptions -> ShakeOptions
forwardOptions ShakeOptions
opts) (Action () -> Rules ()
forwardRule Action ()
act)
forwardRule :: Action () -> Rules ()
forwardRule :: Action () -> Rules ()
forwardRule act :: Action ()
act = do
BuiltinLint ForwardQ () -> BuiltinRun ForwardQ () -> Rules ()
forall key value.
(RuleResult key ~ value, ShakeValue key, ShakeValue value) =>
BuiltinLint key value -> BuiltinRun key value -> Rules ()
addBuiltinRule BuiltinLint ForwardQ ()
forall key value. BuiltinLint key value
noLint (BuiltinRun ForwardQ () -> Rules ())
-> BuiltinRun ForwardQ () -> Rules ()
forall a b. (a -> b) -> a -> b
$ \k :: ForwardQ
k old :: Maybe ByteString
old dirty :: Bool
dirty ->
case Maybe ByteString
old of
Just old :: ByteString
old | Bool -> Bool
not Bool
dirty -> RunResult () -> Action (RunResult ())
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult () -> Action (RunResult ()))
-> RunResult () -> Action (RunResult ())
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> () -> RunResult ()
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedNothing ByteString
old ()
_ -> do
Maybe (Action ())
res <- IO (Maybe (Action ())) -> Action (Maybe (Action ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Action ())) -> Action (Maybe (Action ())))
-> IO (Maybe (Action ())) -> Action (Maybe (Action ()))
forall a b. (a -> b) -> a -> b
$ IORef (HashMap ForwardQ (Action ()))
-> (HashMap ForwardQ (Action ())
-> (HashMap ForwardQ (Action ()), Maybe (Action ())))
-> IO (Maybe (Action ()))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (HashMap ForwardQ (Action ()))
forwards ((HashMap ForwardQ (Action ())
-> (HashMap ForwardQ (Action ()), Maybe (Action ())))
-> IO (Maybe (Action ())))
-> (HashMap ForwardQ (Action ())
-> (HashMap ForwardQ (Action ()), Maybe (Action ())))
-> IO (Maybe (Action ()))
forall a b. (a -> b) -> a -> b
$ \mp :: HashMap ForwardQ (Action ())
mp -> (ForwardQ
-> HashMap ForwardQ (Action ()) -> HashMap ForwardQ (Action ())
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete ForwardQ
k HashMap ForwardQ (Action ())
mp, ForwardQ -> HashMap ForwardQ (Action ()) -> Maybe (Action ())
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup ForwardQ
k HashMap ForwardQ (Action ())
mp)
case Maybe (Action ())
res of
Nothing -> 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 ()
forall a. Partial => String -> IO a
errorIO "Failed to find action name"
Just act :: Action ()
act -> Action ()
act
RunResult () -> Action (RunResult ())
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult () -> Action (RunResult ()))
-> RunResult () -> Action (RunResult ())
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> () -> RunResult ()
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedRecomputeSame ByteString
BS.empty ()
Action () -> Rules ()
forall a. Action a -> Rules ()
action Action ()
act
forwardOptions :: ShakeOptions -> ShakeOptions
forwardOptions :: ShakeOptions -> ShakeOptions
forwardOptions opts :: ShakeOptions
opts = ShakeOptions
opts{shakeCommandOptions :: [CmdOption]
shakeCommandOptions=[CmdOption
AutoDeps]}
cacheAction :: String -> Action () -> Action ()
cacheAction :: String -> Action () -> Action ()
cacheAction name :: String
name action :: Action ()
action = do
let key :: ForwardQ
key = String -> ForwardQ
ForwardQ String
name
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 ForwardQ (Action ()))
-> (HashMap ForwardQ (Action ())
-> (HashMap ForwardQ (Action ()), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (HashMap ForwardQ (Action ()))
forwards ((HashMap ForwardQ (Action ())
-> (HashMap ForwardQ (Action ()), ()))
-> IO ())
-> (HashMap ForwardQ (Action ())
-> (HashMap ForwardQ (Action ()), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \mp :: HashMap ForwardQ (Action ())
mp -> (ForwardQ
-> Action ()
-> HashMap ForwardQ (Action ())
-> HashMap ForwardQ (Action ())
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert ForwardQ
key Action ()
action HashMap ForwardQ (Action ())
mp, ())
[()]
_ :: [()] <- [ForwardQ] -> Action [()]
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value) =>
[key] -> Action [value]
apply [ForwardQ
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 ForwardQ (Action ()))
-> (HashMap ForwardQ (Action ())
-> (HashMap ForwardQ (Action ()), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (HashMap ForwardQ (Action ()))
forwards ((HashMap ForwardQ (Action ())
-> (HashMap ForwardQ (Action ()), ()))
-> IO ())
-> (HashMap ForwardQ (Action ())
-> (HashMap ForwardQ (Action ()), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \mp :: HashMap ForwardQ (Action ())
mp -> (ForwardQ
-> HashMap ForwardQ (Action ()) -> HashMap ForwardQ (Action ())
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete ForwardQ
key HashMap ForwardQ (Action ())
mp, ())
cache :: (forall r . CmdArguments r => r) -> Action ()
cache :: (forall r. CmdArguments r => r) -> Action ()
cache cmd :: forall r. CmdArguments r => r
cmd = do
let CmdArgument args :: [Either CmdOption String]
args = CmdArgument
forall r. CmdArguments r => r
cmd
let isDull :: String -> Bool
isDull ['-',x :: Char
x] = Bool
True; isDull _ = Bool
False
let name :: String
name = [String] -> String
forall a. [a] -> a
head ([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) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop 1 ([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) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["unknown"]
String -> Action () -> Action ()
cacheAction ("command " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
toStandard String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ " #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
upper (Int -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
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) "")) Action ()
forall r. CmdArguments r => r
cmd