#define mingw32_TARGET_OS
module FilePath
         ( -- * FilePath
           splitFileName
         , splitFileExt
         , splitFilePath
         , joinFileName
         , joinFileExt
         , joinPaths         
         , changeFileExt
         , isRootedPath
         , isAbsolutePath
         , absolutePath
         , getPathRoot
         
         , pathInits
         , commonInit

         , normalizeCase
         , normalizePath
         
         -- * Search path
         , parseSearchPath
         , mkSearchPath
         
         -- * Separators
         , isPathSeparator
         , pathSeparator
         , searchPathSeparator
         ) where

import Data.List(intersperse)
import Data.Char(toLower, isAlphaNum)
import System.Directory(getCurrentDirectory)
import System.Environment(getEnv)

--------------------------------------------------------------
-- * FilePath
--------------------------------------------------------------

-- | Split the path into directory and file name
splitFileName :: FilePath -> (String, String)
splitFileName p = (reverse path, reverse fname)
  where
    (fname,path') = break isPathSeparator (reverse p)
    path = case path' of
      []                           -> "."
      [_]                          -> path'   -- don't remove the trailing slash if 
                                              -- there is only one character
      (c:path) | isPathSeparator c -> path
      _                            -> path'

-- | Split the path into file name and extension
splitFileExt :: FilePath -> (String, String)
splitFileExt p =
  case pre of
	[]      -> (p, [])
	(_:pre) -> (reverse (pre++path), reverse suf)
  where
    (fname,path) = break isPathSeparator (reverse p)
    (suf,pre) | fname == "." || fname == ".." = (fname,"")
              | otherwise                     = break (== '.') fname

-- | Split the path into directory, filename and extension
splitFilePath :: FilePath -> (String, String, String)
splitFilePath p =
  case pre of
    []      -> (reverse real_dir, reverse suf, [])
    (_:pre) -> (reverse real_dir, reverse pre, reverse suf)
  where
#ifdef mingw32_TARGET_OS
    (path,drive) = break (== ':') (reverse p)
#else
    (path,drive) = (reverse p,"")
#endif
    (file,dir)   = break isPathSeparator path
    (suf,pre)    = case file of
                     ".." -> ("..", "")
                     _    -> break (== '.') file
    
    real_dir = case dir of
      []      -> '.':drive
      [_]     -> pathSeparator:drive
      (_:dir) -> dir++drive

-- "foo/bar" "xyzzy.ext" -> "foo/bar/xyzzy.ext"
-- "."       "xyzzy.ext" -> "xyzzy.ext"
joinFileName :: String -> String -> FilePath
joinFileName ""  fname = fname
joinFileName "." fname = fname
joinFileName dir fname
  | isPathSeparator (last dir) = dir++fname
  | otherwise                  = dir++pathSeparator:fname

joinFileExt :: FilePath -> String -> String
joinFileExt path ""  = path
joinFileExt path ext = path ++ '.':ext

-- | Combines two path strings.
-- If the second path is not rooted (does not include a root or a drive specification on Windows), 
-- the result is a concatenation of the two paths. If the second path includes a root then it
-- is returned.
joinPaths :: FilePath -> FilePath -> FilePath
joinPaths path1 path2
  | isRootedPath path2 = path2
  | otherwise          = 
#ifdef mingw32_TARGET_OS
        case path2 of
          d:':':path2' | take 2 path1 == [d,':'] -> path1 `joinFileName` path2'
                       | otherwise               -> path2
          _                                      -> path1 `joinFileName` path2
#else
        path1 `joinFileName` path2
#endif
  
-- | Changes the extension of a file path.
changeFileExt :: FilePath           -- ^ The path information to modify.
          -> String                 -- ^ The new extension (without a leading period).
                                    -- Specify an empty string to remove an existing 
                                    -- extension from path.
          -> FilePath               -- ^ A string containing the modified path information.
changeFileExt path ext = joinFileExt name ext
  where
    (name,_) = splitFileExt path

-- | On Unix and Macintosh the 'isRootedPath' function is a synonym to 'isAbsolutePath'.
-- The difference is important only on Windows. The rooted path must start from the root
-- directory but may not include the drive letter while the absolute path always includes
-- the drive letter and the full file path.
isRootedPath :: FilePath -> Bool
isRootedPath (c:_) | isPathSeparator c = True
#ifdef mingw32_TARGET_OS
isRootedPath (_:':':c:_) | isPathSeparator c = True  -- path with drive letter
#endif
isRootedPath _ = False

-- | Return True if the specified path is absolute.
isAbsolutePath :: FilePath -> Bool
#ifdef mingw32_TARGET_OS
isAbsolutePath (_:':':c:_) | isPathSeparator c = True
#else
isAbsolutePath (c:_)       | isPathSeparator c = True
#endif
isAbsolutePath _ = False

-- | Return a normalized absolutized version of the file path.
absolutePath :: FilePath -> IO FilePath
absolutePath path = do
  cur <- getCurrentDirectory
  return (normalizePath (cur `joinPaths` path))

-- | Gets the root directory information of the specified path.
-- On Unix and Macintosh this is @Just \"\/\"@ if the path is
-- absolute, @Just \"~\/\"@ if the path is relative to the home
-- directory and @Nothing@ in other cases. On Windows the @Just@
-- value can contain a drive letter and slash (@Just \"c:\\\"@) for 
-- absolute paths or only drive (@Just \"c:\"@) for relative paths.
getPathRoot :: FilePath -> Maybe String
getPathRoot (c:path)       | isPathSeparator c = Just [c]         -- \ or /
#ifdef mingw32_TARGET_OS
getPathRoot (d:':':c:path) | isPathSeparator c = Just [d,':',c]   -- c:\
getPathRoot (d:':':path)   |                   = Just [d,':']     -- c:
#else
getPathRoot ('~':'/':path)                     = Just "~/"        -- ~/
#endif
getPathRoot _                                  = Nothing

-- | Normalize the case of a file path. On Unix, this returns the path unchanged;
-- on case-insensitive filesystems, it converts the path to lowercase. 
-- On Windows, it also converts forward slashes to backward slashes.
normalizeCase :: FilePath -> FilePath
#ifdef mingw32_TARGET_OS
normalizeCase path = map mapCase path
  where
    mapCase c | isPathSeparator c = pathSeparator
              | otherwise         = toLower c
#else
normalizeCase path = path
#endif

-- | Normalize a pathname. This collapses redundant separators and up-level references, 
-- e.g. A\/\/B, A\/.\/B and A\/foo\/..\/B all become A\/B. It does not normalize the case
-- (use 'normalizeCase' for that). On Windows, it converts forward slashes to backward slashes.
normalizePath :: FilePath -> FilePath
normalizePath path = vol ++ concat (intersperse [pathSeparator] (normalize path1))
  where
    (vol,path1) = case path of
      (c:path)       | isPathSeparator c -> ([c],path)
      (d:':':c:path) | isPathSeparator c -> ([d,':',c],path)
      _                                  -> ("",path)

    normalize path
      | null path1 = []
      | otherwise  = 
          case normalize path2 of
            "..":path -> path
            path | dir == "." -> path
                 | otherwise  -> dir : path
      where
        path1       = dropWhile isPathSeparator path
        (dir,path2) = break isPathSeparator path1

-- | Get this path and all its parents.
pathInits :: FilePath -> [FilePath]
pathInits p =
    map ((++) root') (dropEmptyPath $ inits path')
    where
#ifdef mingw32_TARGET_OS
       (root,path) = case break (== ':') p of
          (path,    "") -> ("",path)
          (root,_:path) -> (root++":",path)
#else
       (root,path) = ("",p)
#endif
       (root',path') = case path of
         (c:path) | isPathSeparator c -> (root++[pathSeparator],path)
         _                            -> (root,path)
         
       dropEmptyPath ("":paths) = paths
       dropEmptyPath paths      = paths

       inits :: String -> [String]
       inits [] =  [""]
       inits cs = 
         case pre of
           "."  -> inits suf
           ".." -> map (joinFileName pre) (dropEmptyPath $ inits suf)
           _    -> "" : map (joinFileName pre) (inits suf)
         where
           (pre,suf) = case break isPathSeparator cs of
              (pre,"")    -> (pre, "")
              (pre,_:suf) -> (pre,suf)

commonInit :: [FilePath] -> Maybe FilePath
commonInit []           = Nothing
commonInit paths@(p:ps) = 
  case common Nothing "" p ps of
#ifdef mingw32_TARGET_OS
    Nothing | all (not . isAbsolutePath) paths -> 
      case foldr getDrive [] paths of
        []  -> Just "."
        [d] -> Just [d,':']
        _   -> Nothing
#else
    Nothing | all (not . isAbsolutePath) paths -> "."
#endif
    mb_path   -> mb_path
  where
    getDrive (d:':':_) ds 
      | not (d `elem` ds) = d:ds
    getDrive _         ds = ds

    common i acc []     ps = checkSep   i acc         ps
    common i acc (c:cs) ps
      | isPathSeparator c  = removeSep  i acc   cs [] ps
      | otherwise          = removeChar i acc c cs [] ps

    checkSep i acc []      = Just (reverse acc)
    checkSep i acc ([]:ps) = Just (reverse acc)
    checkSep i acc ((c1:p):ps)
      | isPathSeparator c1 = checkSep i acc ps
    checkSep i acc ps      = i

    removeSep i acc cs pacc []          = 
      common (Just (reverse (pathSeparator:acc))) (pathSeparator:acc) cs pacc
    removeSep i acc cs pacc ([]    :ps) = Just (reverse acc)
    removeSep i acc cs pacc ((c1:p):ps)
      | isPathSeparator c1              = removeSep i acc cs (p:pacc) ps
    removeSep i acc cs pacc ps          = i

    removeChar i acc c cs pacc []          = common i (c:acc) cs pacc
    removeChar i acc c cs pacc ([]    :ps) = i
    removeChar i acc c cs pacc ((c1:p):ps)
      | c == c1                            = removeChar i acc c cs (p:pacc) ps
    removeChar i acc c cs pacc ps          = i

--------------------------------------------------------------
-- * Search path
--------------------------------------------------------------

parseSearchPath :: String -> [FilePath]
parseSearchPath path = split searchPathSeparator path
  where
    split :: Char -> String -> [String]
    split c s =
      case rest of
        []      -> [chunk] 
        _:rest' -> chunk : split c rest'
      where
        (chunk, rest) = break (==c) s
    
mkSearchPath :: [FilePath] -> String
mkSearchPath paths = concat (intersperse [searchPathSeparator] paths)


--------------------------------------------------------------
-- * Separators
--------------------------------------------------------------

-- | Checks whether the character is a valid path separator for the host platform.
-- The valid character is a 'pathSeparator' but since the Windows operating system 
-- also accepts a backslash (\"\\\") the function also checks for \"\/\" on this platform.
isPathSeparator :: Char -> Bool
isPathSeparator ch =
#ifdef mingw32_TARGET_OS
  ch == '/' || ch == '\\'
#else
  ch == '/'
#endif

-- | Provides a platform-specific character used to separate directory levels in a 
-- path string that reflects a hierarchical file system organization.
-- The separator is a slash (\"\/\") on Unix and Macintosh, and a backslash (\"\\\") on the 
-- Windows operating system.
pathSeparator :: Char
#ifdef mingw32_TARGET_OS
pathSeparator = '\\'
#else
pathSeparator = '/'
#endif

-- A platform-specific separator character used to separate search path strings in 
-- environment variables. The separator is a colon (\"\/\") on Unix and Macintosh, 
-- and a semicolon (\";\") on the Windows operating system.
searchPathSeparator :: Char
#ifdef mingw32_TARGET_OS
searchPathSeparator = ';'
#else
searchPathSeparator = ':'
#endif