Move ArgsHash oracle to the library

See #347

hadrian.cabal

@@ -27,8 +27,8 @@ executable hadrian
                        , Flavour
                        , GHC
                        , Hadrian.Expression
+                       , Hadrian.Oracles.ArgsHash
                        , Hadrian.Target
-                       , Oracles.ArgsHash
                        , Oracles.Config
                        , Oracles.Config.Flag
                        , Oracles.Config.Setting

src/Builder.hs

 {-# LANGUAGE DeriveGeneric, LambdaCase #-}
 module Builder (
-    CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..),
-    trackedArgument, isOptional
+    CcMode (..), GhcMode (..), GhcPkgMode (..), Builder (..), isOptional
     ) where
 
-import Data.Char
 import GHC.Generics
 
 import Base
@@ -65,17 +63,6 @@ isOptional = \case
     Objdump  -> True
     _        -> False
 
--- | Some arguments do not affect build results and therefore do not need to be
--- tracked by the build system. A notable example is "-jN" that controls Make's
--- parallelism. Given a 'Builder' and an argument, this function should return
--- 'True' only if the argument needs to be tracked.
-trackedArgument :: Builder -> String -> Bool
-trackedArgument (Make _) = not . threadArg
-trackedArgument _        = const True
-
-threadArg :: String -> Bool
-threadArg s = dropWhileEnd isDigit s `elem` ["-j", "MAKEFLAGS=-j", "THREADS="]
-
 instance Binary Builder
 instance Hashable Builder
 instance NFData Builder

src/Oracles/ArgsHash.hs → src/Hadrian/Oracles/ArgsHash.hs

 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Oracles.ArgsHash (checkArgsHash, argsHashOracle) where
+module Hadrian.Oracles.ArgsHash (
+    TrackArgument, trackAllArguments, checkArgsHash, argsHashOracle
+    ) where
 
-import Base
-import Builder
-import Expression
-import Settings
-import Target
+import Control.Monad
+import Development.Shake
+import Development.Shake.Classes
 
-newtype ArgsHashKey = ArgsHashKey Target
+import Hadrian.Expression
+import Hadrian.Target
+
+-- | 'TrackArgument' is used to specify the arguments that should be tracked by
+-- the @ArgsHash@ oracle. The safest option is to track all arguments, but some
+-- arguments, such as @-jN@, do not change the build results, hence there is no
+-- need to initiate unnecessary rebuild if they are added to or removed from a
+-- command line. If all arguments should be tracked, use 'trackAllArguments'.
+type TrackArgument c b = Target c b -> String -> Bool
+
+-- | Returns 'True' for all targets and arguments, hence can be used a safe
+-- default for 'argsHashOracle'.
+trackAllArguments :: TrackArgument c b
+trackAllArguments _ _ = True
+
+newtype ArgsHashKey c b = ArgsHashKey (Target c b)
     deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
 
--- TODO: Hash Target to improve accuracy and performance.
--- | Given a full target this Action determines the corresponding argument list
+-- | Given a 'Target' this 'Action' determines the corresponding argument list
 -- and computes its hash. The resulting value is tracked in a Shake oracle,
 -- hence initiating rebuilds when the hash changes (a hash change indicates
 -- changes in the build command for the given target).
--- Note: we keep only the first target input for performance reasons -- to
--- avoid storing long lists of source files passed to some builders (e.g. Ar)
+-- Note: for efficiency we replace the list of input files with its hash to
+-- avoid storing long lists of source files passed to some builders (e.g. ar)
 -- in the Shake database. This optimisation is normally harmless, because
 -- argument list constructors are assumed not to examine target sources, but
 -- only append them to argument lists where appropriate.
-checkArgsHash :: Target -> Action ()
+checkArgsHash :: (ShakeValue c, ShakeValue b) => Target c b -> Action ()
 checkArgsHash t = do
-    let hashedInputs = [ show $ hash (inputs t) ]
+    let hashedInputs  = [ show $ hash (inputs t) ]
         hashedTarget = target (context t) (builder t) hashedInputs (outputs t)
     void (askOracle $ ArgsHashKey hashedTarget :: Action Int)
 
 -- | Oracle for storing per-target argument list hashes.
-argsHashOracle :: Rules ()
-argsHashOracle = void $
+argsHashOracle :: (ShakeValue c, ShakeValue b) => TrackArgument c b -> Args c b -> Rules ()
+argsHashOracle trackArgument args = void $
     addOracle $ \(ArgsHashKey target) -> do
-        argList <- interpret target getArgs
-        let trackedArgList = filter (trackedArgument $ builder target) argList
+        argList <- interpret target args
+        let trackedArgList = filter (trackArgument target) argList
         return $ hash trackedArgList

src/Hadrian/Target.hs

 {-# LANGUAGE DeriveGeneric #-}
 module Hadrian.Target (Target, target, context, builder, inputs, outputs) where
 
+import Development.Shake.Classes
 import GHC.Generics
 
-import Base
-
 -- | Each invocation of a builder is fully described by a 'Target', which
 -- comprises a build context (type variable @c@), a builder (type variable @b@),
 -- a list of input files and a list of output files. For example:

src/Rules/Oracles.hs

 module Rules.Oracles (oracleRules) where
 
+import qualified Hadrian.Oracles.ArgsHash
+
 import Base
-import qualified Oracles.ArgsHash
 import qualified Oracles.Config
 import qualified Oracles.Dependencies
 import qualified Oracles.DirectoryContents
 import qualified Oracles.ModuleFiles
 import qualified Oracles.PackageData
 import qualified Oracles.Path
+import Target
+import Settings
 
 oracleRules :: Rules ()
 oracleRules = do
-    Oracles.ArgsHash.argsHashOracle
+    Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs
     Oracles.Config.configOracle
     Oracles.Dependencies.dependenciesOracles
     Oracles.DirectoryContents.directoryContentsOracle

src/Rules/Selftest.hs

@@ -12,6 +12,7 @@ import Oracles.Config.Setting
 import Oracles.ModuleFiles
 import Settings
 import Settings.Builders.Ar
+import Target
 import UserSettings
 
 instance Arbitrary Way where
@@ -36,11 +37,12 @@ selftestRules =
 
 testBuilder :: Action ()
 testBuilder = do
-    putBuild $ "==== trackedArgument"
+    putBuild $ "==== trackArgument"
+    let make = target undefined (Make undefined) undefined undefined
     test $ forAll (elements ["-j", "MAKEFLAGS=-j", "THREADS="])
          $ \prefix (NonNegative n) ->
-            trackedArgument (Make undefined) prefix == False &&
-            trackedArgument (Make undefined) ("-j" ++ show (n :: Int)) == False
+            trackArgument make prefix == False &&
+            trackArgument make ("-j" ++ show (n :: Int)) == False
 
 testChunksOfSize :: Action ()
 testChunksOfSize = do

src/Target.hs

-module Target (Target, target, context, builder, inputs, outputs) where
+module Target (
+    Target, target, context, builder, inputs, outputs, trackArgument
+    ) where
 
-import Builder
-import Context
+import Data.Char
+import Data.List.Extra
 
 import qualified Hadrian.Target as H
 import Hadrian.Target hiding (Target)
 
+import Builder
+import Context
+
 type Target = H.Target Context Builder
+
+-- | Some arguments do not affect build results and therefore do not need to be
+-- tracked by the build system. A notable example is "-jN" that controls Make's
+-- parallelism. Given a 'Target' and an argument, this function should return
+-- 'True' only if the argument needs to be tracked.
+trackArgument :: Target -> String -> Bool
+trackArgument target arg = case builder target of
+    (Make _) -> not $ threadArg arg
+    _        -> True
+  where
+    threadArg s = dropWhileEnd isDigit s `elem` ["-j", "MAKEFLAGS=-j", "THREADS="]

src/Util.hs

@@ -11,12 +11,13 @@ import qualified System.Directory.Extra as IO
 import qualified System.IO              as IO
 import qualified Control.Exception.Base as IO
 
+import Hadrian.Oracles.ArgsHash
+
 import Base
 import CmdLineFlag
 import Context
 import Expression
 import GHC
-import Oracles.ArgsHash
 import Oracles.DirectoryContents
 import Oracles.Path
 import Oracles.Config.Setting