src/Darcs/RepoPath.hs

   1 {-# OPTIONS_GHC -cpp #-}
   2 {-# LANGUAGE CPP #-}
   3
   4 -- Copyright (C) 2007 Eric Kow
   5 --
   6 -- This program is free software; you can redistribute it and/or modify
   7 -- it under the terms of the GNU General Public License as published by
   8 -- the Free Software Foundation; either version 2, or (at your option)
   9 -- any later version.
  10 --
  11 -- This program is distributed in the hope that it will be useful,
  12 -- but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 -- GNU General Public License for more details.
  15 --
  16 -- You should have received a copy of the GNU General Public License
  17 -- along with this program; see the file COPYING.  If not, write to
  18 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 -- Boston, MA 02110-1301, USA.
  20
  21 module Darcs.RepoPath ( AbsolutePath, makeAbsolute, ioAbsolute, rootDirectory,
  22                         SubPath, makeSubPathOf, simpleSubPath,
  23                         AbsolutePathOrStd,
  24                         makeAbsoluteOrStd, ioAbsoluteOrStd, useAbsoluteOrStd,
  25                         makeRelative, sp2fn,
  26                         FilePathOrURL(..), FilePathLike(toFilePath),
  27                         getCurrentDirectory, setCurrentDirectory
  28                       ) where
  29
  30 import Data.List ( isPrefixOf )
  31 import Control.Exception ( bracket )
  32
  33 import Darcs.URL ( is_absolute, is_relative )
  34 import Autoconf ( path_separator )
  35 import qualified Workaround ( getCurrentDirectory )
  36 import qualified System.Directory ( setCurrentDirectory )
  37 import System.Directory ( doesDirectoryExist )
  38 import UglyFileName ( fn2fp, super_name, fp2fn, own_name, norm_path )
  39 import qualified Darcs.Patch.FileName as PatchFileName ( FileName, fp2fn, fn2fp )
  40
  41 class FilePathOrURL a where
  42  {-# INLINE toPath #-}
  43  toPath :: a -> String
  44
  45 class FilePathOrURL a => FilePathLike a where
  46  {-# INLINE toFilePath #-}
  47  toFilePath :: a -> FilePath
  48
  49 -- | Relative to the local darcs repository and normalized
  50 --   Note: these are understood not to have the dot in front
  51 newtype SubPath      = SubPath FilePath deriving (Eq, Ord)
  52 newtype AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord)
  53 data AbsolutePathOrStd = AP AbsolutePath | APStd deriving (Eq, Ord)
  54
  55 instance FilePathOrURL AbsolutePath where
  56  toPath (AbsolutePath x) = x
  57 instance FilePathOrURL SubPath where
  58  toPath (SubPath x) = x
  59 instance CharLike c => FilePathOrURL [c] where
  60  toPath = toFilePath
  61
  62 instance FilePathOrURL PatchFileName.FileName where
  63     toPath = PatchFileName.fn2fp
  64 instance FilePathLike PatchFileName.FileName where
  65     toFilePath = PatchFileName.fn2fp
  66
  67 instance FilePathLike AbsolutePath where
  68  toFilePath (AbsolutePath x) = x
  69 instance FilePathLike SubPath where
  70  toFilePath (SubPath x) = x
  71
  72 class CharLike c where
  73     toChar :: c -> Char
  74     fromChar :: Char -> c
  75 instance CharLike Char where
  76     toChar = id
  77     fromChar = id
  78
  79 instance CharLike c => FilePathLike [c] where
  80     toFilePath = map toChar
  81
  82 -- | Make the second path relative to the first, if possible
  83 makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath
  84 makeSubPathOf (AbsolutePath p1) (AbsolutePath p2) =
  85  -- The slash prevents "foobar" from being treated as relative to "foo"
  86  if p1 == p2 || (p1 ++ "/") `isPrefixOf` p2
  87     then Just $ SubPath $ drop (length p1 + 1) p2
  88     else Nothing
  89
  90 simpleSubPath :: FilePath -> Maybe SubPath
  91 simpleSubPath x | is_relative x = Just $ SubPath $ fn2fp $ norm_path $ fp2fn $ map cleanup x
  92                 | otherwise = Nothing
  93
  94 makeRelative :: AbsolutePath -> AbsolutePath -> FilePath
  95 makeRelative (AbsolutePath p1) (AbsolutePath p2) = mr p1 p2
  96     where mr x y | x == y = "."
  97           mr x y | takedir x == takedir y = mr (dropdir x) (dropdir y)
  98           mr x y = add_dotdots x y
  99           add_dotdots "" y = dropWhile  (=='/') y
 100           add_dotdots x y = '.':'.':'/': add_dotdots (dropdir x) y
 101           takedir = takeWhile (/='/')  . dropWhile (=='/')
 102           dropdir = dropWhile (/='/') . dropWhile (=='/')
 103
 104 -- | Interpret a possibly relative path wrt the current working directory
 105 ioAbsolute :: FilePath -> IO AbsolutePath
 106 ioAbsolute dir =
 107     do isdir <- doesDirectoryExist dir
 108        here <- getCurrentDirectory
 109        if isdir
 110          then bracket (setCurrentDirectory dir)
 111                       (const $ setCurrentDirectory $ toFilePath here)
 112                       (const getCurrentDirectory)
 113          else let super_dir = (fn2fp . super_name . fp2fn) dir
 114                   file = (fn2fp . own_name . fp2fn) dir
 115               in do abs_dir <- ioAbsolute super_dir
 116                     return $ makeAbsolute abs_dir file
 117
 118 makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath
 119 makeAbsolute a dir = if is_absolute dir
 120                      then AbsolutePath $
 121                           slashes ++ (fn2fp $ norm_path $ fp2fn cleandir)
 122                      else ma a $ fn2fp $ norm_path $ fp2fn cleandir
 123   where
 124     cleandir  = map cleanup dir
 125     slashes = norm_slashes $ takeWhile (== '/') cleandir
 126     ma here ('.':'.':'/':r) = ma (takeDirectory here) r
 127     ma here ".." = takeDirectory here
 128     ma here "." = here
 129     ma here "" = here
 130     ma here r = here /- ('/':r)
 131
 132 (/-) :: AbsolutePath -> String -> AbsolutePath
 133 x /- ('/':r) = x /- r
 134 (AbsolutePath "/") /- r = AbsolutePath ('/':simpleClean r)
 135 (AbsolutePath x) /- r = AbsolutePath (x++'/':simpleClean r)
 136
 137 simpleClean :: String -> String
 138 simpleClean x = norm_slashes $ reverse $ dropWhile (=='/') $ reverse $
 139                 map cleanup x
 140
 141 rootDirectory :: AbsolutePath
 142 rootDirectory = AbsolutePath "/"
 143
 144 makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd
 145 makeAbsoluteOrStd _ "-" = APStd
 146 makeAbsoluteOrStd a p = AP $ makeAbsolute a p
 147
 148 ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd
 149 ioAbsoluteOrStd "-" = return APStd
 150 ioAbsoluteOrStd p = AP `fmap` ioAbsolute p
 151
 152 useAbsoluteOrStd :: (AbsolutePath -> IO a) -> IO a -> AbsolutePathOrStd -> IO a
 153 useAbsoluteOrStd _ f APStd = f
 154 useAbsoluteOrStd f _ (AP x) = f x
 155
 156 takeDirectory :: AbsolutePath -> AbsolutePath
 157 takeDirectory (AbsolutePath x) =
 158     case reverse $ drop 1 $ dropWhile (/='/') $ reverse x of
 159     "" -> AbsolutePath "/"
 160     x' -> AbsolutePath x'
 161
 162 instance Show AbsolutePath where
 163  show = show . toFilePath
 164 instance Show SubPath where
 165  show = show . toFilePath
 166 instance Show AbsolutePathOrStd where
 167     show (AP a) = show a
 168     show APStd = "standard input/output"
 169
 170 cleanup :: Char -> Char
 171 cleanup '\\' | path_separator == '\\' = '/'
 172 cleanup c = c
 173
 174 norm_slashes :: String -> String
 175 #ifndef WIN32
 176 -- multiple slashes in front are ignored under Unix
 177 norm_slashes ('/':p) = '/' : dropWhile (== '/') p
 178 #endif
 179 norm_slashes p = p
 180
 181 getCurrentDirectory :: IO AbsolutePath
 182 getCurrentDirectory = AbsolutePath `fmap` Workaround.getCurrentDirectory
 183
 184 setCurrentDirectory :: FilePathLike p => p -> IO ()
 185 setCurrentDirectory = System.Directory.setCurrentDirectory . toFilePath
 186
 187 {-# INLINE sp2fn #-}
 188 sp2fn :: SubPath -> PatchFileName.FileName
 189 sp2fn = PatchFileName.fp2fn . toFilePath