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

-- | A module for producing forward-defined build systems, in contrast to standard backwards-defined
--   build systems such as shake. Based around ideas from <https://code.google.com/p/fabricate/ fabricate>.
--   As an example:
--
-- @
-- import "Development.Shake"
-- import "Development.Shake.Forward"
-- import "Development.Shake.FilePath"
--
-- main = 'shakeArgsForward' 'shakeOptions' $ do
--     contents <- 'readFileLines' \"result.txt\"
--     'cache' $ 'cmd' \"tar -cf result.tar\" contents
-- @
--
--   Compared to backward-defined build systems (such as normal Shake), forward-defined build
--   systems tend to be simpler for simple systems (less boilerplate, more direct style), but more
--   complex for larger build systems (requires explicit parallelism, explicit sharing of build products,
--   no automatic command line targets). As a general approach for writing forward-defined systems:
--
-- * Figure out the sequence of system commands that will build your project.
--
-- * Write a simple 'Action' that builds your project.
--
-- * Insert 'cache' in front of most system commands.
--
-- * Replace most loops with 'forP', where they can be executed in parallel.
--
-- * Where Haskell performs real computation, if zero-build performance is insufficient, use 'cacheAction'.
--
--   All forward-defined systems use 'AutoDeps', which requires @fsatrace@ to be on the @$PATH@.
--   You can obtain @fsatrace@ from <https://github.com/jacereda/fsatrace>.
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

-- | Run a forward-defined build system.
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)

-- | Run a forward-defined build system, interpreting command-line arguments.
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)

-- | Given an 'Action', turn it into a 'Rules' structure which runs in forward mode.
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

-- | Given a 'ShakeOptions', set the options necessary to execute in forward mode.
forwardOptions :: ShakeOptions -> ShakeOptions
forwardOptions :: ShakeOptions -> ShakeOptions
forwardOptions opts :: ShakeOptions
opts = ShakeOptions
opts{shakeCommandOptions :: [CmdOption]
shakeCommandOptions=[CmdOption
AutoDeps]}


-- | Cache an action. The name of the action must be unique for all different actions.
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, ())

-- | Apply caching to an external command.
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