DirectoryContents.hs 1.56 KB
Newer Older
1
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}
2
module Hadrian.Oracles.DirectoryContents (
Andrey Mokhov's avatar
Andrey Mokhov committed
3
    directoryContents, directoryContentsOracle, Match (..), matchAll
kaiha's avatar
kaiha committed
4
5
    ) where

6
7
8
import Control.Monad
import Development.Shake
import Development.Shake.Classes
Andrey Mokhov's avatar
Andrey Mokhov committed
9
import GHC.Generics
10
import System.Directory.Extra
Andrey Mokhov's avatar
Andrey Mokhov committed
11

12
import Hadrian.Utilities
kaiha's avatar
kaiha committed
13

Andrey Mokhov's avatar
Andrey Mokhov committed
14
newtype DirectoryContents = DirectoryContents (Match, FilePath)
kaiha's avatar
kaiha committed
15
16
    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)

Andrey Mokhov's avatar
Andrey Mokhov committed
17
data Match = Test FilePattern | Not Match | And [Match] | Or [Match]
18
19
    deriving (Generic, Eq, Show, Typeable)

20
21
22
23
instance Binary   Match
instance Hashable Match
instance NFData   Match

Andrey Mokhov's avatar
Andrey Mokhov committed
24
25
26
27
28
-- | A 'Match' expression that always evaluates to 'True' (i.e. always matches).
matchAll :: Match
matchAll = And []

-- | Check if a file name matches a given 'Match' expression.
29
matches :: Match -> FilePath -> Bool
Andrey Mokhov's avatar
Andrey Mokhov committed
30
31
32
33
matches (Test p) f = p ?== f
matches (Not  m) f = not $ matches m f
matches (And ms) f = all (`matches` f) ms
matches (Or  ms) f = any (`matches` f) ms
34

Andrey Mokhov's avatar
Andrey Mokhov committed
35
36
37
38
-- | Given a 'Match' expression and a directory, recursively traverse it and all
-- its subdirectories to find and return all matching contents.
directoryContents :: Match -> FilePath -> Action [FilePath]
directoryContents expr dir = askOracle $ DirectoryContents (expr, dir)
kaiha's avatar
kaiha committed
39

40
-- | This oracle answers 'directoryContents' queries and tracks the results.
Andrey Mokhov's avatar
Andrey Mokhov committed
41
42
directoryContentsOracle :: Rules ()
directoryContentsOracle = void $
Andrey Mokhov's avatar
Andrey Mokhov committed
43
    addOracle $ \(DirectoryContents (expr, dir)) -> liftIO $ map unifyPath .
Andrey Mokhov's avatar
Andrey Mokhov committed
44
        filter (matches expr) <$> listFilesInside (return . matches expr) dir