module Development.Shake.Rules.Directory(
doesFileExist, doesDirectoryExist,
getDirectoryContents, getDirectoryFiles, getDirectoryDirs,
getEnv,
removeFiles, removeFilesAfter,
defaultRuleDirectory
) where
import Control.Monad
import Control.Monad.IO.Class
import Data.Binary
import Data.List
import qualified System.Directory as IO
import Development.Shake.Core
import Development.Shake.Classes
import Development.Shake.FilePath
import Development.Shake.FilePattern
import General.Base
newtype DoesFileExistQ = DoesFileExistQ FilePath
deriving (Typeable,Eq,Hashable,Binary,NFData)
instance Show DoesFileExistQ where
show (DoesFileExistQ a) = "doesFileExist " ++ showQuote a
newtype DoesFileExistA = DoesFileExistA Bool
deriving (Typeable,Eq,Hashable,Binary,NFData)
instance Show DoesFileExistA where
show (DoesFileExistA a) = show a
newtype DoesDirectoryExistQ = DoesDirectoryExistQ FilePath
deriving (Typeable,Eq,Hashable,Binary,NFData)
instance Show DoesDirectoryExistQ where
show (DoesDirectoryExistQ a) = "doesDirectoryExist " ++ showQuote a
newtype DoesDirectoryExistA = DoesDirectoryExistA Bool
deriving (Typeable,Eq,Hashable,Binary,NFData)
instance Show DoesDirectoryExistA where
show (DoesDirectoryExistA a) = show a
newtype GetEnvQ = GetEnvQ String
deriving (Typeable,Eq,Hashable,Binary,NFData)
instance Show GetEnvQ where
show (GetEnvQ a) = "getEnv " ++ showQuote a
newtype GetEnvA = GetEnvA (Maybe String)
deriving (Typeable,Eq,Hashable,Binary,NFData)
instance Show GetEnvA where
show (GetEnvA a) = maybe "<unset>" showQuote a
data GetDirectoryQ
= GetDir {dir :: FilePath}
| GetDirFiles {dir :: FilePath, pat :: [FilePattern]}
| GetDirDirs {dir :: FilePath}
deriving (Typeable,Eq)
newtype GetDirectoryA = GetDirectoryA [FilePath]
deriving (Typeable,Eq,Hashable,Binary,NFData)
instance Show GetDirectoryQ where
show (GetDir x) = "getDirectoryContents " ++ showQuote x
show (GetDirFiles a b) = "getDirectoryFiles " ++ showQuote a ++ " [" ++ unwords (map showQuote b) ++ "]"
show (GetDirDirs x) = "getDirectoryDirs " ++ showQuote x
instance Show GetDirectoryA where
show (GetDirectoryA xs) = unwords $ map showQuote xs
instance NFData GetDirectoryQ where
rnf (GetDir a) = rnf a
rnf (GetDirFiles a b) = rnf a `seq` rnf b
rnf (GetDirDirs a) = rnf a
instance Hashable GetDirectoryQ where
hashWithSalt salt = hashWithSalt salt . f
where f (GetDir x) = (0 :: Int, x, [])
f (GetDirFiles x y) = (1, x, y)
f (GetDirDirs x) = (2, x, [])
instance Binary GetDirectoryQ where
get = do
i <- getWord8
case i of
0 -> liftM GetDir get
1 -> liftM2 GetDirFiles get get
2 -> liftM GetDirDirs get
put (GetDir x) = putWord8 0 >> put x
put (GetDirFiles x y) = putWord8 1 >> put x >> put y
put (GetDirDirs x) = putWord8 2 >> put x
instance Rule DoesFileExistQ DoesFileExistA where
storedValue _ (DoesFileExistQ x) = fmap (Just . DoesFileExistA) $ IO.doesFileExist x
instance Rule DoesDirectoryExistQ DoesDirectoryExistA where
storedValue _ (DoesDirectoryExistQ x) = fmap (Just . DoesDirectoryExistA) $ IO.doesDirectoryExist x
instance Rule GetEnvQ GetEnvA where
storedValue _ (GetEnvQ x) = fmap (Just . GetEnvA) $ getEnvMaybe x
instance Rule GetDirectoryQ GetDirectoryA where
storedValue _ x = fmap Just $ getDir x
defaultRuleDirectory :: Rules ()
defaultRuleDirectory = do
defaultRule $ \(DoesFileExistQ x) -> Just $
liftIO $ fmap DoesFileExistA $ IO.doesFileExist x
defaultRule $ \(DoesDirectoryExistQ x) -> Just $
liftIO $ fmap DoesDirectoryExistA $ IO.doesDirectoryExist x
defaultRule $ \(x :: GetDirectoryQ) -> Just $
liftIO $ getDir x
defaultRule $ \(GetEnvQ x) -> Just $
liftIO $ fmap GetEnvA $ getEnvMaybe x
doesFileExist :: FilePath -> Action Bool
doesFileExist file = do
DoesFileExistA res <- apply1 $ DoesFileExistQ file
return res
doesDirectoryExist :: FilePath -> Action Bool
doesDirectoryExist file = do
DoesDirectoryExistA res <- apply1 $ DoesDirectoryExistQ file
return res
getEnv :: String -> Action (Maybe String)
getEnv var = do
GetEnvA res <- apply1 $ GetEnvQ var
return res
getDirectoryContents :: FilePath -> Action [FilePath]
getDirectoryContents x = getDirAction $ GetDir x
getDirectoryFiles :: FilePath -> [FilePattern] -> Action [FilePath]
getDirectoryFiles x f = getDirAction $ GetDirFiles x f
getDirectoryDirs :: FilePath -> Action [FilePath]
getDirectoryDirs x = getDirAction $ GetDirDirs x
getDirAction x = do GetDirectoryA y <- apply1 x; return y
contents :: FilePath -> IO [FilePath]
contents x = fmap (filter $ not . all (== '.')) $ IO.getDirectoryContents $ if x == "" then "." else x
answer :: [FilePath] -> GetDirectoryA
answer = GetDirectoryA . sort
getDir :: GetDirectoryQ -> IO GetDirectoryA
getDir GetDir{..} = fmap answer $ contents dir
getDir GetDirDirs{..} = fmap answer $ filterM f =<< contents dir
where f x = IO.doesDirectoryExist $ dir </> x
getDir GetDirFiles{..} = fmap answer $ concatMapM f $ directories pat
where
test = let ps = map (?==) pat in \x -> any ($ x) ps
f (dir2,False) = do
xs <- fmap (map (dir2 </>)) $ contents $ dir </> dir2
flip filterM xs $ \x -> if not $ test x then return False else fmap not $ IO.doesDirectoryExist $ dir </> x
f (dir2,True) = do
xs <- fmap (map (dir2 </>)) $ contents $ dir </> dir2
(dirs,files) <- partitionM (\x -> IO.doesDirectoryExist $ dir </> x) xs
rest <- concatMapM (\d -> f (d, True)) dirs
return $ filter test files ++ rest
removeFiles :: FilePath -> [FilePattern] -> IO ()
removeFiles dir ["//*"] = IO.removeDirectoryRecursive dir
removeFiles dir pat = f "" >> return ()
where
test = let ps = map (?==) $ map normalise pat in \x -> any ($ x) ps
f :: FilePath -> IO Bool
f dir2 = do
xs <- fmap (map (dir2 </>)) $ contents $ dir </> dir2
(dirs,files) <- partitionM (\x -> IO.doesDirectoryExist $ dir </> x) xs
noDirs <- fmap and $ mapM f dirs
let (del,keep) = partition test files
mapM_ IO.removeFile $ map (dir </>) del
let die = noDirs && null keep
when die $ IO.removeDirectory $ dir </> dir2
return die
removeFilesAfter :: FilePath -> [FilePattern] -> Action ()
removeFilesAfter a b = runAfter $ removeFiles a b