FilePathUtils.hs

{-# OPTIONS_GHC -cpp #-}
-- Copyright (C) 2005 David Roundy
--
-- 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.FilePathUtils ( DarcsPath(..), repoPath, unfixedRepoPath,
                             absolute_dir,
                             darcsPath, unfixedDarcsPath, unmake_relative,
                             make_absolute, just_dir, drop_paths, (///) ) where

import Data.Maybe ( catMaybes )

import System.Directory ( doesDirectoryExist )
import Darcs.Utils ( withCurrentDirectory )
import Workaround ( getCurrentDirectory )
import Darcs.URL ( is_ssh_nopath )
import Autoconf ( path_separator )
import FileName ( fn2fp, fp2fn, norm_path )
import Darcs.RepoPath ( AbsolutePath, mkAbsolutePath,
                        RelativePath,
                        SubPath, maybeMkSubPath,
                        toFilePath, FilePathOrURL(..),
                        makeSubPathOf, makeAbsolute, combine,
                      )
import Darcs.URL ( is_absolute, is_relative, is_file )
#include "impossible.h"

data DarcsPath = RepoDP SubPath
               | DotDotDP RelativePath
               | AbsoluteDP AbsolutePath
               | RemoteDP String
     deriving (Ord, Eq)

instance FilePathOrURL DarcsPath where
 toPath (RepoDP x) = toFilePath x
 toPath (DotDotDP x) = toFilePath x
 toPath (AbsoluteDP x) = toFilePath x
 toPath (RemoteDP x) = x

-- | like 'darcsPath', except that it treats remote-looking paths like
--   relative paths
repoPath :: AbsolutePath -> FilePath -> String -> Maybe SubPath
repoPath repo fix pat = fma pat
    where fma p | is_absolute p = makeSubPathOf repo (mkAbsolutePath p)
                | otherwise     = either2maybe $ maybeMkSubPath (fix /// p)

unfixedRepoPath :: FilePath -> Maybe SubPath
unfixedRepoPath p
  | is_absolute p = Nothing
  | otherwise     = either2maybe $ maybeMkSubPath p

darcsPath :: AbsolutePath -> FilePath -> String -> DarcsPath
darcsPath _ _ pat | not $ is_file pat = RemoteDP pat
darcsPath repo fix pat = fma pat
    where fma p | is_relative p = relativeDarcsPath (fix /// p)
                | is_absolute p = case makeSubPathOf repo (mkAbsolutePath p) of
                                  Just sp -> RepoDP sp
                                  Nothing -> AbsoluteDP $ mkAbsolutePath p
                | otherwise = RemoteDP p

relativeDarcsPath :: FilePath -> DarcsPath
relativeDarcsPath p = either DotDotDP RepoDP (maybeMkSubPath p)

unfixedDarcsPath :: FilePath -> DarcsPath
unfixedDarcsPath pat | not $ is_file pat = RemoteDP pat
unfixedDarcsPath pat | is_relative pat = relativeDarcsPath pat
unfixedDarcsPath pat | otherwise = AbsoluteDP $ mkAbsolutePath pat

unmake_relative :: FilePath -> FilePath -> FilePath
unmake_relative _ pat | not $ is_file pat = pat
unmake_relative fix pat = fma $ map cleanup pat
    where fma p | is_absolute p = p
          fma p = make_dotdots fix /// p

make_absolute :: AbsolutePath -> FilePath -> AbsolutePath
make_absolute fix pat
  | is_absolute pat = mkAbsolutePath pat
  | otherwise = case maybeMkSubPath pat of
                Left  rp -> makeAbsolute fix rp
                Right sp -> combine fix sp

-- The following function was moved here as a refactor, just to get it out
-- of DarcsRepo.  It really should be integrated with this new framework,
-- but I'll leave that for later...

absolute_dir :: FilePath -> IO FilePath
absolute_dir dir = do
  isdir <- doesDirectoryExist dir
  if not isdir
     then if is_ssh_nopath dir
            then return $ dir++"."
            else return $ if (take 1 $ reverse dir) == "/"
              then init dir
              else dir
             -- hope it's an URL
     else do
          realdir <- withCurrentDirectory dir getCurrentDirectory
                     -- This one is absolute!
          return realdir

cleanup :: Char -> Char
cleanup '\\' | path_separator == '\\' = '/'
cleanup c = c

make_dotdots :: FilePath -> FilePath
make_dotdots "" = ""
make_dotdots p | is_absolute p = bug $ "Can't make_dotdots on an absolute path:  " ++ p
make_dotdots p = "../" ++ case snd $ break (=='/') p of
                          "" -> ""
                          r -> make_dotdots $ drop 1 r

drop_paths :: String -> [String] -> [String]
drop_paths "" ps = map norm_relative ps
    where norm_relative f | is_relative f = do_norm f
                          | otherwise = f
drop_paths fix ps = catMaybes $ map drop_path ps
  where drop_path p | not $ is_relative p = Just p
        drop_path ('.':'/':p) = drop_path $ dropWhile (=='/') p
        drop_path p = if take (length fix) p == fix
                      then Just $ dropWhile (=='/') $ drop (length fix) p
                      else if is_relative p
                           then Nothing
                           else Just p

just_dir :: FilePath -> FilePath
just_dir d = reverse $ takeWhile (/='/') $ reverse d

(///) :: FilePath -> FilePath -> FilePath
""///a = do_norm a
a///b = do_norm $ a ++ "/" ++ b

do_norm :: FilePath -> FilePath
do_norm f = fn2fp $ norm_path $ fp2fn f

either2maybe :: Either a b -> Maybe b
either2maybe = either (const Nothing) Just