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

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

import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Core.Rules
import Development.Shake.Internal.Options
import Development.Shake.Internal.Core.Build
import Development.Shake.Internal.Value
import Development.Shake.Classes
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Control.Monad
import Data.Binary
import General.Binary
import General.Extra


-- 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
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
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
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall {question}. Hashable question => Eq (OracleQ question)
forall question.
Hashable question =>
Int -> OracleQ question -> Int
forall question. Hashable question => OracleQ question -> Int
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
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 -> ()
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
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
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
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall {answer}. Hashable answer => Eq (OracleA answer)
forall answer. Hashable answer => Int -> OracleA answer -> Int
forall answer. Hashable answer => OracleA answer -> Int
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
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 -> ()
forall answer. NFData answer => OracleA answer -> ()
forall a. (a -> ()) -> NFData a
rnf :: OracleA answer -> ()
$crnf :: forall answer. NFData answer => OracleA answer -> ()
NFData)

fromOracleA :: OracleA a -> a
fromOracleA :: forall a. OracleA a -> a
fromOracleA (OracleA a
x) = a
x

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

data Flavor = Norm | Cache | Hash deriving Flavor -> Flavor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flavor -> Flavor -> Bool
$c/= :: Flavor -> Flavor -> Bool
== :: Flavor -> Flavor -> Bool
$c== :: Flavor -> Flavor -> Bool
Eq

addOracleFlavor :: (Located, RuleResult q ~ a, ShakeValue q, ShakeValue a) => Flavor -> (q -> Action a) -> Rules (q -> Action a)
addOracleFlavor :: forall q a.
(Located, RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
Flavor -> (q -> Action a) -> Rules (q -> Action a)
addOracleFlavor Flavor
flavor 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 String
"" forall a. Eq a => a -> a -> Bool
== Rebuild
RebuildLater

        forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value,
 NFData value, Show value, Located) =>
BuiltinLint key value
-> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()
addBuiltinRule forall key value. BuiltinLint key value
noLint (\OracleQ q
_ OracleA a
v -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
runBuilder forall a b. (a -> b) -> a -> b
$ forall a. BinaryEx a => a -> Builder
putEx forall a b. (a -> b) -> a -> b
$ forall a. Hashable a => a -> Int
hash OracleA a
v) forall a b. (a -> b) -> a -> b
$ \(OracleQ q
q) Maybe ByteString
old RunMode
mode -> case Maybe ByteString
old of
            Just ByteString
old | (Flavor
flavor forall a. Eq a => a -> a -> Bool
/= Flavor
Hash Bool -> Bool -> Bool
&& Bool
skip) Bool -> Bool -> Bool
|| (Flavor
flavor forall a. Eq a => a -> a -> Bool
== Flavor
Cache Bool -> Bool -> Bool
&& 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 b. (a -> b) -> a -> b
$ forall a. Binary a => ByteString -> a
decode' ByteString
old
            Maybe ByteString
_ -> do
                -- can only use cmpHash if flavor == Hash
                let cmpValue :: OracleA a -> RunChanged
cmpValue OracleA a
new = if forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Binary a => ByteString -> a
decode' Maybe ByteString
old forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just OracleA a
new then RunChanged
ChangedRecomputeSame else RunChanged
ChangedRecomputeDiff
                let cmpHash :: ByteString -> RunChanged
cmpHash ByteString
newHash = if Maybe ByteString
old forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
newHash then RunChanged
ChangedRecomputeSame else RunChanged
ChangedRecomputeDiff

                Maybe ByteString
cache <- if Flavor
flavor forall a. Eq a => a -> a -> Bool
== Flavor
Cache then Int -> Action (Maybe ByteString)
historyLoad Int
0 else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                case Maybe ByteString
cache of
                    Just ByteString
newEncode -> do
                        let new :: OracleA a
new = forall a. Binary a => ByteString -> a
decode' ByteString
newEncode
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult (OracleA a -> RunChanged
cmpValue OracleA a
new) ByteString
newEncode OracleA a
new
                    Maybe ByteString
Nothing -> do
                        OracleA a
new <- forall answer. answer -> OracleA answer
OracleA forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> q -> Action a
act q
q
                        let newHash :: ByteString
newHash = forall a. Hashable a => a -> ByteString
encodeHash OracleA a
new
                        let newEncode :: ByteString
newEncode = forall a. Binary a => a -> ByteString
encode' OracleA a
new
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flavor
flavor forall a. Eq a => a -> a -> Bool
== Flavor
Cache) forall a b. (a -> b) -> a -> b
$
                            Int -> ByteString -> Action ()
historySave Int
0 ByteString
newEncode
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                            if Flavor
flavor forall a. Eq a => a -> a -> Bool
== Flavor
Hash
                                then forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult (ByteString -> RunChanged
cmpHash ByteString
newHash) ByteString
newHash OracleA a
new
                                else forall value. RunChanged -> ByteString -> value -> RunResult value
RunResult (OracleA a -> RunChanged
cmpValue OracleA a
new) ByteString
newEncode OracleA a
new
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle
    where
        encodeHash :: Hashable a => a -> BS.ByteString
        encodeHash :: forall a. Hashable a => a -> ByteString
encodeHash = Builder -> ByteString
runBuilder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. BinaryEx a => a -> Builder
putEx forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Hashable a => a -> Int
hash

        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


-- | 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 _) -> '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'.
--
--   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\"
--         pure [(reverse b, reverse a) | x <- words out, let (a,_:b) = break (== \'-\') $ reverse x]
--
--     getPkgVersion \<- 'addOracle' $ \\(GhcPkgVersion pkg) -> do
--         pkgs <- getPkgList $ GhcPkgList ()
--         pure $ 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.
--
--   If you apply 'versioned' to an oracle it will cause that oracle result to be discarded, and not do early-termination.
addOracle :: (RuleResult q ~ a, ShakeValue q, ShakeValue a, Partial) => (q -> Action a) -> Rules (q -> Action a)
addOracle :: forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a, Located) =>
(q -> Action a) -> Rules (q -> Action a)
addOracle = forall a. Located => (Located => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall q a.
(Located, RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
Flavor -> (q -> Action a) -> Rules (q -> Action a)
addOracleFlavor Flavor
Norm


-- | An alternative to to 'addOracle' that relies on the 'hash' function providing a perfect equality,
--   doesn't support @--skip@, but requires less storage.
addOracleHash :: (RuleResult q ~ a, ShakeValue q, ShakeValue a, Partial) => (q -> Action a) -> Rules (q -> Action a)
addOracleHash :: forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a, Located) =>
(q -> Action a) -> Rules (q -> Action a)
addOracleHash = forall a. Located => (Located => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall q a.
(Located, RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
Flavor -> (q -> Action a) -> Rules (q -> Action a)
addOracleFlavor Flavor
Hash

-- | 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, Partial) => (q -> Action a) -> Rules (q -> Action a)
addOracleCache :: forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a, Located) =>
(q -> Action a) -> Rules (q -> Action a)
addOracleCache = forall a. Located => (Located => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall q a.
(Located, RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
Flavor -> (q -> Action a) -> Rules (q -> Action a)
addOracleFlavor Flavor
Cache


-- | 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 :: forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. OracleA a -> a
fromOracleA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key value.
(Located, RuleResult key ~ value, ShakeValue key,
 Typeable value) =>
key -> Action value
apply1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall question. question -> OracleQ question
OracleQ

-- | A parallel version of 'askOracle'.
askOracles :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => [q] -> Action [a]
askOracles :: forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
[q] -> Action [a]
askOracles = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall a. OracleA a -> a
fromOracleA) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key value.
(Located, RuleResult key ~ value, ShakeValue key,
 Typeable value) =>
[key] -> Action [value]
apply forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall question. question -> OracleQ question
OracleQ