module Darcs.Patch.FileName ( FileName( ),
fp2fn, fn2fp,
fn2ps, ps2fn,
niceps2fn, fn2niceps,
breakOnDir, normPath, ownName, superName,
movedirfilename,
encodeWhite, decodeWhite,
(///),
breakup, isParentOrEqOf
) where
import Data.Char ( isSpace, chr, ord )
import Data.List ( stripPrefix )
import ByteStringUtils ( packStringToUTF8, unpackPSFromUTF8 )
import qualified Data.ByteString.Char8 as BC (unpack, pack)
import qualified Data.ByteString as B (ByteString)
newtype FileName = FN FilePath deriving ( Eq, Ord )
instance Show FileName where
showsPrec d (FN fp) = showParen (d > appPrec) $ showString "fp2fn " . showsPrec (appPrec + 1) fp
where appPrec = 10
fp2fn :: FilePath -> FileName
fp2fn fp = FN fp
fn2fp :: FileName -> FilePath
fn2fp (FN fp) = fp
niceps2fn :: B.ByteString -> FileName
niceps2fn = FN . decodeWhite . BC.unpack
fn2niceps :: FileName -> B.ByteString
fn2niceps (FN fp) = BC.pack $ encodeWhite fp
fn2ps :: FileName -> B.ByteString
fn2ps (FN fp) = packStringToUTF8 $ encodeWhite fp
ps2fn :: B.ByteString -> FileName
ps2fn ps = FN $ decodeWhite $ unpackPSFromUTF8 ps
encodeWhite :: FilePath -> String
encodeWhite (c:cs) | isSpace c || c == '\\' =
'\\' : (show $ ord c) ++ "\\" ++ encodeWhite cs
encodeWhite (c:cs) = c : encodeWhite cs
encodeWhite [] = []
decodeWhite :: String -> FilePath
decodeWhite ('\\':cs) =
case break (=='\\') cs of
(theord, '\\':rest) ->
chr (read theord) : decodeWhite rest
_ -> error "malformed filename"
decodeWhite (c:cs) = c: decodeWhite cs
decodeWhite "" = ""
ownName :: FileName -> FileName
ownName (FN f) = case breakLast '/' f of Nothing -> FN f
Just (_,f') -> FN f'
superName :: FileName -> FileName
superName fn = case normPath fn of
FN f -> case breakLast '/' f of
Nothing -> FN "."
Just (d,_) -> FN d
breakOnDir :: FileName -> Maybe (FileName,FileName)
breakOnDir (FN p) = case breakFirst '/' p of
Nothing -> Nothing
Just (d,f) | d == "." -> breakOnDir $ FN f
| otherwise -> Just (FN d, FN f)
normPath :: FileName -> FileName
normPath (FN p) = FN $ repath $ dropDotdot $ breakup p
repath :: [String] -> String
repath [] = ""
repath [f] = f
repath (d:p) = d ++ "/" ++ repath p
dropDotdot :: [String] -> [String]
dropDotdot ("":p) = dropDotdot p
dropDotdot (".":p) = dropDotdot p
dropDotdot ("..":p) = ".." : (dropDotdot p)
dropDotdot (_:"..":p) = dropDotdot p
dropDotdot (d:p) = case dropDotdot p of
("..":p') -> p'
p' -> d : p'
dropDotdot [] = []
breakup :: String -> [String]
breakup p = case break (=='/') p of
(d,"") -> [d]
(d,p') -> d : breakup (tail p')
breakFirst :: Char -> String -> Maybe (String,String)
breakFirst c l = bf [] l
where bf a (r:rs) | r == c = Just (reverse a,rs)
| otherwise = bf (r:a) rs
bf _ [] = Nothing
breakLast :: Char -> String -> Maybe (String,String)
breakLast c l = case breakFirst c (reverse l) of
Nothing -> Nothing
Just (a,b) -> Just (reverse b, reverse a)
(///) :: FileName -> FileName -> FileName
(FN "")///b = normPath b
a///b = normPath $ fp2fn $ fn2fp a ++ "/" ++ fn2fp b
isParentOrEqOf :: FileName -> FileName -> Bool
isParentOrEqOf fn1 fn2 = case stripPrefix (fn2fp fn1) (fn2fp fn2) of
Just ('/' : _) -> True
Just [] -> True
_ -> False
movedirfilename :: FileName -> FileName -> FileName -> FileName
movedirfilename old new name =
if name' == old'
then new
else case stripPrefix old' name' of
Just rest@('/':_) -> fp2fn $ "./" ++ new' ++ rest
_ -> name
where old' = fn2fp $ normPath old
new' = fn2fp $ normPath new
name' = fn2fp $ normPath name