module Development.Shake.Directory(
doesFileExist, doesDirectoryExist,
getDirectoryContents, getDirectoryFiles, getDirectoryDirs,
getEnv,
removeFiles, removeFilesAfter,
defaultRuleDirectory
) where
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import System.IO.Error
import Data.Binary
import Data.List
import Data.Maybe
import qualified System.Directory as IO
import qualified System.Environment as IO
import Development.Shake.Core
import Development.Shake.Classes
import Development.Shake.FilePath
import Development.Shake.FilePattern
newtype DoesFileExistQ = DoesFileExistQ FilePath
deriving (Typeable,Eq,Hashable,Binary,NFData)
instance Show DoesFileExistQ where
show (DoesFileExistQ a) = "Exists? " ++ 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) = "Exists dir? " ++ 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 " ++ a
newtype GetEnvA = GetEnvA (Maybe String)
deriving (Typeable,Eq,Hashable,Binary,NFData)
instance Show GetEnvA where
show (GetEnvA a) = fromMaybe "<unset>" a
data GetDirectoryQ
= GetDir {dir :: FilePath}
| GetDirFiles {dir :: FilePath, pat :: [FilePattern]}
| GetDirDirs {dir :: FilePath}
deriving (Typeable,Eq)
newtype GetDirectoryA = GetDirectoryA [FilePath]
deriving (Typeable,Show,Eq,Hashable,Binary,NFData)
instance Show GetDirectoryQ where
show (GetDir x) = "Listing " ++ x
show (GetDirFiles a b) = "Files " ++ a </> ['{'|m] ++ unwords b ++ ['}'|m]
where m = length b > 1
show (GetDirDirs x) = "Dirs " ++ x
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) $ getEnvIO 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 $ getEnvIO 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
getEnvIO :: String -> IO (Maybe String)
getEnvIO x = Control.Exception.catch (fmap Just $ IO.getEnv x) $
\e -> if isDoesNotExistError e then return Nothing else ioError e
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
concatMapM f xs = fmap concat $ mapM f xs
partitionM f [] = return ([], [])
partitionM f (x:xs) = do
t <- f x
(a,b) <- partitionM f xs
return $ if t then (x:a,b) else (a,x:b)
removeFiles :: FilePath -> [FilePattern] -> IO ()
removeFiles dir ["//*"] = IO.removeDirectoryRecursive dir
removeFiles dir pat = f "" >> return ()
where
test = let ps = map (?==) 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 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