Commit 7ff841eb authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Move DirectoryContents oracle to the library

See #347
parent 5e1d004c
...@@ -28,12 +28,13 @@ executable hadrian ...@@ -28,12 +28,13 @@ executable hadrian
, GHC , GHC
, Hadrian.Expression , Hadrian.Expression
, Hadrian.Oracles.ArgsHash , Hadrian.Oracles.ArgsHash
, Hadrian.Oracles.DirectoryContents
, Hadrian.Target , Hadrian.Target
, Hadrian.Utilities
, Oracles.Config , Oracles.Config
, Oracles.Config.Flag , Oracles.Config.Flag
, Oracles.Config.Setting , Oracles.Config.Setting
, Oracles.Dependencies , Oracles.Dependencies
, Oracles.DirectoryContents
, Oracles.ModuleFiles , Oracles.ModuleFiles
, Oracles.PackageData , Oracles.PackageData
, Oracles.Path , Oracles.Path
......
...@@ -33,6 +33,7 @@ import Data.Semigroup ...@@ -33,6 +33,7 @@ import Data.Semigroup
import Development.Shake hiding (parallel, unit, (*>), Normal) import Development.Shake hiding (parallel, unit, (*>), Normal)
import Development.Shake.Classes import Development.Shake.Classes
import Development.Shake.FilePath import Development.Shake.FilePath
import Hadrian.Utilities
import System.Console.ANSI import System.Console.ANSI
import System.IO import System.IO
import System.Info import System.Info
...@@ -72,19 +73,6 @@ replaceWhen p to = map (\from -> if p from then to else from) ...@@ -72,19 +73,6 @@ replaceWhen p to = map (\from -> if p from then to else from)
quote :: String -> String quote :: String -> String
quote s = "'" ++ s ++ "'" 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 -- Explicit definition to avoid dependency on Data.List.Ordered
-- | Difference of two ordered lists. -- | Difference of two ordered lists.
minusOrd :: Ord a => [a] -> [a] -> [a] minusOrd :: Ord a => [a] -> [a] -> [a]
......
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}
module Oracles.DirectoryContents ( module Hadrian.Oracles.DirectoryContents (
directoryContents, directoryContentsOracle, Match (..), matchAll directoryContents, directoryContentsOracle, Match (..), matchAll
) where ) where
import System.Directory.Extra import Control.Monad
import Development.Shake
import Development.Shake.Classes
import GHC.Generics import GHC.Generics
import System.Directory.Extra
import Base import Hadrian.Utilities
newtype DirectoryContents = DirectoryContents (Match, FilePath) newtype DirectoryContents = DirectoryContents (Match, FilePath)
deriving (Binary, Eq, Hashable, NFData, Show, Typeable) deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
...@@ -14,6 +17,10 @@ newtype DirectoryContents = DirectoryContents (Match, FilePath) ...@@ -14,6 +17,10 @@ newtype DirectoryContents = DirectoryContents (Match, FilePath)
data Match = Test FilePattern | Not Match | And [Match] | Or [Match] data Match = Test FilePattern | Not Match | And [Match] | Or [Match]
deriving (Generic, Eq, Show, Typeable) 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). -- | A 'Match' expression that always evaluates to 'True' (i.e. always matches).
matchAll :: Match matchAll :: Match
matchAll = And [] matchAll = And []
...@@ -30,11 +37,8 @@ matches (Or ms) f = any (`matches` f) ms ...@@ -30,11 +37,8 @@ matches (Or ms) f = any (`matches` f) ms
directoryContents :: Match -> FilePath -> Action [FilePath] directoryContents :: Match -> FilePath -> Action [FilePath]
directoryContents expr dir = askOracle $ DirectoryContents (expr, dir) directoryContents expr dir = askOracle $ DirectoryContents (expr, dir)
-- | This oracle answers 'directoryContents' queries and tracks the results.
directoryContentsOracle :: Rules () directoryContentsOracle :: Rules ()
directoryContentsOracle = void $ directoryContentsOracle = void $
addOracle $ \(DirectoryContents (expr, dir)) -> liftIO $ map unifyPath . addOracle $ \(DirectoryContents (expr, dir)) -> liftIO $ map unifyPath .
filter (matches expr) <$> listFilesInside (return . matches expr) dir filter (matches expr) <$> listFilesInside (return . matches expr) dir
instance Binary Match
instance Hashable Match
instance NFData Match
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 -/-
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
module Rules.Install (installRules) where module Rules.Install (installRules) where
import Hadrian.Oracles.DirectoryContents
import Base import Base
import Target import Target
import Context import Context
...@@ -16,7 +18,6 @@ import Rules.Generate ...@@ -16,7 +18,6 @@ import Rules.Generate
import Settings.Packages.Rts import Settings.Packages.Rts
import Oracles.Config.Setting import Oracles.Config.Setting
import Oracles.Dependencies import Oracles.Dependencies
import Oracles.DirectoryContents
import Oracles.Path import Oracles.Path
import qualified System.Directory as IO import qualified System.Directory as IO
......
module Rules.Oracles (oracleRules) where module Rules.Oracles (oracleRules) where
import qualified Hadrian.Oracles.ArgsHash import qualified Hadrian.Oracles.ArgsHash
import qualified Hadrian.Oracles.DirectoryContents
import Base import Base
import qualified Oracles.Config import qualified Oracles.Config
import qualified Oracles.Dependencies import qualified Oracles.Dependencies
import qualified Oracles.DirectoryContents
import qualified Oracles.ModuleFiles import qualified Oracles.ModuleFiles
import qualified Oracles.PackageData import qualified Oracles.PackageData
import qualified Oracles.Path import qualified Oracles.Path
...@@ -15,9 +15,9 @@ import Settings ...@@ -15,9 +15,9 @@ import Settings
oracleRules :: Rules () oracleRules :: Rules ()
oracleRules = do oracleRules = do
Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs
Hadrian.Oracles.DirectoryContents.directoryContentsOracle
Oracles.Config.configOracle Oracles.Config.configOracle
Oracles.Dependencies.dependenciesOracles Oracles.Dependencies.dependenciesOracles
Oracles.DirectoryContents.directoryContentsOracle
Oracles.ModuleFiles.moduleFilesOracle Oracles.ModuleFiles.moduleFilesOracle
Oracles.PackageData.packageDataOracle Oracles.PackageData.packageDataOracle
Oracles.Path.pathOracle Oracles.Path.pathOracle
module Rules.SourceDist (sourceDistRules) where module Rules.SourceDist (sourceDistRules) where
import Hadrian.Oracles.DirectoryContents
import Base import Base
import Builder import Builder
import Oracles.Config.Setting import Oracles.Config.Setting
import Oracles.DirectoryContents
import Rules.Clean import Rules.Clean
import UserSettings import UserSettings
import Util import Util
......
...@@ -12,13 +12,13 @@ import qualified System.IO as IO ...@@ -12,13 +12,13 @@ import qualified System.IO as IO
import qualified Control.Exception.Base as IO import qualified Control.Exception.Base as IO
import Hadrian.Oracles.ArgsHash import Hadrian.Oracles.ArgsHash
import Hadrian.Oracles.DirectoryContents
import Base import Base
import CmdLineFlag import CmdLineFlag
import Context import Context
import Expression import Expression
import GHC import GHC
import Oracles.DirectoryContents
import Oracles.Path import Oracles.Path
import Oracles.Config.Setting import Oracles.Config.Setting
import Settings import Settings
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment