{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification, RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}

module Development.Shake.Internal.Core.Rules(
    Rules, runRules,
    RuleResult, addBuiltinRule, addBuiltinRuleEx, noLint,
    getShakeOptionsRules, userRuleMatch,
    getUserRules, addUserRule, alternatives, priority,
    action, withoutActions
    ) where

import Control.Applicative
import Data.Tuple.Extra
import Control.Monad.Extra
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer.Strict
import Development.Shake.Classes
import General.Binary
import Data.Typeable.Extra
import Data.Function
import Data.List.Extra
import qualified Data.HashMap.Strict as Map
import Data.Maybe
import System.IO.Extra
import System.IO.Unsafe
import Data.Semigroup (Semigroup (..))
import Data.Monoid hiding ((<>))
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Binary.Builder as Bin
import Data.Binary.Put
import Data.Binary.Get
import General.ListBuilder

import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Core.Monad
import Development.Shake.Internal.Value
import Development.Shake.Internal.Options
import Development.Shake.Internal.Errors
import Prelude


---------------------------------------------------------------------
-- RULES

-- | Get the 'UserRule' value at a given type. This 'UserRule' will capture
--   all rules added, along with things such as 'priority' and 'alternatives'.
getUserRules :: Typeable a => Action (UserRule a)
getUserRules :: Action (UserRule a)
getUserRules = Action (UserRule a)
forall a. Typeable a => Action (UserRule a)
f where
    f :: forall a . Typeable a => Action (UserRule a)
    f :: Action (UserRule a)
f = do
        Global{..} <- RAW Global Local Global -> Action Global
forall a. RAW Global Local a -> Action a
Action RAW Global Local Global
forall ro rw. RAW ro rw ro
getRO
        UserRule a -> Action (UserRule a)
forall (m :: * -> *) a. Monad m => a -> m a
return (UserRule a -> Action (UserRule a))
-> UserRule a -> Action (UserRule a)
forall a b. (a -> b) -> a -> b
$ case TypeRep -> HashMap TypeRep UserRule_ -> Maybe UserRule_
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)) HashMap TypeRep UserRule_
globalUserRules of
            Nothing -> [UserRule a] -> UserRule a
forall a. [UserRule a] -> UserRule a
Unordered []
            Just (UserRule_ r :: UserRule a
r) -> Maybe (UserRule a) -> UserRule a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (UserRule a) -> UserRule a)
-> Maybe (UserRule a) -> UserRule a
forall a b. (a -> b) -> a -> b
$ UserRule a -> Maybe (UserRule a)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast UserRule a
r


-- | Get the 'ShakeOptions' that were used.
getShakeOptionsRules :: Rules ShakeOptions
getShakeOptionsRules :: Rules ShakeOptions
getShakeOptionsRules = WriterT SRules (ReaderT ShakeOptions IO) ShakeOptions
-> Rules ShakeOptions
forall a. WriterT SRules (ReaderT ShakeOptions IO) a -> Rules a
Rules (WriterT SRules (ReaderT ShakeOptions IO) ShakeOptions
 -> Rules ShakeOptions)
-> WriterT SRules (ReaderT ShakeOptions IO) ShakeOptions
-> Rules ShakeOptions
forall a b. (a -> b) -> a -> b
$ ReaderT ShakeOptions IO ShakeOptions
-> WriterT SRules (ReaderT ShakeOptions IO) ShakeOptions
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT ShakeOptions IO ShakeOptions
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

-- | Give a 'UserRule', and a function that tests a given rule, return the most important values
--   that match. In most cases the caller will raise an error if the rule matching returns anything
--   other than a singleton.
userRuleMatch :: UserRule a -> (a -> Maybe b) -> [b]
userRuleMatch :: UserRule a -> (a -> Maybe b) -> [b]
userRuleMatch u :: UserRule a
u test :: a -> Maybe b
test = [[b]] -> [b]
forall a. [a] -> a
head ([[b]] -> [b]) -> [[b]] -> [b]
forall a b. (a -> b) -> a -> b
$ (((Seconds, [b]) -> [b]) -> [(Seconds, [b])] -> [[b]]
forall a b. (a -> b) -> [a] -> [b]
map (Seconds, [b]) -> [b]
forall a b. (a, b) -> b
snd ([(Seconds, [b])] -> [[b]]) -> [(Seconds, [b])] -> [[b]]
forall a b. (a -> b) -> a -> b
$ [(Seconds, [b])] -> [(Seconds, [b])]
forall a. [a] -> [a]
reverse ([(Seconds, [b])] -> [(Seconds, [b])])
-> [(Seconds, [b])] -> [(Seconds, [b])]
forall a b. (a -> b) -> a -> b
$ [(Seconds, b)] -> [(Seconds, [b])]
forall k v. Ord k => [(k, v)] -> [(k, [v])]
groupSort ([(Seconds, b)] -> [(Seconds, [b])])
-> [(Seconds, b)] -> [(Seconds, [b])]
forall a b. (a -> b) -> a -> b
$ Maybe Seconds -> UserRule (Maybe b) -> [(Seconds, b)]
forall a. Maybe Seconds -> UserRule (Maybe a) -> [(Seconds, a)]
f Maybe Seconds
forall a. Maybe a
Nothing (UserRule (Maybe b) -> [(Seconds, b)])
-> UserRule (Maybe b) -> [(Seconds, b)]
forall a b. (a -> b) -> a -> b
$ (a -> Maybe b) -> UserRule a -> UserRule (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe b
test UserRule a
u) [[b]] -> [[b]] -> [[b]]
forall a. [a] -> [a] -> [a]
++ [[]]
    where
        f :: Maybe Double -> UserRule (Maybe a) -> [(Double,a)]
        f :: Maybe Seconds -> UserRule (Maybe a) -> [(Seconds, a)]
f p :: Maybe Seconds
p (UserRule x :: Maybe a
x) = [(Seconds, a)]
-> (a -> [(Seconds, a)]) -> Maybe a -> [(Seconds, a)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\x :: a
x -> [(Seconds -> Maybe Seconds -> Seconds
forall a. a -> Maybe a -> a
fromMaybe 1 Maybe Seconds
p,a
x)]) Maybe a
x
        f p :: Maybe Seconds
p (Unordered xs :: [UserRule (Maybe a)]
xs) = (UserRule (Maybe a) -> [(Seconds, a)])
-> [UserRule (Maybe a)] -> [(Seconds, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe Seconds -> UserRule (Maybe a) -> [(Seconds, a)]
forall a. Maybe Seconds -> UserRule (Maybe a) -> [(Seconds, a)]
f Maybe Seconds
p) [UserRule (Maybe a)]
xs
        f p :: Maybe Seconds
p (Priority p2 :: Seconds
p2 x :: UserRule (Maybe a)
x) = Maybe Seconds -> UserRule (Maybe a) -> [(Seconds, a)]
forall a. Maybe Seconds -> UserRule (Maybe a) -> [(Seconds, a)]
f (Seconds -> Maybe Seconds
forall a. a -> Maybe a
Just (Seconds -> Maybe Seconds) -> Seconds -> Maybe Seconds
forall a b. (a -> b) -> a -> b
$ Seconds -> Maybe Seconds -> Seconds
forall a. a -> Maybe a -> a
fromMaybe Seconds
p2 Maybe Seconds
p) UserRule (Maybe a)
x
        f p :: Maybe Seconds
p (Alternative x :: UserRule (Maybe a)
x) = case Maybe Seconds -> UserRule (Maybe a) -> [(Seconds, a)]
forall a. Maybe Seconds -> UserRule (Maybe a) -> [(Seconds, a)]
f Maybe Seconds
p UserRule (Maybe a)
x of
            [] -> []
            -- a bit weird to use the max priority but the first value
            -- but that's what the current implementation does...
            xs :: [(Seconds, a)]
xs -> [([Seconds] -> Seconds
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Seconds] -> Seconds) -> [Seconds] -> Seconds
forall a b. (a -> b) -> a -> b
$ ((Seconds, a) -> Seconds) -> [(Seconds, a)] -> [Seconds]
forall a b. (a -> b) -> [a] -> [b]
map (Seconds, a) -> Seconds
forall a b. (a, b) -> a
fst [(Seconds, a)]
xs, (Seconds, a) -> a
forall a b. (a, b) -> b
snd ((Seconds, a) -> a) -> (Seconds, a) -> a
forall a b. (a -> b) -> a -> b
$ [(Seconds, a)] -> (Seconds, a)
forall a. [a] -> a
head [(Seconds, a)]
xs)]


-- | Define a set of rules. Rules can be created with calls to functions such as 'Development.Shake.%>' or 'action'.
--   Rules are combined with either the 'Monoid' instance, or (more commonly) the 'Monad' instance and @do@ notation.
--   To define your own custom types of rule, see "Development.Shake.Rule".
newtype Rules a = Rules (WriterT SRules (ReaderT ShakeOptions IO) a) -- All IO must be associative/commutative (e.g. creating IORef/MVars)
    deriving (a -> Rules b -> Rules a
(a -> b) -> Rules a -> Rules b
(forall a b. (a -> b) -> Rules a -> Rules b)
-> (forall a b. a -> Rules b -> Rules a) -> Functor Rules
forall a b. a -> Rules b -> Rules a
forall a b. (a -> b) -> Rules a -> Rules b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Rules b -> Rules a
$c<$ :: forall a b. a -> Rules b -> Rules a
fmap :: (a -> b) -> Rules a -> Rules b
$cfmap :: forall a b. (a -> b) -> Rules a -> Rules b
Functor, Functor Rules
a -> Rules a
Functor Rules =>
(forall a. a -> Rules a)
-> (forall a b. Rules (a -> b) -> Rules a -> Rules b)
-> (forall a b c. (a -> b -> c) -> Rules a -> Rules b -> Rules c)
-> (forall a b. Rules a -> Rules b -> Rules b)
-> (forall a b. Rules a -> Rules b -> Rules a)
-> Applicative Rules
Rules a -> Rules b -> Rules b
Rules a -> Rules b -> Rules a
Rules (a -> b) -> Rules a -> Rules b
(a -> b -> c) -> Rules a -> Rules b -> Rules c
forall a. a -> Rules a
forall a b. Rules a -> Rules b -> Rules a
forall a b. Rules a -> Rules b -> Rules b
forall a b. Rules (a -> b) -> Rules a -> Rules b
forall a b c. (a -> b -> c) -> Rules a -> Rules b -> Rules c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Rules a -> Rules b -> Rules a
$c<* :: forall a b. Rules a -> Rules b -> Rules a
*> :: Rules a -> Rules b -> Rules b
$c*> :: forall a b. Rules a -> Rules b -> Rules b
liftA2 :: (a -> b -> c) -> Rules a -> Rules b -> Rules c
$cliftA2 :: forall a b c. (a -> b -> c) -> Rules a -> Rules b -> Rules c
<*> :: Rules (a -> b) -> Rules a -> Rules b
$c<*> :: forall a b. Rules (a -> b) -> Rules a -> Rules b
pure :: a -> Rules a
$cpure :: forall a. a -> Rules a
$cp1Applicative :: Functor Rules
Applicative, Applicative Rules
a -> Rules a
Applicative Rules =>
(forall a b. Rules a -> (a -> Rules b) -> Rules b)
-> (forall a b. Rules a -> Rules b -> Rules b)
-> (forall a. a -> Rules a)
-> Monad Rules
Rules a -> (a -> Rules b) -> Rules b
Rules a -> Rules b -> Rules b
forall a. a -> Rules a
forall a b. Rules a -> Rules b -> Rules b
forall a b. Rules a -> (a -> Rules b) -> Rules b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Rules a
$creturn :: forall a. a -> Rules a
>> :: Rules a -> Rules b -> Rules b
$c>> :: forall a b. Rules a -> Rules b -> Rules b
>>= :: Rules a -> (a -> Rules b) -> Rules b
$c>>= :: forall a b. Rules a -> (a -> Rules b) -> Rules b
$cp1Monad :: Applicative Rules
Monad, Monad Rules
Monad Rules => (forall a. IO a -> Rules a) -> MonadIO Rules
IO a -> Rules a
forall a. IO a -> Rules a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> Rules a
$cliftIO :: forall a. IO a -> Rules a
$cp1MonadIO :: Monad Rules
MonadIO, Monad Rules
Monad Rules =>
(forall a. (a -> Rules a) -> Rules a) -> MonadFix Rules
(a -> Rules a) -> Rules a
forall a. (a -> Rules a) -> Rules a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: (a -> Rules a) -> Rules a
$cmfix :: forall a. (a -> Rules a) -> Rules a
$cp1MonadFix :: Monad Rules
MonadFix)

newRules :: SRules -> Rules ()
newRules :: SRules -> Rules ()
newRules = WriterT SRules (ReaderT ShakeOptions IO) () -> Rules ()
forall a. WriterT SRules (ReaderT ShakeOptions IO) a -> Rules a
Rules (WriterT SRules (ReaderT ShakeOptions IO) () -> Rules ())
-> (SRules -> WriterT SRules (ReaderT ShakeOptions IO) ())
-> SRules
-> Rules ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SRules -> WriterT SRules (ReaderT ShakeOptions IO) ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell

modifyRules :: (SRules -> SRules) -> Rules () -> Rules ()
modifyRules :: (SRules -> SRules) -> Rules () -> Rules ()
modifyRules f :: SRules -> SRules
f (Rules r :: WriterT SRules (ReaderT ShakeOptions IO) ()
r) = WriterT SRules (ReaderT ShakeOptions IO) () -> Rules ()
forall a. WriterT SRules (ReaderT ShakeOptions IO) a -> Rules a
Rules (WriterT SRules (ReaderT ShakeOptions IO) () -> Rules ())
-> WriterT SRules (ReaderT ShakeOptions IO) () -> Rules ()
forall a b. (a -> b) -> a -> b
$ (SRules -> SRules)
-> WriterT SRules (ReaderT ShakeOptions IO) ()
-> WriterT SRules (ReaderT ShakeOptions IO) ()
forall (m :: * -> *) w a.
Monad m =>
(w -> w) -> WriterT w m a -> WriterT w m a
censor SRules -> SRules
f WriterT SRules (ReaderT ShakeOptions IO) ()
r

runRules :: ShakeOptions -> Rules () -> IO ([Action ()], Map.HashMap TypeRep BuiltinRule, Map.HashMap TypeRep UserRule_)
runRules :: ShakeOptions
-> Rules ()
-> IO
     ([Action ()], HashMap TypeRep BuiltinRule,
      HashMap TypeRep UserRule_)
runRules opts :: ShakeOptions
opts (Rules r :: WriterT SRules (ReaderT ShakeOptions IO) ()
r) = do
    SRules{..} <- ReaderT ShakeOptions IO SRules -> ShakeOptions -> IO SRules
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (WriterT SRules (ReaderT ShakeOptions IO) ()
-> ReaderT ShakeOptions IO SRules
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT WriterT SRules (ReaderT ShakeOptions IO) ()
r) ShakeOptions
opts
    ([Action ()], HashMap TypeRep BuiltinRule,
 HashMap TypeRep UserRule_)
-> IO
     ([Action ()], HashMap TypeRep BuiltinRule,
      HashMap TypeRep UserRule_)
forall (m :: * -> *) a. Monad m => a -> m a
return (ListBuilder (Action ()) -> [Action ()]
forall a. ListBuilder a -> [a]
runListBuilder ListBuilder (Action ())
actions, HashMap TypeRep BuiltinRule
builtinRules, HashMap TypeRep UserRule_
userRules)

data SRules = SRules
    {SRules -> ListBuilder (Action ())
actions :: !(ListBuilder (Action ()))
    ,SRules -> HashMap TypeRep BuiltinRule
builtinRules :: !(Map.HashMap TypeRep{-k-} BuiltinRule)
    ,SRules -> HashMap TypeRep UserRule_
userRules :: !(Map.HashMap TypeRep{-k-} UserRule_)
    }

instance Semigroup SRules where
    (SRules x1 :: ListBuilder (Action ())
x1 x2 :: HashMap TypeRep BuiltinRule
x2 x3 :: HashMap TypeRep UserRule_
x3) <> :: SRules -> SRules -> SRules
<> (SRules y1 :: ListBuilder (Action ())
y1 y2 :: HashMap TypeRep BuiltinRule
y2 y3 :: HashMap TypeRep UserRule_
y3) = ListBuilder (Action ())
-> HashMap TypeRep BuiltinRule
-> HashMap TypeRep UserRule_
-> SRules
SRules (ListBuilder (Action ())
-> ListBuilder (Action ()) -> ListBuilder (Action ())
forall a. Monoid a => a -> a -> a
mappend ListBuilder (Action ())
x1 ListBuilder (Action ())
y1) ((TypeRep -> BuiltinRule -> BuiltinRule -> BuiltinRule)
-> HashMap TypeRep BuiltinRule
-> HashMap TypeRep BuiltinRule
-> HashMap TypeRep BuiltinRule
forall k v.
(Eq k, Hashable k) =>
(k -> v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
Map.unionWithKey TypeRep -> BuiltinRule -> BuiltinRule -> BuiltinRule
forall p p a. TypeRep -> p -> p -> a
f HashMap TypeRep BuiltinRule
x2 HashMap TypeRep BuiltinRule
y2) ((UserRule_ -> UserRule_ -> UserRule_)
-> HashMap TypeRep UserRule_
-> HashMap TypeRep UserRule_
-> HashMap TypeRep UserRule_
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
Map.unionWith UserRule_ -> UserRule_ -> UserRule_
g HashMap TypeRep UserRule_
x3 HashMap TypeRep UserRule_
y3)
        where
            f :: TypeRep -> p -> p -> a
f k :: TypeRep
k _ _ = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ TypeRep -> IO a
forall a. TypeRep -> IO a
errorRuleDefinedMultipleTimes TypeRep
k
            g :: UserRule_ -> UserRule_ -> UserRule_
g (UserRule_ x :: UserRule a
x) (UserRule_ y) = UserRule a -> UserRule_
forall a. Typeable a => UserRule a -> UserRule_
UserRule_ (UserRule a -> UserRule_) -> UserRule a -> UserRule_
forall a b. (a -> b) -> a -> b
$ [UserRule a] -> UserRule a
forall a. [UserRule a] -> UserRule a
Unordered ([UserRule a] -> UserRule a) -> [UserRule a] -> UserRule a
forall a b. (a -> b) -> a -> b
$ UserRule a -> [UserRule a]
forall a. UserRule a -> [UserRule a]
fromUnordered UserRule a
x [UserRule a] -> [UserRule a] -> [UserRule a]
forall a. [a] -> [a] -> [a]
++ UserRule a -> [UserRule a]
forall a. UserRule a -> [UserRule a]
fromUnordered (Maybe (UserRule a) -> UserRule a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (UserRule a) -> UserRule a)
-> Maybe (UserRule a) -> UserRule a
forall a b. (a -> b) -> a -> b
$ UserRule a -> Maybe (UserRule a)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast UserRule a
y)

            fromUnordered :: UserRule a -> [UserRule a]
fromUnordered (Unordered xs :: [UserRule a]
xs) = [UserRule a]
xs
            fromUnordered x :: UserRule a
x = [UserRule a
x]

instance Monoid SRules where
    mempty :: SRules
mempty = ListBuilder (Action ())
-> HashMap TypeRep BuiltinRule
-> HashMap TypeRep UserRule_
-> SRules
SRules ListBuilder (Action ())
forall a. Monoid a => a
mempty HashMap TypeRep BuiltinRule
forall k v. HashMap k v
Map.empty HashMap TypeRep UserRule_
forall k v. HashMap k v
Map.empty
    mappend :: SRules -> SRules -> SRules
mappend = SRules -> SRules -> SRules
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup a => Semigroup (Rules a) where
    <> :: Rules a -> Rules a -> Rules a
(<>) = (a -> a -> a) -> Rules a -> Rules a -> Rules a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance (Semigroup a, Monoid a) => Monoid (Rules a) where
    mempty :: Rules a
mempty = a -> Rules a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Monoid a => a
mempty
    mappend :: Rules a -> Rules a -> Rules a
mappend = Rules a -> Rules a -> Rules a
forall a. Semigroup a => a -> a -> a
(<>)


-- | Add a value of type 'UserRule'.
addUserRule :: Typeable a => a -> Rules ()
addUserRule :: a -> Rules ()
addUserRule r :: a
r = SRules -> Rules ()
newRules SRules
forall a. Monoid a => a
mempty{userRules :: HashMap TypeRep UserRule_
userRules = TypeRep -> UserRule_ -> HashMap TypeRep UserRule_
forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
r) (UserRule_ -> HashMap TypeRep UserRule_)
-> UserRule_ -> HashMap TypeRep UserRule_
forall a b. (a -> b) -> a -> b
$ UserRule a -> UserRule_
forall a. Typeable a => UserRule a -> UserRule_
UserRule_ (UserRule a -> UserRule_) -> UserRule a -> UserRule_
forall a b. (a -> b) -> a -> b
$ a -> UserRule a
forall a. a -> UserRule a
UserRule a
r}

-- | A suitable 'BuiltinLint' that always succeeds.
noLint :: BuiltinLint key value
noLint :: BuiltinLint key value
noLint _ _ = Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing

type family RuleResult key -- = value

-- | Add a builtin rule, comprising of a lint rule and an action. Each builtin rule must be identified by
--   a unique key.
addBuiltinRule :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => BuiltinLint key value -> BuiltinRun key value -> Rules ()
addBuiltinRule :: BuiltinLint key value -> BuiltinRun key value -> Rules ()
addBuiltinRule = BinaryOp key
-> BuiltinLint key value -> BuiltinRun key value -> Rules ()
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value,
 NFData value, Show value) =>
BinaryOp key
-> BuiltinLint key value -> BuiltinRun key value -> Rules ()
addBuiltinRuleInternal (BinaryOp key
 -> BuiltinLint key value -> BuiltinRun key value -> Rules ())
-> BinaryOp key
-> BuiltinLint key value
-> BuiltinRun key value
-> Rules ()
forall a b. (a -> b) -> a -> b
$ (key -> Builder) -> (ByteString -> key) -> BinaryOp key
forall v. (v -> Builder) -> (ByteString -> v) -> BinaryOp v
BinaryOp
    (ByteString -> Builder
forall a. BinaryEx a => a -> Builder
putEx (ByteString -> Builder) -> (key -> ByteString) -> key -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Bin.toLazyByteString (Builder -> ByteString) -> (key -> Builder) -> key -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PutM () -> Builder
forall a. PutM a -> Builder
execPut (PutM () -> Builder) -> (key -> PutM ()) -> key -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. key -> PutM ()
forall t. Binary t => t -> PutM ()
put)
    (Get key -> ByteString -> key
forall a. Get a -> ByteString -> a
runGet Get key
forall t. Binary t => Get t
get (ByteString -> key)
-> (ByteString -> ByteString) -> ByteString -> key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
LBS.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return)

addBuiltinRuleEx :: (RuleResult key ~ value, ShakeValue key, BinaryEx key, Typeable value, NFData value, Show value) => BuiltinLint key value -> BuiltinRun key value -> Rules ()
addBuiltinRuleEx :: BuiltinLint key value -> BuiltinRun key value -> Rules ()
addBuiltinRuleEx = BinaryOp key
-> BuiltinLint key value -> BuiltinRun key value -> Rules ()
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value,
 NFData value, Show value) =>
BinaryOp key
-> BuiltinLint key value -> BuiltinRun key value -> Rules ()
addBuiltinRuleInternal (BinaryOp key
 -> BuiltinLint key value -> BuiltinRun key value -> Rules ())
-> BinaryOp key
-> BuiltinLint key value
-> BuiltinRun key value
-> Rules ()
forall a b. (a -> b) -> a -> b
$ (key -> Builder) -> (ByteString -> key) -> BinaryOp key
forall v. (v -> Builder) -> (ByteString -> v) -> BinaryOp v
BinaryOp key -> Builder
forall a. BinaryEx a => a -> Builder
putEx ByteString -> key
forall a. BinaryEx a => ByteString -> a
getEx


-- | Unexpected version of 'addBuiltinRule', which also lets me set the 'BinaryOp'.
addBuiltinRuleInternal :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value) => BinaryOp key -> BuiltinLint key value -> BuiltinRun key value -> Rules ()
addBuiltinRuleInternal :: BinaryOp key
-> BuiltinLint key value -> BuiltinRun key value -> Rules ()
addBuiltinRuleInternal binary :: BinaryOp key
binary lint :: BuiltinLint key value
lint (BuiltinRun key value
run :: BuiltinRun key value) = do
    let k :: Proxy key
k = Proxy key
forall k (t :: k). Proxy t
Proxy :: Proxy key
        v :: Proxy value
v = Proxy value
forall k (t :: k). Proxy t
Proxy :: Proxy value
    let run_ :: Key -> Maybe ByteString -> Bool -> Action (RunResult Value)
run_ k :: Key
k v :: Maybe ByteString
v b :: Bool
b = (value -> Value) -> RunResult value -> RunResult Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap value -> Value
forall a. (Typeable a, Show a, NFData a) => a -> Value
newValue (RunResult value -> RunResult Value)
-> Action (RunResult value) -> Action (RunResult Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuiltinRun key value
run (Key -> key
forall a. Typeable a => Key -> a
fromKey Key
k) Maybe ByteString
v Bool
b
    let lint_ :: Key -> Value -> IO (Maybe FilePath)
lint_ k :: Key
k v :: Value
v = BuiltinLint key value
lint (Key -> key
forall a. Typeable a => Key -> a
fromKey Key
k) (Value -> value
forall a. Typeable a => Value -> a
fromValue Value
v)
    let binary_ :: BinaryOp Key
binary_ = (Key -> Builder) -> (ByteString -> Key) -> BinaryOp Key
forall v. (v -> Builder) -> (ByteString -> v) -> BinaryOp v
BinaryOp (BinaryOp key -> key -> Builder
forall v. BinaryOp v -> v -> Builder
putOp BinaryOp key
binary (key -> Builder) -> (Key -> key) -> Key -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> key
forall a. Typeable a => Key -> a
fromKey) (key -> Key
forall a. ShakeValue a => a -> Key
newKey (key -> Key) -> (ByteString -> key) -> ByteString -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinaryOp key -> ByteString -> key
forall v. BinaryOp v -> ByteString -> v
getOp BinaryOp key
binary)
    SRules -> Rules ()
newRules SRules
forall a. Monoid a => a
mempty{builtinRules :: HashMap TypeRep BuiltinRule
builtinRules = TypeRep -> BuiltinRule -> HashMap TypeRep BuiltinRule
forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton (Proxy key -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy key
k) (BuiltinRule -> HashMap TypeRep BuiltinRule)
-> BuiltinRule -> HashMap TypeRep BuiltinRule
forall a b. (a -> b) -> a -> b
$ (Key -> Maybe ByteString -> Bool -> Action (RunResult Value))
-> (Key -> Value -> IO (Maybe FilePath))
-> TypeRep
-> BinaryOp Key
-> BuiltinRule
BuiltinRule Key -> Maybe ByteString -> Bool -> Action (RunResult Value)
run_ Key -> Value -> IO (Maybe FilePath)
lint_ (Proxy value -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy value
v) BinaryOp Key
binary_}


-- | Change the priority of a given set of rules, where higher priorities take precedence.
--   All matching rules at a given priority must be disjoint, or an error is raised.
--   All builtin Shake rules have priority between 0 and 1.
--   Excessive use of 'priority' is discouraged. As an example:
--
-- @
-- 'priority' 4 $ \"hello.*\" %> \\out -> 'writeFile'' out \"hello.*\"
-- 'priority' 8 $ \"*.txt\" %> \\out -> 'writeFile'' out \"*.txt\"
-- @
--
--   In this example @hello.txt@ will match the second rule, instead of raising an error about ambiguity.
--
--   The 'priority' function obeys the invariants:
--
-- @
-- 'priority' p1 ('priority' p2 r1) === 'priority' p1 r1
-- 'priority' p1 (r1 >> r2) === 'priority' p1 r1 >> 'priority' p1 r2
-- @
priority :: Double -> Rules () -> Rules ()
priority :: Seconds -> Rules () -> Rules ()
priority d :: Seconds
d = (SRules -> SRules) -> Rules () -> Rules ()
modifyRules ((SRules -> SRules) -> Rules () -> Rules ())
-> (SRules -> SRules) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ \s :: SRules
s -> SRules
s{userRules :: HashMap TypeRep UserRule_
userRules = (UserRule_ -> UserRule_)
-> HashMap TypeRep UserRule_ -> HashMap TypeRep UserRule_
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map UserRule_ -> UserRule_
f (HashMap TypeRep UserRule_ -> HashMap TypeRep UserRule_)
-> HashMap TypeRep UserRule_ -> HashMap TypeRep UserRule_
forall a b. (a -> b) -> a -> b
$ SRules -> HashMap TypeRep UserRule_
userRules SRules
s}
    where f :: UserRule_ -> UserRule_
f (UserRule_ s :: UserRule a
s) = UserRule a -> UserRule_
forall a. Typeable a => UserRule a -> UserRule_
UserRule_ (UserRule a -> UserRule_) -> UserRule a -> UserRule_
forall a b. (a -> b) -> a -> b
$ Seconds -> UserRule a -> UserRule a
forall a. Seconds -> UserRule a -> UserRule a
Priority Seconds
d UserRule a
s


-- | Change the matching behaviour of rules so rules do not have to be disjoint, but are instead matched
--   in order. Only recommended for small blocks containing a handful of rules.
--
-- @
-- 'alternatives' $ do
--     \"hello.*\" %> \\out -> 'writeFile'' out \"hello.*\"
--     \"*.txt\" %> \\out -> 'writeFile'' out \"*.txt\"
-- @
--
--   In this example @hello.txt@ will match the first rule, instead of raising an error about ambiguity.
--   Inside 'alternatives' the 'priority' of each rule is not used to determine which rule matches,
--   but the resulting match uses that priority compared to the rules outside the 'alternatives' block.
alternatives :: Rules () -> Rules ()
alternatives :: Rules () -> Rules ()
alternatives = (SRules -> SRules) -> Rules () -> Rules ()
modifyRules ((SRules -> SRules) -> Rules () -> Rules ())
-> (SRules -> SRules) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ \r :: SRules
r -> SRules
r{userRules :: HashMap TypeRep UserRule_
userRules = (UserRule_ -> UserRule_)
-> HashMap TypeRep UserRule_ -> HashMap TypeRep UserRule_
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map UserRule_ -> UserRule_
f (HashMap TypeRep UserRule_ -> HashMap TypeRep UserRule_)
-> HashMap TypeRep UserRule_ -> HashMap TypeRep UserRule_
forall a b. (a -> b) -> a -> b
$ SRules -> HashMap TypeRep UserRule_
userRules SRules
r}
    where f :: UserRule_ -> UserRule_
f (UserRule_ s :: UserRule a
s) = UserRule a -> UserRule_
forall a. Typeable a => UserRule a -> UserRule_
UserRule_ (UserRule a -> UserRule_) -> UserRule a -> UserRule_
forall a b. (a -> b) -> a -> b
$ UserRule a -> UserRule a
forall a. UserRule a -> UserRule a
Alternative UserRule a
s


-- | Run an action, usually used for specifying top-level requirements.
--
-- @
-- main = 'Development.Shake.shake' 'shakeOptions' $ do
--    'action' $ do
--        b <- 'Development.Shake.doesFileExist' \"file.src\"
--        when b $ 'Development.Shake.need' [\"file.out\"]
-- @
--
--   This 'action' builds @file.out@, but only if @file.src@ exists. The 'action'
--   will be run in every build execution (unless 'withoutActions' is used), so only cheap
--   operations should be performed. All arguments to 'action' may be run in parallel, in any order.
--
--   For the standard requirement of only 'Development.Shake.need'ing a fixed list of files in the 'action',
--   see 'Development.Shake.want'.
action :: Action a -> Rules ()
action :: Action a -> Rules ()
action a :: Action a
a = SRules -> Rules ()
newRules SRules
forall a. Monoid a => a
mempty{actions :: ListBuilder (Action ())
actions=Action () -> ListBuilder (Action ())
forall a. a -> ListBuilder a
newListBuilder (Action () -> ListBuilder (Action ()))
-> Action () -> ListBuilder (Action ())
forall a b. (a -> b) -> a -> b
$ Action a -> Action ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Action a
a}


-- | Remove all actions specified in a set of rules, usually used for implementing
--   command line specification of what to build.
withoutActions :: Rules () -> Rules ()
withoutActions :: Rules () -> Rules ()
withoutActions = (SRules -> SRules) -> Rules () -> Rules ()
modifyRules ((SRules -> SRules) -> Rules () -> Rules ())
-> (SRules -> SRules) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ \x :: SRules
x -> SRules
x{actions :: ListBuilder (Action ())
actions=ListBuilder (Action ())
forall a. Monoid a => a
mempty}