module Development.Shake.Rules.Directory(
doesFileExist, doesDirectoryExist,
getDirectoryContents, getDirectoryFiles, getDirectoryDirs,
getEnv, getEnvWithDefault,
removeFiles, removeFilesAfter,
defaultRuleDirectory
) where
import Control.Applicative
import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.Maybe
import Data.Binary
import Data.List
import qualified System.Directory as IO
import qualified System.Environment.Extra as IO
import Development.Shake.Core
import Development.Shake.Classes
import Development.Shake.FilePath
import Development.Shake.FilePattern
import General.Extra
import Prelude
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) $ IO.lookupEnv x
instance Rule GetDirectoryQ GetDirectoryA where
storedValue _ x = fmap Just $ getDir x
defaultRuleDirectory :: Rules ()
defaultRuleDirectory = do
rule $ \(DoesFileExistQ x) -> Just $
liftIO $ fmap DoesFileExistA $ IO.doesFileExist x
rule $ \(DoesDirectoryExistQ x) -> Just $
liftIO $ fmap DoesDirectoryExistA $ IO.doesDirectoryExist x
rule $ \(x :: GetDirectoryQ) -> Just $
liftIO $ getDir x
rule $ \(GetEnvQ x) -> Just $
liftIO $ fmap GetEnvA $ IO.lookupEnv 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
getEnvWithDefault :: String -> String -> Action String
getEnvWithDefault def var = fromMaybe def <$> getEnv var
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 pat = do
b <- IO.doesDirectoryExist dir
when b $ void $ f ""
where
test = let ps = map (?==) pat in \x -> any ($ x) ps
f :: FilePath -> IO Bool
f dir2 | test dir2 = do
IO.removeDirectoryRecursive $ dir </> dir2
return True
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
forM del $ \d -> IO.removeFile $ dir </> d
let die = noDirs && null keep && not (null xs)
when die $ IO.removeDirectory $ dir </> dir2
return die
removeFilesAfter :: FilePath -> [FilePattern] -> Action ()
removeFilesAfter a b = do
putLoud $ "Will remove " ++ unwords b ++ " from " ++ a
runAfter $ removeFiles a b