bamse-0.9.1: Util/Dir.hs

{- |
 
  Module      :  Util.Dir
  Copyright   :  (c) Galois Connections 2002

  Maintainer      : lib@galois.com
  Stability       : 
  Portability     : 
  
  File system directory utilities.
-}
module Util.Dir
	(  -- *Types
	  GenDirTree(..)
	, DirTree
	   -- * Functions
	, allFiles	    -- :: FilePath -> IO DirTree
	, findFiles         -- :: (FilePath -> Bool) -> FilePath -> IO DirTree
	, findFilesRel      -- :: (FilePath -> Bool) -> FilePath -> IO DirTree
	, showDirTree       -- :: Maybe Int -> DirTree -> String
	) where

import Data.Maybe ( fromMaybe )
import Control.Monad ( when )
import System.Directory
import Data.List
import System.Path
import Util.Path ( baseName )

-- | A tree \/ forest of files.
type DirTree = GenDirTree FilePath

data GenDirTree a
 = File a
 | Directory a [GenDirTree a]
 | Empty
   deriving ( Eq, Show )

instance Functor GenDirTree where
  fmap f (File name)         = File (f name)
  fmap f (Directory name ts) = Directory (f name) (map (fmap f) ts)
  fmap _ (Empty)             = Empty

-- | @showDirTree mbIndent tree@ shows the directory
-- tree, with each file\/directory appearing on a line
-- of their own. @mbIndent@ controls how much to indent
-- directory entries by. If @Nothing@, entries are indented
-- by two spaces.
showDirTree :: Maybe Int -> DirTree -> String
showDirTree mbIndent d = unlines $ showDir 0 d
 where
  indent_delta = fromMaybe 2 mbIndent

  showDir n Empty        = [indent n ""]
  showDir n (File fpath) = [indent n fpath]
  showDir n (Directory nm sub) =
  	indent n nm :
	concatMap (showDir (n+indent_delta)) sub

  indent n x = replicate n ' ' ++ x

-- | given a filepath, build up a @DirTree@ containing
-- all files and directories reachable (below that path.)
allFiles :: FilePath -> IO DirTree
allFiles fpath = findFiles (const True) fpath

-- | @findFiles pred path@ builds up a @DirTree@ 
-- containing all files\/directories that satisfy
-- the predicate @pred@. The file and directory names
-- in the result appear in full, e.g., if @a.hs@ is
-- a file in the directory @path@, it appears in the
-- result as @(File \"path\/a.hs\"@
findFiles :: (FilePath -> Bool)
	  -> FilePath
	  -> IO DirTree
findFiles predcsr fpath = findFiles' True predcsr fpath

findFiles' :: Bool -> (FilePath -> Bool) -> FilePath -> IO DirTree
findFiles' isTopLevel predcsr fpath
 | not (predcsr fpath) = return Empty
 | otherwise        = do
   let findFiles'' = findFiles' False
   isFileThere <- doesFileExist fpath
   isDirThere  <- doesDirectoryExist fpath
   case (isFileThere, isDirThere) of
     (True, _) -> return (File fpath)
     (_, True) -> do
       stuff <- getDirectoryContents fpath
       let stuff' = filter (not.isUpDown) stuff
       more_stuff <- mapM (findFiles'' predcsr) (map (\ x -> fpath++[pathSep]++ x) stuff')
       let more_stuff' = filter (not.isEmpty) more_stuff
       return (Directory fpath more_stuff')
     (False, False) -> do
       when (isTopLevel)
        (fail $ unwords [ "DirUtils.findFiles: file/directory"
			, fpath
			, "not found."
			])
       return Empty  -- don\'t throw exceptions for broken symlinks


-- | @findFilesRel pred path@ behaves like @findFiles@, except
-- files and directory names in the result are in /basename/ form,
-- e.g., if @a.hs@ is a file in the directory @path@, it appears
-- in the result as @(File \"a.hs\"@.
findFilesRel :: (FilePath -> Bool)
	     -> FilePath
	     -> IO DirTree
findFilesRel predcsr fpath = do
  tree <- findFiles predcsr fpath
  return (fmap baseName tree)

isEmpty :: GenDirTree a -> Bool
isEmpty Empty = True
isEmpty _     = False

isUpDown :: String -> Bool
isUpDown "."  = True
isUpDown ".." = True
isUpDown _    = False