{-# 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, makeAbsolute, ioAbsolute, rootDirectory,
                        SubPath, makeSubPathOf, simpleSubPath,
                        AbsolutePathOrStd,
                        makeAbsoluteOrStd, ioAbsoluteOrStd, useAbsoluteOrStd,
                        makeRelative, sp2fn,
                        FilePathOrURL(..), FilePathLike(toFilePath),
                        getCurrentDirectory, setCurrentDirectory
                      ) where

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

import Darcs.URL ( is_absolute, is_relative )
import Autoconf ( path_separator )
import qualified Workaround ( getCurrentDirectory )
import qualified System.Directory ( setCurrentDirectory )
import System.Directory ( doesDirectoryExist )
import UglyFileName ( fn2fp, super_name, fp2fn, own_name, norm_path )
import qualified Darcs.Patch.FileName as PatchFileName ( FileName, fp2fn )

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
 toInternal = toFilePath
 {-# INLINE fromFilePath #-}
 fromFilePath :: 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 AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord)
data AbsolutePathOrStd = AP AbsolutePath | APStd 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 FilePathLike AbsolutePath where
 toFilePath (AbsolutePath x) = x
 toInternal (AbsolutePath x) = x
 fromFilePath xs       = AbsolutePath xs
instance FilePathLike SubPath where
 toFilePath (SubPath x) = x
 toInternal (SubPath x) = x
 fromFilePath = SubPath

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
    toInternal = map toChar
    fromFilePath = map fromChar

-- | 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 $ fn2fp $ norm_path $ fp2fn $ map cleanup x
                | otherwise = Nothing

makeRelative :: AbsolutePath -> AbsolutePath -> FilePath
makeRelative (AbsolutePath p1) (AbsolutePath p2) = mr p1 p2
    where mr x y | x == y = "."
          mr x y | takedir x == takedir y = mr (dropdir x) (dropdir y)
          mr x y = add_dotdots x y
          add_dotdots "" y = dropWhile  (=='/') y
          add_dotdots x y = '.':'.':'/': add_dotdots (dropdir x) y
          takedir = takeWhile (/='/')  . dropWhile (=='/')
          dropdir = dropWhile (/='/') . dropWhile (=='/')

-- | 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 = (fn2fp . super_name . fp2fn) dir
                  file = (fn2fp . own_name . fp2fn) 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 ++ (fn2fp $ norm_path $ fp2fn cleandir)
                     else ma a $ fn2fp $ norm_path $ fp2fn 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

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"

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
