Squashed 'hadrian/' content from commit 438dc57
[ghc.git] / src / Hadrian / Oracles / DirectoryContents.hs
1 {-# LANGUAGE TypeFamilies #-}
2 module Hadrian.Oracles.DirectoryContents (
3 directoryContents, copyDirectoryContents, directoryContentsOracle, copyDirectoryContentsUntracked,
4 Match (..), matches, matchAll
5 ) where
6
7 import Control.Monad
8 import Development.Shake
9 import Development.Shake.Classes
10 import Development.Shake.FilePath
11 import GHC.Generics
12
13 import Hadrian.Utilities
14
15 import qualified System.Directory.Extra as IO
16
17 data Match = Test FilePattern | Not Match | And [Match] | Or [Match]
18 deriving (Generic, Eq, Show, Typeable)
19
20 instance Binary Match
21 instance Hashable Match
22 instance NFData Match
23
24 -- | A 'Match' expression that always evaluates to 'True' (i.e. always matches).
25 matchAll :: Match
26 matchAll = And []
27
28 -- | Check if a file name matches a given 'Match' expression.
29 matches :: Match -> FilePath -> Bool
30 matches (Test p) f = p ?== f
31 matches (Not m) f = not $ matches m f
32 matches (And ms) f = all (`matches` f) ms
33 matches (Or ms) f = any (`matches` f) ms
34
35 -- | Given a 'Match' expression and a directory, recursively traverse it and all
36 -- its subdirectories to find and return all matching contents.
37 directoryContents :: Match -> FilePath -> Action [FilePath]
38 directoryContents expr dir = askOracle $ DirectoryContents (expr, dir)
39
40 -- | Copy the contents of the source directory that matches a given 'Match'
41 -- expression into the target directory. The copied contents is tracked.
42 copyDirectoryContents :: Match -> FilePath -> FilePath -> Action ()
43 copyDirectoryContents expr source target = do
44 putProgressInfo =<< renderAction "Copy directory contents" source target
45 let cp file = copyFile file $ target -/- makeRelative source file
46 mapM_ cp =<< directoryContents expr source
47
48 -- | Copy the contents of the source directory that matches a given 'Match'
49 -- expression into the target directory. The copied contents is untracked.
50 copyDirectoryContentsUntracked :: Match -> FilePath -> FilePath -> Action ()
51 copyDirectoryContentsUntracked expr source target = do
52 putProgressInfo =<< renderAction "Copy directory contents (untracked)" source target
53 let cp file = copyFileUntracked file $ target -/- makeRelative source file
54 mapM_ cp =<< directoryContents expr source
55
56 newtype DirectoryContents = DirectoryContents (Match, FilePath)
57 deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
58 type instance RuleResult DirectoryContents = [FilePath]
59
60 -- | This oracle answers 'directoryContents' queries and tracks the results.
61 directoryContentsOracle :: Rules ()
62 directoryContentsOracle = void $
63 addOracle $ \(DirectoryContents (expr, dir)) -> liftIO $ map unifyPath .
64 filter (matches expr) <$> IO.listFilesInside (return . matches expr) dir