module Development.Shake.Rules.Directory(
doesFileExist, doesDirectoryExist,
getDirectoryContents, getDirectoryFiles, getDirectoryDirs,
getEnv, getEnvWithDefault,
removeFiles, removeFilesAfter,
getDirectoryFilesIO,
defaultRuleDirectory
) where
import Control.Applicative
import Control.Exception as C
import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.Maybe
import Data.Binary
import Data.List
import Data.Tuple.Extra
import qualified Data.HashSet as Set
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 -> GetDir <$> get
1 -> GetDirFiles <$> get <*> get
2 -> 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) = (Just . DoesFileExistA) <$> IO.doesFileExist x
instance Rule DoesDirectoryExistQ DoesDirectoryExistA where
storedValue _ (DoesDirectoryExistQ x) = (Just . DoesDirectoryExistA) <$> IO.doesDirectoryExist x
instance Rule GetEnvQ GetEnvA where
storedValue _ (GetEnvQ x) = (Just . GetEnvA) <$> IO.lookupEnv x
instance Rule GetDirectoryQ GetDirectoryA where
storedValue _ x = Just <$> getDir x
defaultRuleDirectory :: Rules ()
defaultRuleDirectory = do
rule $ \(DoesFileExistQ x) -> Just $
liftIO $ DoesFileExistA <$> IO.doesFileExist x
rule $ \(DoesDirectoryExistQ x) -> Just $
liftIO $ DoesDirectoryExistA <$> IO.doesDirectoryExist x
rule $ \(x :: GetDirectoryQ) -> Just $
liftIO $ getDir x
rule $ \(GetEnvQ x) -> Just $
liftIO $ GetEnvA <$> IO.lookupEnv x
doesFileExist :: FilePath -> Action Bool
doesFileExist file = do
DoesFileExistA res <- apply1 $ DoesFileExistQ $ toStandard file
return res
doesDirectoryExist :: FilePath -> Action Bool
doesDirectoryExist file = do
DoesDirectoryExistA res <- apply1 $ DoesDirectoryExistQ $ toStandard 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{..} = answer <$> contents dir
getDir GetDirDirs{..} = fmap answer $ filterM f =<< contents dir
where f x = IO.doesDirectoryExist $ dir </> x
getDir GetDirFiles{..} = answer <$> getDirectoryFilesIO dir pat
getDirectoryFilesIO :: FilePath -> [FilePattern] -> IO [FilePath]
getDirectoryFilesIO root pat = f "" $ snd $ walk pat
where
f dir (Walk op) = f dir . WalkTo . op =<< contents (root </> dir)
f dir (WalkTo (files, dirs)) = do
files <- filterM (IO.doesFileExist . (root </>)) $ map (dir </>) files
dirs <- concatMapM (uncurry f) =<< filterM (IO.doesDirectoryExist . (root </>) . fst) (map (first (dir </>)) dirs)
return $ files ++ dirs
removeFiles :: FilePath -> [FilePattern] -> IO ()
removeFiles dir pat =
whenM (IO.doesDirectoryExist dir) $ do
let (b,w) = walk pat
if b then removeDir dir else f dir w
where
f dir (Walk op) = f dir . WalkTo . op =<< contents dir
f dir (WalkTo (files, dirs)) = do
forM_ files $ \fil ->
try $ removeItem $ dir </> fil :: IO (Either IOException ())
let done = Set.fromList files
forM_ (filter (not . flip Set.member done . fst) dirs) $ \(d,w) -> do
let dir2 = dir </> d
whenM (IO.doesDirectoryExist dir2) $ f dir2 w
removeItem :: FilePath -> IO ()
removeItem x = IO.removeFile x `C.catch` \(_ :: IOException) -> removeDir x
removeDir :: FilePath -> IO ()
removeDir x = do
mapM_ (removeItem . (x </>)) =<< contents x
IO.removeDirectory x
removeFilesAfter :: FilePath -> [FilePattern] -> Action ()
removeFilesAfter a b = do
putLoud $ "Will remove " ++ unwords b ++ " from " ++ a
runAfter $ removeFiles a b