{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, Rank2Types, ScopedTypeVariables, ViewPatterns #-}
{-# 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>. You must set
--   'shakeLintInside' to specify where 'AutoDeps' will look for dependencies - if you want all dependencies
--   everywhere use @[\"\"]@.
--
--   This module is considered experimental - it has not been battle tested. There are now a few possible
--   alternatives in this space:
--
-- * Pier <http://hackage.haskell.org/package/pier/docs/Pier-Core-Artifact.html> (built on Shake).
--
-- * Rattle <https://github.com/ndmitchell/rattle> (by the same author as Shake).
--
-- * Stroll <https://github.com/snowleopard/stroll>.
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

-- I'd like to use TypeRep, but it doesn't have any instances in older versions
newtype Forward = Forward (String, String, BS.ByteString) -- the type, the Show, the payload
    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

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

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

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

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


-- | Cache an action, given a key and an 'Action'. Each call in your program should specify a different
--   key, but the key should remain consistent between runs. Ideally, the 'Action' will gather all its dependencies
--   with tracked operations, e.g. 'readFile\''. However, if information is accessed from the environment
--   (e.g. the action is a closure), you should call 'cacheActionWith' being explicit about what is captured.
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)

-- | Like 'cacheAction', but also specify which information is captured by the closure of the 'Action'. If that
--   information changes, the 'Action' will be rerun.
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

-- | Apply caching to an external command using the same arguments as 'cmd'.
--
-- > cache $ cmd "gcc -c" ["foo.c"] "-o" ["foo.o"]
--
--   This command will be cached, with the inputs/outputs traced. If any of the
--   files used by this command (e.g. @foo.c@ or header files it imports) then
--   the command will rerun.
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