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

module Development.Shake.Internal.Rules.Oracle(
    addOracle, addOracleCache, askOracle
    ) where

import Development.Shake.Internal.Core.Run
import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Core.Rules
import Development.Shake.Internal.Options
import Development.Shake.Internal.Value
import Development.Shake.Classes
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Binary
import Control.Applicative
import Prelude


-- Use short type names, since the names appear in the Haddock, and are too long if they are in full
newtype OracleQ question = OracleQ question
    deriving (Int -> OracleQ question -> ShowS
[OracleQ question] -> ShowS
OracleQ question -> String
(Int -> OracleQ question -> ShowS)
-> (OracleQ question -> String)
-> ([OracleQ question] -> ShowS)
-> Show (OracleQ question)
forall question. Show question => Int -> OracleQ question -> ShowS
forall question. Show question => [OracleQ question] -> ShowS
forall question. Show question => OracleQ question -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OracleQ question] -> ShowS
$cshowList :: forall question. Show question => [OracleQ question] -> ShowS
show :: OracleQ question -> String
$cshow :: forall question. Show question => OracleQ question -> String
showsPrec :: Int -> OracleQ question -> ShowS
$cshowsPrec :: forall question. Show question => Int -> OracleQ question -> ShowS
Show,Typeable,OracleQ question -> OracleQ question -> Bool
(OracleQ question -> OracleQ question -> Bool)
-> (OracleQ question -> OracleQ question -> Bool)
-> Eq (OracleQ question)
forall question.
Eq question =>
OracleQ question -> OracleQ question -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OracleQ question -> OracleQ question -> Bool
$c/= :: forall question.
Eq question =>
OracleQ question -> OracleQ question -> Bool
== :: OracleQ question -> OracleQ question -> Bool
$c== :: forall question.
Eq question =>
OracleQ question -> OracleQ question -> Bool
Eq,Int -> OracleQ question -> Int
OracleQ question -> Int
(Int -> OracleQ question -> Int)
-> (OracleQ question -> Int) -> Hashable (OracleQ question)
forall question.
Hashable question =>
Int -> OracleQ question -> Int
forall question. Hashable question => OracleQ question -> Int
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: OracleQ question -> Int
$chash :: forall question. Hashable question => OracleQ question -> Int
hashWithSalt :: Int -> OracleQ question -> Int
$chashWithSalt :: forall question.
Hashable question =>
Int -> OracleQ question -> Int
Hashable,Get (OracleQ question)
[OracleQ question] -> Put
OracleQ question -> Put
(OracleQ question -> Put)
-> Get (OracleQ question)
-> ([OracleQ question] -> Put)
-> Binary (OracleQ question)
forall question. Binary question => Get (OracleQ question)
forall question. Binary question => [OracleQ question] -> Put
forall question. Binary question => OracleQ question -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [OracleQ question] -> Put
$cputList :: forall question. Binary question => [OracleQ question] -> Put
get :: Get (OracleQ question)
$cget :: forall question. Binary question => Get (OracleQ question)
put :: OracleQ question -> Put
$cput :: forall question. Binary question => OracleQ question -> Put
Binary,OracleQ question -> ()
(OracleQ question -> ()) -> NFData (OracleQ question)
forall question. NFData question => OracleQ question -> ()
forall a. (a -> ()) -> NFData a
rnf :: OracleQ question -> ()
$crnf :: forall question. NFData question => OracleQ question -> ()
NFData)
newtype OracleA answer = OracleA answer
    deriving (Int -> OracleA answer -> ShowS
[OracleA answer] -> ShowS
OracleA answer -> String
(Int -> OracleA answer -> ShowS)
-> (OracleA answer -> String)
-> ([OracleA answer] -> ShowS)
-> Show (OracleA answer)
forall answer. Show answer => Int -> OracleA answer -> ShowS
forall answer. Show answer => [OracleA answer] -> ShowS
forall answer. Show answer => OracleA answer -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OracleA answer] -> ShowS
$cshowList :: forall answer. Show answer => [OracleA answer] -> ShowS
show :: OracleA answer -> String
$cshow :: forall answer. Show answer => OracleA answer -> String
showsPrec :: Int -> OracleA answer -> ShowS
$cshowsPrec :: forall answer. Show answer => Int -> OracleA answer -> ShowS
Show,Typeable,OracleA answer -> OracleA answer -> Bool
(OracleA answer -> OracleA answer -> Bool)
-> (OracleA answer -> OracleA answer -> Bool)
-> Eq (OracleA answer)
forall answer.
Eq answer =>
OracleA answer -> OracleA answer -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OracleA answer -> OracleA answer -> Bool
$c/= :: forall answer.
Eq answer =>
OracleA answer -> OracleA answer -> Bool
== :: OracleA answer -> OracleA answer -> Bool
$c== :: forall answer.
Eq answer =>
OracleA answer -> OracleA answer -> Bool
Eq,Int -> OracleA answer -> Int
OracleA answer -> Int
(Int -> OracleA answer -> Int)
-> (OracleA answer -> Int) -> Hashable (OracleA answer)
forall answer. Hashable answer => Int -> OracleA answer -> Int
forall answer. Hashable answer => OracleA answer -> Int
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: OracleA answer -> Int
$chash :: forall answer. Hashable answer => OracleA answer -> Int
hashWithSalt :: Int -> OracleA answer -> Int
$chashWithSalt :: forall answer. Hashable answer => Int -> OracleA answer -> Int
Hashable,Get (OracleA answer)
[OracleA answer] -> Put
OracleA answer -> Put
(OracleA answer -> Put)
-> Get (OracleA answer)
-> ([OracleA answer] -> Put)
-> Binary (OracleA answer)
forall answer. Binary answer => Get (OracleA answer)
forall answer. Binary answer => [OracleA answer] -> Put
forall answer. Binary answer => OracleA answer -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [OracleA answer] -> Put
$cputList :: forall answer. Binary answer => [OracleA answer] -> Put
get :: Get (OracleA answer)
$cget :: forall answer. Binary answer => Get (OracleA answer)
put :: OracleA answer -> Put
$cput :: forall answer. Binary answer => OracleA answer -> Put
Binary,OracleA answer -> ()
(OracleA answer -> ()) -> NFData (OracleA answer)
forall answer. NFData answer => OracleA answer -> ()
forall a. (a -> ()) -> NFData a
rnf :: OracleA answer -> ()
$crnf :: forall answer. NFData answer => OracleA answer -> ()
NFData)

type instance RuleResult (OracleQ a) = OracleA (RuleResult a)


addOracleRaw :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => Bool -> (q -> Action a) -> Rules (q -> Action a)
addOracleRaw :: Bool -> (q -> Action a) -> Rules (q -> Action a)
addOracleRaw cache :: Bool
cache act :: q -> Action a
act = do
        -- rebuild is automatic for oracles, skip just means we don't rebuild
        ShakeOptions
opts <- Rules ShakeOptions
getShakeOptionsRules
        let skip :: Bool
skip = ShakeOptions -> String -> Rebuild
shakeRebuildApply ShakeOptions
opts "" Rebuild -> Rebuild -> Bool
forall a. Eq a => a -> a -> Bool
== Rebuild
RebuildLater

        BuiltinLint (OracleQ q) (OracleA a)
-> BuiltinRun (OracleQ q) (OracleA a) -> Rules ()
forall key value.
(RuleResult key ~ value, ShakeValue key, ShakeValue value) =>
BuiltinLint key value -> BuiltinRun key value -> Rules ()
addBuiltinRule BuiltinLint (OracleQ q) (OracleA a)
forall key value. BuiltinLint key value
noLint (BuiltinRun (OracleQ q) (OracleA a) -> Rules ())
-> BuiltinRun (OracleQ q) (OracleA a) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \(OracleQ q :: q
q) old :: Maybe ByteString
old changed :: Bool
changed -> case Maybe ByteString
old of
            Just old :: ByteString
old | Bool
skip Bool -> Bool -> Bool
|| (Bool
cache Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
changed) ->
                RunResult (OracleA a) -> Action (RunResult (OracleA a))
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult (OracleA a) -> Action (RunResult (OracleA a)))
-> RunResult (OracleA a) -> Action (RunResult (OracleA a))
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> OracleA a -> RunResult (OracleA a)
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult RunChanged
ChangedNothing ByteString
old (OracleA a -> RunResult (OracleA a))
-> OracleA a -> RunResult (OracleA a)
forall a b. (a -> b) -> a -> b
$ ByteString -> OracleA a
forall a. Binary a => ByteString -> a
decode' ByteString
old
            _ -> do
                OracleA a
new <- a -> OracleA a
forall answer. answer -> OracleA answer
OracleA (a -> OracleA a) -> Action a -> Action (OracleA a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> q -> Action a
act q
q
                RunResult (OracleA a) -> Action (RunResult (OracleA a))
forall (m :: * -> *) a. Monad m => a -> m a
return (RunResult (OracleA a) -> Action (RunResult (OracleA a)))
-> RunResult (OracleA a) -> Action (RunResult (OracleA a))
forall a b. (a -> b) -> a -> b
$ RunChanged -> ByteString -> OracleA a -> RunResult (OracleA a)
forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult
                    (if (ByteString -> OracleA a) -> Maybe ByteString -> Maybe (OracleA a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> OracleA a
forall a. Binary a => ByteString -> a
decode' Maybe ByteString
old Maybe (OracleA a) -> Maybe (OracleA a) -> Bool
forall a. Eq a => a -> a -> Bool
== OracleA a -> Maybe (OracleA a)
forall a. a -> Maybe a
Just OracleA a
new then RunChanged
ChangedRecomputeSame else RunChanged
ChangedRecomputeDiff)
                    (OracleA a -> ByteString
forall a. Binary a => a -> ByteString
encode' OracleA a
new)
                    OracleA a
new
        (q -> Action a) -> Rules (q -> Action a)
forall (m :: * -> *) a. Monad m => a -> m a
return q -> Action a
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle
    where
        encode' :: Binary a => a -> BS.ByteString
        encode' :: a -> ByteString
encode' = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> (a -> [ByteString]) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LBS.toChunks (ByteString -> [ByteString])
-> (a -> ByteString) -> a -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Binary a => a -> ByteString
encode

        decode' :: Binary a => BS.ByteString -> a
        decode' :: ByteString -> a
decode' = ByteString -> a
forall a. Binary a => ByteString -> a
decode (ByteString -> a) -> (ByteString -> ByteString) -> ByteString -> a
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


-- | Add extra information which rules can depend on.
--   An oracle is a function from a question type @q@, to an answer type @a@.
--   As an example, we can define an oracle allowing you to depend on the current version of GHC:
--
-- @
-- newtype GhcVersion = GhcVersion () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
-- type instance RuleResult GhcVersion = String
-- rules = do
--     'addOracle' $ \\(GhcVersion _) -> fmap 'Development.Shake.fromStdout' $ 'Development.Shake.cmd' \"ghc --numeric-version\" :: Action String
--     ... rules ...
-- @
--
--   If a rule calls @'askOracle' (GhcVersion ())@, that rule will be rerun whenever the GHC version changes.
--   Some notes:
--
-- * We define @GhcVersion@ with a @newtype@ around @()@, allowing the use of @GeneralizedNewtypeDeriving@.
--   All the necessary type classes are exported from "Development.Shake.Classes".
--
-- * The @type instance@ requires the extension @TypeFamilies@.
--
-- * Each call to 'addOracle' must use a different type of question.
--
-- * Actions passed to 'addOracle' will be run in every build they are required, even if nothing else changes,
--   so be careful of slow actions.
--   If the result of an oracle does not change it will not invalidate any rules depending on it.
--   To always rerun files rules see 'Development.Shake.alwaysRerun'.
--
-- * If the value returned by 'askOracle' is ignored then 'askOracleWith' may help avoid ambiguous type messages.
--   Alternatively, use the result of 'addOracle', which is 'askOracle' restricted to the correct type.
--
--   As a more complex example, consider tracking Haskell package versions:
--
-- @
-- newtype GhcPkgList = GhcPkgList () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
-- type instance RuleResult GhcPkgList = [(String, String)]
-- newtype GhcPkgVersion = GhcPkgVersion String deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
-- type instance RuleResult GhcPkgVersion = Maybe String
--
-- rules = do
--     getPkgList \<- 'addOracle' $ \\GhcPkgList{} -> do
--         Stdout out <- 'Development.Shake.cmd' \"ghc-pkg list --simple-output\"
--         return [(reverse b, reverse a) | x <- words out, let (a,_:b) = break (== \'-\') $ reverse x]
--
--     getPkgVersion \<- 'addOracle' $ \\(GhcPkgVersion pkg) -> do
--         pkgs <- getPkgList $ GhcPkgList ()
--         return $ lookup pkg pkgs
--
--     \"myrule\" %> \\_ -> do
--         getPkgVersion $ GhcPkgVersion \"shake\"
--         ... rule using the shake version ...
-- @
--
--   Using these definitions, any rule depending on the version of @shake@
--   should call @getPkgVersion $ GhcPkgVersion \"shake\"@ to rebuild when @shake@ is upgraded.
addOracle :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => (q -> Action a) -> Rules (q -> Action a)
addOracle :: (q -> Action a) -> Rules (q -> Action a)
addOracle = Bool -> (q -> Action a) -> Rules (q -> Action a)
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
Bool -> (q -> Action a) -> Rules (q -> Action a)
addOracleRaw Bool
False

-- | A combination of 'addOracle' and 'newCache' - an action that only runs when its dependencies change,
--   whose result is stored in the database.
--
-- * Does the information need recomputing every time? e.g. looking up stuff in the environment?
--   If so, use 'addOracle' instead.
--
-- * Is the action mostly deserisalising some file? If so, use 'newCache'.
--
-- * Is the operation expensive computation from other results? If so, use 'addOracleCache'.
--
--   An alternative to using 'addOracleCache' is introducing an intermediate file containing the result,
--   which requires less storage in the Shake database and can be inspected by existing file-system viewing
--   tools.
addOracleCache ::(RuleResult q ~ a, ShakeValue q, ShakeValue a) => (q -> Action a) -> Rules (q -> Action a)
addOracleCache :: (q -> Action a) -> Rules (q -> Action a)
addOracleCache = Bool -> (q -> Action a) -> Rules (q -> Action a)
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
Bool -> (q -> Action a) -> Rules (q -> Action a)
addOracleRaw Bool
True


-- | Get information previously added with 'addOracle' or 'addOracleCache'.
--   The question/answer types must match those provided previously.
askOracle :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => q -> Action a
askOracle :: q -> Action a
askOracle question :: q
question = do OracleA answer :: a
answer <- OracleQ q -> Action (OracleA a)
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value) =>
key -> Action value
apply1 (OracleQ q -> Action (OracleA a))
-> OracleQ q -> Action (OracleA a)
forall a b. (a -> b) -> a -> b
$ q -> OracleQ q
forall question. question -> OracleQ question
OracleQ q
question; a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return a
answer