{-# OPTIONS_GHC -cpp #-}
-- Copyright (C) 2007 Eric Kow
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING. If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.
module Darcs.RepoPath ( AbsolutePath, mkAbsolutePath,
RelativePath, mkRelativePath,
SubPath, maybeMkSubPath,
rp2fn, unsafeFn2rp,
ap2fn, unsafeFn2ap,
sp2fn,
FilePathOrURL(..), FilePathLike(toFilePath),
appendToPath, combine, takeDirectory,
makeSubPathOf, makeAbsolute,
) where
import Data.List ( isPrefixOf )
import Autoconf ( path_separator )
import FileName
class FilePathOrURL a where
{-# INLINE toPath #-}
toPath :: a -> String
class FilePathOrURL a => FilePathLike a where
{-# INLINE toFilePath #-}
toFilePath :: a -> FilePath
{-# INLINE toInternal #-}
toInternal :: a -> FilePath
{-# INLINE fromInternal #-}
fromInternal :: FilePath -> a
-- | Relative to the local darcs repository and normalized
-- Note: these are understood not to have the dot in front
newtype SubPath = SubPath FilePath deriving (Eq, Ord)
newtype RelativePath = RelativePath FilePath deriving (Eq, Ord)
newtype AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord)
instance FilePathOrURL AbsolutePath where
toPath (AbsolutePath x) = x
instance FilePathOrURL RelativePath where
toPath (RelativePath x) = x
instance FilePathOrURL SubPath where
toPath (SubPath x) = x
instance FilePathLike AbsolutePath where
toFilePath (AbsolutePath x) = x
toInternal (AbsolutePath x) = x
fromInternal xs = AbsolutePath xs
instance FilePathLike RelativePath where
toFilePath (RelativePath x) = x
toInternal (RelativePath x) = x
fromInternal = RelativePath
instance FilePathLike SubPath where
toFilePath (SubPath x) = x
toInternal (SubPath x) = x
fromInternal = SubPath
-- | Make the second path relative to the first, if possible
makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath
makeSubPathOf (AbsolutePath p1) (AbsolutePath p2) =
-- The slash prevents "foobar" from being treated as relative to "foo"
if p1 == p2 || (p1 ++ "/") `isPrefixOf` p2
then Just $ SubPath $ drop (length p1 + 1) p2
else Nothing
-- | Interpret the second (relative) path wrt the first (absolute) one
-- N.B. makeAbsolute "\/foo" "..\/..\/..\/bar" == "\/bar"
makeAbsolute :: AbsolutePath -> RelativePath -> AbsolutePath
makeAbsolute p1 (RelativePath p2) = ma p2
where ma ('.':'.':'/':r) = if pp1 == p1 then AbsolutePath r else ma r
ma r = combine p1 (SubPath r)
pp1 = takeDirectory p1
combine :: FilePathLike a => a -> SubPath -> a
combine p1 (SubPath "") = p1
combine p1 (SubPath p2) | null (toInternal p1) = fromInternal p2
combine p1 (SubPath p2) = withInternal (++ '/':p2) p1
appendToPath :: FilePathLike a => String -> a -> a
appendToPath suf = withInternal (++ suf)
takeDirectory :: FilePathLike a => a -> a
takeDirectory = withInternal (reverse . drop 1 . dropWhile (/='/') . reverse)
withInternal :: FilePathLike a => (FilePath -> FilePath) -> a -> a
withInternal f = fromInternal . f . toInternal
-- TODO: quickcheck that withInternal id x == id x
instance Show AbsolutePath where
show = show . toFilePath
instance Show RelativePath where
show = show . toFilePath
instance Show SubPath where
show = show . toFilePath
cleanup :: Char -> Char
cleanup '\\' | path_separator == '\\' = '/'
cleanup c = c
norm_slashes :: String -> String
#ifndef WIN32
-- multiple slashes in front are ignored under Unix
norm_slashes ('/':p) = '/' : dropWhile (== '/') p
#endif
norm_slashes p = p
{-# INLINE mkAbsolutePath #-}
mkAbsolutePath :: FilePath -> AbsolutePath
mkAbsolutePath p = AbsolutePath $ slashes ++ (fn2fp $ norm_path $ fp2fn cleanp)
where
cleanp = map cleanup p
slashes = norm_slashes $ takeWhile (== '/') cleanp
{-# INLINE mkRelativePath #-}
mkRelativePath :: FilePath -> RelativePath
mkRelativePath p = unsafeFn2rp $ norm_path $ fp2fn $ map cleanup p
maybeMkSubPath :: FilePath -> Either RelativePath SubPath
maybeMkSubPath rawp =
case p of
('.':'.':'/':_) -> Left $ RelativePath p
_ -> Right $ SubPath p
where p = fn2fp $ norm_path $ fp2fn $ map cleanup rawp
{-# INLINE ap2fn #-}
ap2fn :: AbsolutePath -> FileName
ap2fn = fp2fn . toFilePath
{-# INLINE rp2fn #-}
rp2fn :: RelativePath -> FileName
rp2fn = fp2fn . toFilePath
{-# INLINE sp2fn #-}
sp2fn :: SubPath -> FileName
sp2fn = fp2fn . toFilePath
{-# INLINE unsafeFn2ap #-}
-- | unsafe because we don't actually know if the FileName
-- encodes a relative path
unsafeFn2ap :: FileName -> AbsolutePath
unsafeFn2ap = AbsolutePath . fn2fp
{-# INLINE unsafeFn2rp #-}
-- | unsafe because we don't actually know if the FileName
-- encodes a relative path
unsafeFn2rp :: FileName -> RelativePath
unsafeFn2rp = RelativePath . fn2fp