module Utils (pairs
, unpairs
, root
, dot
, dotdot
, reduceFilePath
, absoluteLink
, relativeLink
, compElems
, subdirectories
, subdirectory
, aDirectory
, aSymbolicLink
, anObject
, putOrPageStrLn
)
where
import Control.Exception (IOException, try)
import Control.Monad (unless)
import Data.List (nub,intersect,isPrefixOf,tails,foldl')
import Data.Maybe (fromJust,isNothing)
import System.Environment (getEnvironment)
import System.Exit (ExitCode(..))
import System.FilePath (pathSeparator,joinPath,(</>),isAbsolute,splitDirectories)
import System.IO (hClose,hFlush,hPutStr)
import System.Posix.Files (getSymbolicLinkStatus,isSymbolicLink,isDirectory)
import System.Process (waitForProcess,createProcess,shell,StdStream(..),CreateProcess(..))
root :: FilePath
root = [pathSeparator]
dot :: FilePath
dot = "."
dotdot :: FilePath
dotdot = ".."
pairs :: [a] -> [(a,a)]
pairs [] = []
pairs [x] = []
pairs xs =
let pair_ x0 = map (\x1 -> (x0,x1))
xss = init $ init $ tails xs
in concatMap (\xs -> pair_ (head xs) (tail xs)) xss
unpairs :: Eq a => [(a,a)] -> [a]
unpairs ps
| null ps = []
| otherwise = fst (head ps) : foldr ((:).snd) [] (take (elements 0 (length ps) - 1) ps)
where
elements e p = if p == e*(e-1) `div` 2 then e else elements (e+1) p
reduceFilePath :: FilePath -> FilePath
reduceFilePath = joinPath . filePathComponents
absoluteLink :: FilePath -> FilePath -> FilePath -> FilePath
absoluteLink wd _ = reduceFilePath . ((pathSeparator:wd)</>)
relativeLink :: FilePath -> FilePath -> FilePath -> FilePath
relativeLink wd p1 p2 =
let wd_ = pathSeparator:wd
ab p = if isAbsolute p then p else wd_ </> p
(_, p1_, p2_) = decomposeFilePaths (ab p1) (ab p2)
p1_s = map (const dotdot) $ splitDirectories p1_
p1__ = (joinPath . (if null p1_s then id else tail)) p1_s
p = p1__ </> p2_
in if null p then dot else p
compElems :: Eq a => [a] -> [a] -> ([a], [a], [a])
compElems [] l2 = ([], [], nub l2)
compElems l1 [] = ([], nub l1, [])
compElems l1 l2 =
let l1_ = nub l1
l2_ = nub l2
same = intersect l1_ l2_
unique1 = filter (`notElem` same) l1_
unique2 = filter (`notElem` same) l2_
in (same, unique1, unique2)
subdirectories :: FilePath -> FilePath -> Bool
subdirectories p1 p2 = subdirectory p1 p2 || subdirectory p2 p1
subdirectory :: FilePath -> FilePath -> Bool
subdirectory p1 p2 =
let x = filePathComponents p1
y = filePathComponents p2
in isPrefixOf y x
aDirectory :: FilePath -> IO Bool
aDirectory =
fmap (either (const False :: IOException -> Bool) isDirectory) . try . getSymbolicLinkStatus
aSymbolicLink :: FilePath -> IO Bool
aSymbolicLink =
fmap (either (const False :: IOException -> Bool) isSymbolicLink) . try . getSymbolicLinkStatus
anObject :: FilePath -> IO Bool
anObject =
fmap (either (const False :: IOException -> Bool) (const True)) . try . getSymbolicLinkStatus
putOrPageStrLn :: String -> IO ExitCode
putOrPageStrLn str
| null str = return ExitSuccess
| otherwise =
do pager <- fmap (lookup "PAGER") getEnvironment
if isNothing pager
then putStrLn str >> return ExitSuccess
else do (inh, _, _, pid) <- createProcess (shell $ fromJust pager){std_in = CreatePipe}
unless (isNothing inh) $ do hPutStr (fromJust inh) str
hFlush (fromJust inh)
hClose (fromJust inh)
waitForProcess pid
decomposeFilePaths :: FilePath -> FilePath -> (FilePath, FilePath, FilePath)
decomposeFilePaths p1 p2
| null p1 = ([], p1, p2)
| null p2 = ([], p1, p2)
| otherwise =
let p1s = filePathComponents p1
p2s = filePathComponents p2
(pxs_, p1s_, p2s_) = decomposeFilePaths_ ([], p1s, p2s)
decomposeFilePaths_ (pxs, [], p2s) = (pxs, [], p2s)
decomposeFilePaths_ (pxs, p1s, []) = (pxs, p1s, [])
decomposeFilePaths_ (pxs, p1s, p2s) =
let p1h = head p1s
p2h = head p2s
p1t = tail p1s
p2t = tail p2s
in if p1h == p2h
then decomposeFilePaths_ (pxs++[p1h], p1t, p2t)
else (pxs, p1s, p2s)
in (joinPath pxs_, joinPath p1s_, joinPath p2s_)
filePathComponents :: FilePath -> [FilePath]
filePathComponents p
| null p = [dot]
| otherwise = let c = head p
cs = tail p
in reverse $ snd $ foldl accumulate
(if c == pathSeparator then ([],[root]) else ([c],[dot]))
(cs++root)
where
accumulate :: (String,[String]) -> Char -> (String,[String])
accumulate (cs, css) c =
if c == pathSeparator
then ([],(if null cs then id else cons cs) css)
else (cs++[c],css)
cons :: String -> [String] -> [String]
cons cs css
| cs == dot = css
| css == [dot] = [cs]
| cs /= dotdot || null css = cs : css
| otherwise =
let hd = head css
tl = tail css
in if hd == root
then css
else if hd == dotdot
then cs : css
else if null tl
then [dot]
else tl