lhs2tex-1.21: src/FileNameUtils.lhs
> {-# LANGUAGE ScopedTypeVariables #-}
>
> module FileNameUtils ( extension
> , expandPath
> , chaseFile
> , readTextFile
> , openOutputFile
> , modifySearchPath
> , deep, env
> , absPath
> , module System.FilePath
> ) where
>
> import Prelude
> import System.IO ( openFile, IOMode(..), hPutStrLn, stderr,
> hSetEncoding, hGetContents, utf8, Handle() )
> import System.IO.Error ( isDoesNotExistError, isPermissionError )
> import System.Directory
> import System.Environment
> import Data.List
> import Control.Monad (filterM)
> import Control.Exception as E
> ( try, catch, IOException )
> import System.FilePath
> import System.Info
>
> import Auxiliaries
A searchpath can be added to the front or to the back of the current path
by pre- or postfixing it with a path separator. Otherwise the new search
path replaces the current one.
> modifySearchPath :: [FilePath] -> String -> [FilePath]
> modifySearchPath p np
> | isSearchPathSeparator (head np) = p ++ split
> | isSearchPathSeparator (last np) = split ++ p
> | otherwise = split
> where split = splitOn isSearchPathSeparator np
> -- relPath = joinpath
> -- absPath ps = directorySeparator : relPath ps
> isWindows :: Bool
> isWindows = "win" `isPrefixOf` os || "Win" `isPrefixOf` os || "mingw" `isPrefixOf` os
> absPath :: FilePath -> FilePath
> absPath = if isWindows then
> (("C:" ++ [pathSeparator]) ++)
> else
> (pathSeparator :)
> deep :: FilePath -> FilePath
> deep = (++(replicate 2 pathSeparator))
> env :: String -> FilePath
> env x = "{" ++ x ++ "}"
> extension :: FilePath -> Maybe String
> extension fn = case takeExtension fn of
> "" -> Nothing
> (_:ext) -> Just ext
> -- dirname = takeDirectory
> -- filename = takeFilePath
> -- basename = takeBaseName
|expandPath| does two things: it replaces curly braced strings with
environment entries, if present; furthermore, if the path ends with
more than one directory separator, all subpaths are added ...
> expandPath :: [String] -> IO [String]
> expandPath s = do let s' = concatMap splitSearchPath s
> s'' <- mapM expandEnvironment s'
> s''' <- mapM findSubPaths (concat s'')
> return (nub $ concat s''')
> findSubPaths :: String -> IO [String]
> findSubPaths "" = return []
> findSubPaths s = let rs = reverse s
> (sep,rs') = span isPathSeparator rs
> s' = reverse rs'
> sep' = reverse sep
> in if null s'
> then return [[head sep']] {- we don't descend from root -}
> else if length sep < 2
> then return [s]
> else descendFrom s'
> descendFrom :: String -> IO [String]
> descendFrom s = E.catch (do d <- getDirectoryContents s
> {- no hidden files, no parents -}
> let d' = map (\x -> s </> x)
> . filter ((/='.') . head) . filter (not . null) $ d
> d'' <- filterM doesDirectoryExist d'
> d''' <- mapM descendFrom d''
> return (s : concat d''')
> )
> (\ (_ :: IOException) -> return [s])
> expandEnvironment :: String -> IO [String]
> expandEnvironment s = case break (=='{') s of
> (_s',"") -> return [s]
> (s','{':r) -> case break (=='}') r of
> (_e,"") -> return [s]
> (e,'}':r') -> findEnvironment e s' r'
> _ -> impossible "expandEnvironment"
> _ -> impossible "expandEnvironment"
> where findEnvironment :: String -> String -> String -> IO [String]
> findEnvironment e a o = do er <- try (getEnv e)
> return $ either (\ (_ :: IOException) -> [])
> (map (\x -> a ++ x ++ o) . splitOn isSearchPathSeparator)
> er
> readTextFile :: FilePath -> IO String
> readTextFile f = do h <- openFile f ReadMode
> hSetEncoding h utf8
> hGetContents h
> openOutputFile :: FilePath -> IO Handle
> openOutputFile f = do h <- openFile f WriteMode
> hSetEncoding h utf8
> return h
> chaseFile :: [String] {- search path -}
> -> FilePath -> IO (String,FilePath)
> chaseFile p fn | isAbsolute fn= E.catch (t fn) (handle fn (err "."))
> | p == [] = chaseFile ["."] fn
> | otherwise = s $ map (\ d -> md d ++ fn) p
> where
> md cs | isPathSeparator (last cs)
> = cs
> | otherwise = addTrailingPathSeparator cs
> t f = readTextFile f >>= \x -> return (x,f)
> s [] = err $ " in search path:\n" ++ showpath
> s (x:xs) = E.catch (t x) (handle x (s xs))
> err extra = ioError
> $ userError $ "File `" ++ fn ++ "' not found or not readable" ++ extra
> handle :: FilePath -> IO (String,FilePath) -> IOException -> IO (String,FilePath)
> handle x k e =
> if isDoesNotExistError e then k
> else if isPermissionError e then do
> hPutStrLn stderr $ "Warning: could not access " ++ x ++ " due to permission error."
> k
> else ioError e
> showpath = concatMap (\x -> " " ++ x ++ "\n") p