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.HashMap.Strict as Map
forwards :: IORef (Map.HashMap ForwardQ (Action ()))
forwards = unsafePerformIO $ newIORef Map.empty
newtype ForwardQ = ForwardQ String
deriving (Hashable,Typeable,Eq,NFData,Binary)
instance Show ForwardQ where
show (ForwardQ x) = x
newtype ForwardA = ForwardA ()
deriving (Hashable,Typeable,Eq,NFData,Binary,Show)
instance Rule ForwardQ ForwardA where
storedValue _ _ = return $ Just $ ForwardA ()
shakeForward :: ShakeOptions -> Action () -> IO ()
shakeForward opts act = shake (forwardOptions opts) (forwardRule act)
shakeArgsForward :: ShakeOptions -> Action () -> IO ()
shakeArgsForward opts act = shakeArgs (forwardOptions opts) (forwardRule act)
forwardRule :: Action () -> Rules ()
forwardRule act = do
rule $ \k -> Just $ do
res <- liftIO $ atomicModifyIORef forwards $ \mp -> (Map.delete k mp, Map.lookup k mp)
case res of
Nothing -> liftIO $ errorIO "Failed to find action name"
Just act -> act
return $ ForwardA ()
action act
forwardOptions :: ShakeOptions -> ShakeOptions
forwardOptions opts = opts{shakeCommandOptions=[AutoDeps]}
cacheAction :: String -> Action () -> Action ()
cacheAction name action = do
let key = ForwardQ name
liftIO $ atomicModifyIORef forwards $ \mp -> (Map.insert key action mp, ())
_ :: [ForwardA] <- apply [key]
liftIO $ atomicModifyIORef forwards $ \mp -> (Map.delete key mp, ())
cache :: (forall r . CmdArguments r => r) -> Action ()
cache cmd = do
let args :: [Either CmdOption String] = cmd
let isDull ['-',x] = True; isDull _ = False
let name = head $ filter (not . isDull) (drop 1 $ rights args) ++ ["unknown"]
cacheAction ("command " ++ toStandard name ++ " #" ++ upper (showHex (abs $ hash $ show args) "")) cmd