RepoPath.hs

{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE 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, makeAbsolute, ioAbsolute, rootDirectory,
                        SubPath, makeSubPathOf, simpleSubPath,
                        AbsolutePathOrStd,
                        makeAbsoluteOrStd, ioAbsoluteOrStd, useAbsoluteOrStd,
                        AbsoluteOrRemotePath, ioAbsoluteOrRemote, isRemote,
                        sp2fn,
                        FilePathOrURL(..), FilePathLike(toFilePath),
                        getCurrentDirectory, setCurrentDirectory
                      ) where

import Data.List ( isPrefixOf, isSuffixOf )
import Control.Exception ( bracket )

import Darcs.URL ( is_absolute, is_relative, is_ssh_nopath )
import Autoconf ( path_separator )
import qualified Workaround ( getCurrentDirectory )
import qualified System.Directory ( setCurrentDirectory )
import System.Directory ( doesDirectoryExist )
import qualified System.FilePath.Posix as FilePath
import qualified Darcs.Patch.FileName as PatchFileName ( FileName, fp2fn, fn2fp )

class FilePathOrURL a where
 {-# INLINE toPath #-}
 toPath :: a -> String

class FilePathOrURL a => FilePathLike a where
 {-# INLINE toFilePath #-}
 toFilePath :: a -> FilePath

-- | 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 AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord)
data AbsolutePathOrStd = AP AbsolutePath | APStd deriving (Eq, Ord)
data AbsoluteOrRemotePath = AbsP AbsolutePath | RmtP String deriving (Eq, Ord)

instance FilePathOrURL AbsolutePath where
 toPath (AbsolutePath x) = x
instance FilePathOrURL SubPath where
 toPath (SubPath x) = x
instance CharLike c => FilePathOrURL [c] where
 toPath = toFilePath

instance FilePathOrURL AbsoluteOrRemotePath where
 toPath (AbsP a) = toPath a
 toPath (RmtP r) = r

instance FilePathOrURL PatchFileName.FileName where
    toPath = PatchFileName.fn2fp
instance FilePathLike PatchFileName.FileName where
    toFilePath = PatchFileName.fn2fp

instance FilePathLike AbsolutePath where
 toFilePath (AbsolutePath x) = x
instance FilePathLike SubPath where
 toFilePath (SubPath x) = x

class CharLike c where
    toChar :: c -> Char
    fromChar :: Char -> c
instance CharLike Char where
    toChar = id
    fromChar = id

instance CharLike c => FilePathLike [c] where
    toFilePath = map toChar

-- | 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

simpleSubPath :: FilePath -> Maybe SubPath
simpleSubPath x | is_relative x = Just $ SubPath $ FilePath.normalise $ map cleanup x
                | otherwise = Nothing

-- | Interpret a possibly relative path wrt the current working directory
ioAbsolute :: FilePath -> IO AbsolutePath
ioAbsolute dir =
    do isdir <- doesDirectoryExist dir
       here <- getCurrentDirectory
       if isdir
         then bracket (setCurrentDirectory dir)
                      (const $ setCurrentDirectory $ toFilePath here)
                      (const getCurrentDirectory)
         else let super_dir = case FilePath.takeDirectory dir of
                                "" ->  "."
                                d  -> d
                  file = FilePath.takeFileName dir
              in do abs_dir <- ioAbsolute super_dir
                    return $ makeAbsolute abs_dir file

makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath
makeAbsolute a dir = if is_absolute dir
                     then AbsolutePath $
                          slashes ++ FilePath.normalise cleandir
                     else ma a $ FilePath.normalise cleandir
  where
    cleandir  = map cleanup dir
    slashes = norm_slashes $ takeWhile (== '/') cleandir
    ma here ('.':'.':'/':r) = ma (takeDirectory here) r
    ma here ".." = takeDirectory here
    ma here "." = here
    ma here "" = here
    ma here r = here /- ('/':r)

(/-) :: AbsolutePath -> String -> AbsolutePath
x /- ('/':r) = x /- r
(AbsolutePath "/") /- r = AbsolutePath ('/':simpleClean r)
(AbsolutePath x) /- r = AbsolutePath (x++'/':simpleClean r)

simpleClean :: String -> String
simpleClean x = norm_slashes $ reverse $ dropWhile (=='/') $ reverse $
                map cleanup x

rootDirectory :: AbsolutePath
rootDirectory = AbsolutePath "/"

makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd
makeAbsoluteOrStd _ "-" = APStd
makeAbsoluteOrStd a p = AP $ makeAbsolute a p

ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd
ioAbsoluteOrStd "-" = return APStd
ioAbsoluteOrStd p = AP `fmap` ioAbsolute p

useAbsoluteOrStd :: (AbsolutePath -> IO a) -> IO a -> AbsolutePathOrStd -> IO a
useAbsoluteOrStd _ f APStd = f
useAbsoluteOrStd f _ (AP x) = f x

ioAbsoluteOrRemote :: String -> IO AbsoluteOrRemotePath
ioAbsoluteOrRemote p = do
  isdir <- doesDirectoryExist p
  if not isdir
     then return $ RmtP $
          case () of _ | is_ssh_nopath p    -> p++"."
                       | "/" `isSuffixOf` p -> init p
                       | otherwise          -> p
     else AbsP `fmap` ioAbsolute p

isRemote :: AbsoluteOrRemotePath -> Bool
isRemote (RmtP _) = True
isRemote _ = False

takeDirectory :: AbsolutePath -> AbsolutePath
takeDirectory (AbsolutePath x) =
    case reverse $ drop 1 $ dropWhile (/='/') $ reverse x of
    "" -> AbsolutePath "/"
    x' -> AbsolutePath x'

instance Show AbsolutePath where
 show = show . toFilePath
instance Show SubPath where
 show = show . toFilePath
instance Show AbsolutePathOrStd where
    show (AP a) = show a
    show APStd = "standard input/output"
instance Show AbsoluteOrRemotePath where
    show (AbsP a) = show a
    show (RmtP r) = show r

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

getCurrentDirectory :: IO AbsolutePath
getCurrentDirectory = AbsolutePath `fmap` Workaround.getCurrentDirectory

setCurrentDirectory :: FilePathLike p => p -> IO ()
setCurrentDirectory = System.Directory.setCurrentDirectory . toFilePath

{-# INLINE sp2fn #-}
sp2fn :: SubPath -> PatchFileName.FileName
sp2fn = PatchFileName.fp2fn . toFilePath