lhs2tex-1.15: FileNameUtils.lhs
> {-# LANGUAGE ScopedTypeVariables #-}
> {-# LANGUAGE PatternSignatures #-}
>
> module FileNameUtils ( extension
> , expandPath
> , chaseFile
> , modifySearchPath
> , deep, env
> , absPath
> , module System.FilePath
> ) where
>
> import Prelude hiding ( catch, readFile )
> import System.IO ( openFile, IOMode(..) )
> import System.IO.UTF8
> import System.Directory
> import System.Environment
> import Data.List
> import Control.Monad (filterM)
> import Control.Exception.Extensible
> ( try, catch, IOException )
> import System.FilePath
> import System.Info
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 = "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 = 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'
> 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
> splitOn :: (Char -> Bool) -> String -> [String]
> splitOn p s = case dropWhile p s of
> "" -> []
> s' -> w : splitOn p s''
> where (w,s'') = break p s'
The UTF8 version of readFile defaults to binary files, whereas the
System.IO version defaults to text files. Therfore we implement our
own.
> readTextFile :: FilePath -> IO String
> readTextFile f = openFile f ReadMode >>= hGetContents
> chaseFile :: [String] {- search path -}
> -> FilePath -> IO (String,FilePath)
> chaseFile p fn | isAbsolute fn= t fn
> | p == [] = chaseFile ["."] fn
> | otherwise = s $ map (\d -> t (md d ++ fn)) p
> where
> md cs | isPathSeparator (last cs)
> = cs
> | otherwise = addTrailingPathSeparator cs
> t f = catch (readTextFile f >>= \x -> return (x,f))
> (\ (_ :: IOException) -> ioError $ userError $ "File `" ++ fn ++ "' not found.\n")
> s [] = ioError
> $ userError $ "File `" ++ fn ++ "' not found in search path:\n" ++ showpath
> s (x:xs) = catch x (\ (_ :: IOException) -> s xs)
> showpath = concatMap (\x -> " " ++ x ++ "\n") p