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