{-# LANGUAGE GADTs, ViewPatterns, ScopedTypeVariables, MultiParamTypeClasses,
             FlexibleInstances, OverloadedStrings, CPP, FunctionalDependencies,
             EmptyDataDecls, FlexibleContexts, DeriveDataTypeable, TypeFamilies #-}

module Data.Path.Implementation where

import Prelude hiding ( FilePath )
import Control.Exception ( finally )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.ByteString.Internal ( c2w )
import Data.List( isPrefixOf, inits )
import Data.Data( Typeable, Data )
import Unsafe.Coerce( unsafeCoerce )
import System.Directory( getCurrentDirectory, setCurrentDirectory, doesDirectoryExist )

-------------------------------
-- Path utilities
--

coerceObject :: Path s p o -> Path s p o'
coerceObject = unsafeCoerce

coerceType :: Path s p o -> Path s p' o
coerceType = unsafeCoerce

-- Path "spec" witnesses

-- | Posix is the real POSIX paths, where foo/.. can mean something else than
-- ".". It is a runtime error to join ".." to a POSIX path (by extension, such
-- paths cannot be parsed if they contain ".." components). You need to use
-- "ioJoin" / "ioParsePath" and related to handle these paths.
data Posix
-- | The W32 type represents Windows-style paths.
data W32

-- Path "object" (type) witnesses
data Directory
data File
data Any

class DirectoryW w
instance DirectoryW Directory
instance DirectoryW Any

class FileW w
instance FileW File
instance FileW Any

-- Path "path" (type) witness
data Absolute
data Relative
data Sub

class SuffixClass x where
  type Suffix x :: *

instance SuffixClass Absolute where
  type Suffix Absolute = Sub

instance SuffixClass Sub where
  type Suffix Sub = Sub

instance SuffixClass Relative where
  type Suffix Relative = Relative

class AbsoluteW w
instance AbsoluteW Absolute
instance AbsoluteW Sub -- Hmm.

class RelativeW w
instance RelativeW Relative
instance RelativeW Sub

type Name = BS.ByteString

data (PathType spec path) =>
     Path spec path object = Path BS.ByteString
   deriving (Ord, Eq, Typeable, Data)

instance (PathType x y) => Show (Path x y z) where
  show p = "Path " ++ show (pathToString p)

class PathType spec path where
  unpath :: forall object. Path spec path object -> BS.ByteString
  unpath (Path p) = p

  path :: forall object. BS.ByteString -> Path spec path object
  path = Path

  pathToBS :: forall object. Path spec path object -> BS.ByteString
  pathToBS (Path p) = p

  parsePathBS :: forall object. BS.ByteString -> Maybe (Path spec path object)
  parent :: forall dir object. (DirectoryW dir) => Path spec path object -> Path spec path dir

  makeAbsolute :: forall object abs dir. (DirectoryW dir, PathType spec Absolute)
               => Path spec Absolute dir -> Path spec path object -> Path spec Absolute object

  (</>) :: forall obj obj'.
           (PathType spec path) => Path spec path obj -> Name -> Path spec path obj'
  (</>) = join

  separators :: forall obj. Path spec path obj -> [Char]
  separators _ = [ '/' ]

---------------------------------
-- Instances
--

-- POSIX' ----------------

instance PathType Posix Relative where
  parsePathBS = relParse
  parent = relParent
  pathToBS = relPathBS
  makeAbsolute = (+/+)

instance PathType Posix Sub where
  parsePathBS = relParse
  parent = absParent
  pathToBS = relPathBS
  makeAbsolute = (+/+)

instance PathType Posix Absolute where
  unpath (Path x) = BS.drop 1 x
  path = Path . BSC.cons '/'
  parsePathBS = absParse
  parent = absParent
  makeAbsolute _ x = x


-- Windows ---------------

-- TODO: We do not handle drive-qualified relative paths in Relative, since it
-- breaks the whole idea of a relative path. We may need a separate path type
-- for that, which can't be appended to other paths, but can be made absolute
-- or opened.

instance PathType W32 Absolute where
  parsePathBS = winParse absParse
  parent = absParent
  makeAbsolute _ x = x
  unpath (Path x)
    | ":" `BS.isPrefixOf` BS.drop 1 x = BS.concat [BS.take 2 x, BS.drop 3 x]
    | otherwise = BS.drop 1 x
  path x
    | ":" `BS.isPrefixOf` BS.drop 1 x = Path $ BS.concat [BS.take 2 x, "/", BS.drop 2 x]
    | otherwise = Path $ BS.append "/" x
  separators _ = [ '/', '\\' ]

instance PathType W32 Relative where
  parsePathBS = relParse
  parent = relParent
  pathToBS = relPathBS
  makeAbsolute = (+/+)
  separators _ = [ '/', '\\' ]

instance PathType W32 Sub where
  parsePathBS = relParse
  parent = absParent
  pathToBS = relPathBS
  makeAbsolute = (+/+)
  separators _ = [ '/', '\\' ]

editPath :: (PathType a b) => Path a b c -> (BS.ByteString -> BS.ByteString) -> Path a b c
editPath p f = path $ f $ unpath p

root :: (PathType spec path) => Path spec path object
root = path ""

relPathBS (unpath -> p) | BS.null p = "."
                        | otherwise = p

-----------------------------------
-- Parsing paths
--

parse :: forall spec path object. (PathType spec path)
      => BS.ByteString -> Path spec path object
parse path
  | BS.null path = root
  | fst (BS.span (`notElem` sep) path) == "." = parse $ BS.drop 2 path
  | BS.head path `elem` sep = parse $ BS.drop 1 path
  | otherwise = case BS.spanEnd (`notElem` sep) path of
                 (head', tail) -> case BS.spanEnd (`elem` sep) head' of
                   (head, _) -> (parse head :: Path spec path object) </>
                                 tail :: Path spec path object
    where sep = map c2w $ separators (undefined :: Path spec path object)

relParse :: forall spec path object. (PathType spec path)
         => BS.ByteString -> Maybe (Path spec path object)
relParse path
  | BS.null path = Just root
  | BS.head path `elem` sep = Nothing
  | otherwise = Just $ parse path
    where sep = map c2w $ separators (undefined :: Path spec path object)

absParse :: forall spec path object. (PathType spec path)
         => BS.ByteString -> Maybe (Path spec path object)
absParse path
  | BS.null path = Nothing
  | BS.head path `notElem` sep = Nothing
  | otherwise = Just $ parse path
    where sep = map c2w $ separators (undefined :: Path spec path object)

winParse :: forall spec path object. (PathType spec path) =>
            (BS.ByteString -> Maybe (Path spec path object)) ->
            BS.ByteString -> Maybe (Path spec path object)
winParse parse raw = case BS.breakByte (c2w ':') raw of
  (drive, rest) | ":" `BS.isPrefixOf` rest && BS.length drive == 1 ->
    fmap (path . (BS.append (BS.concat [drive, ":"])) . unpath) $ parse $ BS.drop 1 rest
  _ | "\\\\" `BS.isPrefixOf` raw || "//" `BS.isPrefixOf` raw ->
    fmap (path . (joinUNC $ BS.concat ["//", BS.takeWhile (`notElem` sep) $ BS.drop 2 raw])
          . unpath) $ parse $ BS.dropWhile (`notElem` sep) $ BS.drop 2 raw -- this is an UNC path
  _ -> parse raw -- drive-less, UNC-less path
 where sep = map c2w $ separators (undefined :: Path spec path object)
       joinUNC a b | BS.null b = a
                   | otherwise = BS.concat [a, BSC.singleton '/', b]

------------------------------
-- Going up (..)
--

relParent :: (PathType spec rel, DirectoryW dir, RelativeW rel)
          => Path spec rel object -> Path spec rel dir
relParent p@(unpath -> p')
  | pp :/: last <- file p, last /= ".." = pp
  | otherwise = path $ if BS.null p' then ".." else BS.intercalate "/" [p', ".."]

absParent :: (PathType spec abs, DirectoryW dir, AbsoluteW abs)
          => Path spec abs object -> Path spec abs dir
absParent p
  | pp :/: _ <- file p = pp
  | otherwise = root

----------------------------
-- Predicates & views
--

data Split a b = a :/: b | Atomic deriving Show

singleton :: forall spec path object. (PathType spec path)
          => Path spec path object -> Maybe BS.ByteString
singleton (file -> (dir :: Path spec path Directory) :/: file)
  | isRoot dir = Just file
singleton _ = Nothing

directory :: forall spec path object rel. (PathType spec path, PathType spec rel, RelativeW rel)
          => Path spec path object -> Split BS.ByteString (Path spec rel object)
directory orig@(unpath -> p) = case BS.breakByte (c2w '/') p of
  _ | isRoot (coerceObject orig :: Path spec path Directory) -> Atomic
  (dir, p') -> dir :/: (path (BS.drop 1 p') :: Path spec rel object)

file :: forall spec path dir object.
        (PathType spec path, PathType spec path, DirectoryW dir)
     => Path spec path object -> Split (Path spec path dir) BS.ByteString
file orig@(unpath -> p) = case BS.breakEnd (==(c2w '/')) p of
  _ | isRoot (coerceObject orig :: Path spec path Directory) -> Atomic
  (p', file) | isRoot (path p' :: Path spec path dir) -> root :/: file
             | otherwise -> (path $ BS.init p' :: Path spec path dir) :/: file

isRoot :: (PathType spec path, DirectoryW dir) => Path spec path dir -> Bool
isRoot (unpath -> p) = case p of
  _ | BS.null p -> True
  _ | "//" `BS.isPrefixOf` p && BS.null (BS.dropWhile (/= (c2w '/')) $ BS.drop 2 p) -> True
  _ | ":" `BS.isPrefixOf` (BS.drop 1 p) -> (BS.null $ BS.drop 2 p) || "/" == BS.drop 2 p
  _ -> False

-- | Check whether a path is a prefix of another path.
isPrefix :: (PathType spec path) => Path spec path object -> Path spec path object' -> Bool
isPrefix (unpath -> a) (unpath -> b)
  | BS.null a = True
  | BS.length a == BS.length b = a == b
  | BS.isPrefixOf a b = BS.index b (BS.length a) == c2w '/'
  | otherwise = False

basename :: forall spec path object. (PathType spec path) => Path spec path object -> Name
basename (file -> (_ :: Path spec path Any) :/: base) = base

-----------------------------
-- Building paths
--

join :: forall spec path obj obj'.
        (PathType spec path) => Path spec path obj -> Name -> Path spec path obj'
p@(unpath -> p') `join` n
  | BS.null n = coerceObject p
  | n == "." = coerceObject p
  | n == ".." = (coerceObject $ (parent p :: Path spec path Directory))
  | BS.null p' = path $ BS.concat [unpath (root :: Path spec path Directory), n]
  | BS.elem (c2w '/') n = error $ "BUG: Path components may not contain slashes: "
                          ++ show (BSC.unpack p') ++ ", " ++ BSC.unpack n
  | otherwise = path $ BS.concat [p', BSC.singleton '/', n]

safeJoin :: forall spec path obj obj'.
            (PathType spec path) => Path spec path obj -> Name -> Path spec path obj'
p@(unpath -> p') `safeJoin` n
  | n == ".." = error "safeJoin: .. is not allowed as a path component"
  | otherwise = p `join` n

(<.>) :: forall spec path obj.
         (PathType spec path) => Path spec path obj -> Name -> Path spec path obj
p@(file -> (dir :: Path spec path Directory) :/: n) <.> ext = dir </> BS.concat [n, ".", ext]

(+/+) :: forall spec path dir rel object.
         (PathType spec path, PathType spec rel, RelativeW rel, DirectoryW dir)
      => Path spec path dir -> Path spec rel object -> Path spec path object
p@(unpath -> p') +/+ q@(unpath -> q')
  | ".." :/: (_ :: Path spec rel object) <- directory q =
        (parent p :: Path spec path Directory) +/+ (editPath q (BS.drop 3))
  | BS.null q' = path p'
  | BS.null p' = path q'
  | otherwise = path $ BS.concat [ p', BSC.singleton '/', q' ]

relativeTo :: (PathType spec path, PathType spec rel, RelativeW rel, DirectoryW dir) =>
              Path spec path dir -> Path spec path object -> Maybe (Path spec rel object)
relativeTo x@(unpath -> x') y@(unpath -> y')
  | BS.null x' = Just $ path y'
  | x `isPrefix` y = Just $ path $ BS.drop (BS.length x' + 1) y'
  | otherwise = Nothing

-- | The list of "parent" paths. This does not make sense for Relative paths as
-- each relative path has a parent (. -> ..).
parents :: forall spec abs object dir.
           (PathType spec abs, AbsoluteW abs, DirectoryW dir)
        => Path spec abs object -> [Path spec abs dir]
parents (file -> dir :/: _) = dir : parents dir
parents _ = []

toNames (unpath -> p) = BSC.split '/' p -- uh-oh ... not very nice

------------------------------------------------------
-- Going to/from String & ByteString
--

-- | Turn a path to a String that can be used with traditional String-based
-- filepath code, like System.IO and friends.
pathToString :: (PathType spec path) => Path spec path object -> String
pathToString = BSC.unpack . pathToBS

-- | Turn a String into a Path. This may fail, depending on the type of path
-- you requested and the content of the string you passed.
parsePath :: (PathType spec path) => String -> Maybe (Path spec path object)
parsePath = parsePathBS . BSC.pack

-- | Project a path under a rename of directory "from" to "to". Examples:
-- > renamePath some/dir new/dir some/dir/file.txt -> new/dir/file.txt
-- > renamePath some/dir new/dir other/dir/file.txt -> other/dir/file.txt
-- > renamePath some/dir new/dir some/dir -> new/dir
renamePath :: forall spec path dir object object'.
              (PathType spec path, PathType spec Relative, DirectoryW dir)
           => Path spec path dir     -- ^ From: the directory to rename.
           -> Path spec path dir     -- ^ To: the new name of the directory.
           -> Path spec path object' -- ^ The path to project.
           -> Path spec path object'
renamePath from to path
  | Just (suff :: Path spec Relative object') <- relativeTo from path = to +/+ suff
  | otherwise = path

-- | See "Data.Path.eitherPath".
eitherPath :: (PathType spec abs, PathType spec rel, AbsoluteW abs, RelativeW rel)
           => String -> Either (Path spec abs object) (Path spec rel object)
eitherPath p = case (parsePath p, parsePath p) of
  (Nothing, Nothing) -> error $ "BUG: The path " ++ p ++ " is neither relative nor absolute."
  (Just x, Nothing) -> Left x
  (Nothing, Just x) -> Right x
  (Just _, Just _) -> error $ "BUG: The path " ++ p ++ " is both relative and absolute."

-- | Check various path invariants.
pathInvariants :: (PathType a b) => Path a b c -> Bool
pathInvariants p'@(unpath -> p)
  | ".." `elem` (dropWhile (== "..") $ toNames p') = False
  | "/./" `BS.isInfixOf` p = False
  | "//" `BS.isInfixOf` (BS.drop 1 p) = False
  | ".." `BS.isSuffixOf` p && not (BS.null $ BSC.filter (`notElem` ['.', '/']) p) = False
  | otherwise = True

-- | NB. This is not threadsafe. Turn a relative path (relative to current
-- working directory) into an absolute path.
ioAbsolute :: forall spec path object. (PathType spec Absolute, PathType spec path)
           => Path spec path object -> IO (Path spec Absolute object)
ioAbsolute path =
  do Just here <- parsePath `fmap` getCurrentDirectory
     return $ makeAbsolute (here :: Path spec Absolute Directory) path

-- Work in progress.
{-

-- | NB. This is not threadsafe, since it needs to use setCurrentDirectory.
ioJoin :: forall spec path obj obj'.
          (PathType spec path) => Path spec path obj -> Name -> IO (Path spec path obj')
ioJoin p q = do orig <- getCurrentDirectory
                do setCurrentDirectory $ pathToString p
                   Just base <- parsePath `fmap` getCurrentDirectory
                   return $ base `join` q
                 `finally` setCurrentDirectory orig

-- | NB. This is not threadsafe. Parse a path using setCurrentDirectory. This
-- makes it possible to parse POSIX (non-primed) paths with ".." components. It
-- will also resolve any symlinks. NB. This only works for paths that actually
-- exist in the filesystem. You will get an exception otherwise.
ioParsePathBS :: forall path spec object. (PathType spec path)
              => BS.ByteString -> IO (Path spec path object)
ioParsePathBS = ioParsePath . BS.unpack

ioParsePath :: forall path spec object. (PathType spec path)
            => String -> IO (Path spec path object)
ioParsePath p =
  do orig <- getCurrentDirectory
     isdir <- doesDirectoryExist p
     let dirname = if isdir then p
                            else reverse $ dropWhile (`notElem` sep) $ reverse p
         base = if isdir then ""
                         else reverse $ takeWhile (`notElem` sep) $ reverse p
     setCurrentDirectory dirname
     Just dir <- parsePath `fmap` getCurrentDirectory
     return $ dir </> BS.pack base
  where sep = separators (undefined :: Path spec path object)

-}