Oracle.hs

{-# 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 (Show,Typeable,Eq,Hashable,Binary,NFData)
newtype OracleA answer = OracleA answer
    deriving (Show,Typeable,Eq,Hashable,Binary,NFData)

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

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

data Flavor = Norm | Cache | Hash deriving Eq

addOracleFlavor :: (Located, RuleResult q ~ a, ShakeValue q, ShakeValue a) => Flavor -> (q -> Action a) -> Rules (q -> Action a)
addOracleFlavor flavor act = do
        -- rebuild is automatic for oracles, skip just means we don't rebuild
        opts <- getShakeOptionsRules
        let skip = shakeRebuildApply opts "" == RebuildLater

        addBuiltinRule noLint (\_ v -> Just $ runBuilder $ putEx $ hash v) $ \(OracleQ q) old mode -> case old of
            Just old | (flavor /= Hash && skip) || (flavor == Cache && mode == RunDependenciesSame) ->
                pure $ RunResult ChangedNothing old $ decode' old
            _ -> do
                -- can only use cmpHash if flavor == Hash
                let cmpValue new = if fmap decode' old == Just new then ChangedRecomputeSame else ChangedRecomputeDiff
                let cmpHash newHash = if old == Just newHash then ChangedRecomputeSame else ChangedRecomputeDiff

                cache <- if flavor == Cache then historyLoad 0 else pure Nothing
                case cache of
                    Just newEncode -> do
                        let new = decode' newEncode
                        pure $ RunResult (cmpValue new) newEncode new
                    Nothing -> do
                        new <- OracleA <$> act q
                        let newHash = encodeHash new
                        let newEncode = encode' new
                        when (flavor == Cache) $
                            historySave 0 newEncode
                        pure $
                            if flavor == Hash
                                then RunResult (cmpHash newHash) newHash new
                                else RunResult (cmpValue new) newEncode new
        pure askOracle
    where
        encodeHash :: Hashable a => a -> BS.ByteString
        encodeHash = runBuilder . putEx . hash

        encode' :: Binary a => a -> BS.ByteString
        encode' = BS.concat . LBS.toChunks . encode

        decode' :: Binary a => BS.ByteString -> a
        decode' = decode . LBS.fromChunks . 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 = withFrozenCallStack $ addOracleFlavor 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 = withFrozenCallStack $ addOracleFlavor 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 = withFrozenCallStack $ addOracleFlavor 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 = fmap fromOracleA . apply1 . OracleQ

-- | A parallel version of 'askOracle'.
askOracles :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => [q] -> Action [a]
askOracles = fmap (map fromOracleA) . apply . map OracleQ