[commit: ghc] wip/nfs-locking: Move DirectoryContents oracle to the library (7ff841e)

git at git.haskell.org git at git.haskell.org
Fri Oct 27 00:36:51 UTC 2017


Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/7ff841eb492e16bedfb1d72152e5fc0de4d52c77/ghc

>---------------------------------------------------------------

commit 7ff841eb492e16bedfb1d72152e5fc0de4d52c77
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Sun Aug 6 01:31:02 2017 +0100

    Move DirectoryContents oracle to the library
    
    See #347


>---------------------------------------------------------------

7ff841eb492e16bedfb1d72152e5fc0de4d52c77
 hadrian.cabal                                  |  3 ++-
 src/Base.hs                                    | 14 +-------------
 src/{ => Hadrian}/Oracles/DirectoryContents.hs | 18 +++++++++++-------
 src/Hadrian/Utilities.hs                       | 19 +++++++++++++++++++
 src/Rules/Install.hs                           |  3 ++-
 src/Rules/Oracles.hs                           |  4 ++--
 src/Rules/SourceDist.hs                        |  3 ++-
 src/Util.hs                                    |  2 +-
 8 files changed, 40 insertions(+), 26 deletions(-)

diff --git a/hadrian.cabal b/hadrian.cabal
index 121ba74..b757549 100644
--- a/hadrian.cabal
+++ b/hadrian.cabal
@@ -28,12 +28,13 @@ executable hadrian
                        , GHC
                        , Hadrian.Expression
                        , Hadrian.Oracles.ArgsHash
+                       , Hadrian.Oracles.DirectoryContents
                        , Hadrian.Target
+                       , Hadrian.Utilities
                        , Oracles.Config
                        , Oracles.Config.Flag
                        , Oracles.Config.Setting
                        , Oracles.Dependencies
-                       , Oracles.DirectoryContents
                        , Oracles.ModuleFiles
                        , Oracles.PackageData
                        , Oracles.Path
diff --git a/src/Base.hs b/src/Base.hs
index 9e2922b..7443438 100644
--- a/src/Base.hs
+++ b/src/Base.hs
@@ -33,6 +33,7 @@ import Data.Semigroup
 import Development.Shake hiding (parallel, unit, (*>), Normal)
 import Development.Shake.Classes
 import Development.Shake.FilePath
+import Hadrian.Utilities
 import System.Console.ANSI
 import System.IO
 import System.Info
@@ -72,19 +73,6 @@ replaceWhen p to = map (\from -> if p from then to else from)
 quote :: String -> String
 quote s = "'" ++ s ++ "'"
 
--- | Normalise a path and convert all path separators to @/@, even on Windows.
-unifyPath :: FilePath -> FilePath
-unifyPath = toStandard . normaliseEx
-
--- | Combine paths with a forward slash regardless of platform.
-(-/-) :: FilePath -> FilePath -> FilePath
-"" -/- b = b
-a  -/- b
-    | last a == '/' = a ++       b
-    | otherwise     = a ++ '/' : b
-
-infixr 6 -/-
-
 -- Explicit definition to avoid dependency on Data.List.Ordered
 -- | Difference of two ordered lists.
 minusOrd :: Ord a => [a] -> [a] -> [a]
diff --git a/src/Oracles/DirectoryContents.hs b/src/Hadrian/Oracles/DirectoryContents.hs
similarity index 82%
rename from src/Oracles/DirectoryContents.hs
rename to src/Hadrian/Oracles/DirectoryContents.hs
index 1f016ff..e52c5c5 100644
--- a/src/Oracles/DirectoryContents.hs
+++ b/src/Hadrian/Oracles/DirectoryContents.hs
@@ -1,12 +1,15 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}
-module Oracles.DirectoryContents (
+module Hadrian.Oracles.DirectoryContents (
     directoryContents, directoryContentsOracle, Match (..), matchAll
     ) where
 
-import System.Directory.Extra
+import Control.Monad
+import Development.Shake
+import Development.Shake.Classes
 import GHC.Generics
+import System.Directory.Extra
 
-import Base
+import Hadrian.Utilities
 
 newtype DirectoryContents = DirectoryContents (Match, FilePath)
     deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
@@ -14,6 +17,10 @@ newtype DirectoryContents = DirectoryContents (Match, FilePath)
 data Match = Test FilePattern | Not Match | And [Match] | Or [Match]
     deriving (Generic, Eq, Show, Typeable)
 
+instance Binary   Match
+instance Hashable Match
+instance NFData   Match
+
 -- | A 'Match' expression that always evaluates to 'True' (i.e. always matches).
 matchAll :: Match
 matchAll = And []
@@ -30,11 +37,8 @@ matches (Or  ms) f = any (`matches` f) ms
 directoryContents :: Match -> FilePath -> Action [FilePath]
 directoryContents expr dir = askOracle $ DirectoryContents (expr, dir)
 
+-- | This oracle answers 'directoryContents' queries and tracks the results.
 directoryContentsOracle :: Rules ()
 directoryContentsOracle = void $
     addOracle $ \(DirectoryContents (expr, dir)) -> liftIO $ map unifyPath .
         filter (matches expr) <$> listFilesInside (return . matches expr) dir
-
-instance Binary Match
-instance Hashable Match
-instance NFData Match
diff --git a/src/Hadrian/Utilities.hs b/src/Hadrian/Utilities.hs
new file mode 100644
index 0000000..2103452
--- /dev/null
+++ b/src/Hadrian/Utilities.hs
@@ -0,0 +1,19 @@
+module Hadrian.Utilities (
+    -- * FilePath manipulation
+    unifyPath, (-/-)
+    ) where
+
+import Development.Shake.FilePath
+
+-- | Normalise a path and convert all path separators to @/@, even on Windows.
+unifyPath :: FilePath -> FilePath
+unifyPath = toStandard . normaliseEx
+
+-- | Combine paths with a forward slash regardless of platform.
+(-/-) :: FilePath -> FilePath -> FilePath
+"" -/- b = b
+a  -/- b
+    | last a == '/' = a ++       b
+    | otherwise     = a ++ '/' : b
+
+infixr 6 -/-
diff --git a/src/Rules/Install.hs b/src/Rules/Install.hs
index 66e57bf..f90b480 100644
--- a/src/Rules/Install.hs
+++ b/src/Rules/Install.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 module Rules.Install (installRules) where
 
+import Hadrian.Oracles.DirectoryContents
+
 import Base
 import Target
 import Context
@@ -16,7 +18,6 @@ import Rules.Generate
 import Settings.Packages.Rts
 import Oracles.Config.Setting
 import Oracles.Dependencies
-import Oracles.DirectoryContents
 import Oracles.Path
 
 import qualified System.Directory as IO
diff --git a/src/Rules/Oracles.hs b/src/Rules/Oracles.hs
index a12bec4..59b55d9 100644
--- a/src/Rules/Oracles.hs
+++ b/src/Rules/Oracles.hs
@@ -1,11 +1,11 @@
 module Rules.Oracles (oracleRules) where
 
 import qualified Hadrian.Oracles.ArgsHash
+import qualified Hadrian.Oracles.DirectoryContents
 
 import Base
 import qualified Oracles.Config
 import qualified Oracles.Dependencies
-import qualified Oracles.DirectoryContents
 import qualified Oracles.ModuleFiles
 import qualified Oracles.PackageData
 import qualified Oracles.Path
@@ -15,9 +15,9 @@ import Settings
 oracleRules :: Rules ()
 oracleRules = do
     Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs
+    Hadrian.Oracles.DirectoryContents.directoryContentsOracle
     Oracles.Config.configOracle
     Oracles.Dependencies.dependenciesOracles
-    Oracles.DirectoryContents.directoryContentsOracle
     Oracles.ModuleFiles.moduleFilesOracle
     Oracles.PackageData.packageDataOracle
     Oracles.Path.pathOracle
diff --git a/src/Rules/SourceDist.hs b/src/Rules/SourceDist.hs
index 40a4156..879ae34 100644
--- a/src/Rules/SourceDist.hs
+++ b/src/Rules/SourceDist.hs
@@ -1,9 +1,10 @@
 module Rules.SourceDist (sourceDistRules) where
 
+import Hadrian.Oracles.DirectoryContents
+
 import Base
 import Builder
 import Oracles.Config.Setting
-import Oracles.DirectoryContents
 import Rules.Clean
 import UserSettings
 import Util
diff --git a/src/Util.hs b/src/Util.hs
index c4b888d..a616b04 100644
--- a/src/Util.hs
+++ b/src/Util.hs
@@ -12,13 +12,13 @@ import qualified System.IO              as IO
 import qualified Control.Exception.Base as IO
 
 import Hadrian.Oracles.ArgsHash
+import Hadrian.Oracles.DirectoryContents
 
 import Base
 import CmdLineFlag
 import Context
 import Expression
 import GHC
-import Oracles.DirectoryContents
 import Oracles.Path
 import Oracles.Config.Setting
 import Settings



More information about the ghc-commits mailing list