{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      :  System.CanonicalizePath
-- License     :  GPL-2
-- Maintainer  :  yi-devel@googlegroups.com
-- Stability   :  experimental
-- Portability :  portable
--
-- System.Directory.canonicalizePath replacement
module System.CanonicalizePath
  ( canonicalizePath
  , replaceShorthands
  ) where


#ifdef mingw32_HOST_OS
import           System.FilePath          (normalise)
import qualified System.Win32             as Win32
#endif

import           Control.Exc              (ignoringException)
import           Control.Monad            (foldM)
import           Data.List.Split          (splitOneOf)
import           Data.Monoid              ((<>))
import qualified Data.Text                as T (Text, empty, splitOn)
import           System.Directory         (getCurrentDirectory)
import           System.FilePath          (isAbsolute, isDrive, pathSeparator,
                                           pathSeparators, takeDirectory, (</>))
import           System.PosixCompat.Files (readSymbolicLink)

-- | Returns absolute name of the file, which doesn't contain
-- any `/./`, `/../`, `//` sequences or symlinks
canonicalizePath :: FilePath -> IO FilePath
canonicalizePath :: String -> IO String
canonicalizePath String
path = do
#if !defined(mingw32_HOST_OS)
  String
absPath <- String -> IO String
makeAbsolute String
path
  (String -> String -> IO String) -> String -> [String] -> IO String
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\String
x String
y -> String -> IO String
expandSym (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
combinePath String
x String
y) String
"/" ([String] -> IO String) -> [String] -> IO String
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitPath String
absPath
#else
  Win32.getFullPathName . normalise $ path
#endif

-- | Dereferences symbolic links until regular
-- file/directory/something_else appears
expandSym :: FilePath -> IO FilePath
expandSym :: String -> IO String
expandSym String
fpath = do
  -- System.Posix.Files.getFileStatus dereferences symlink before
  -- checking its status, so it's useless here
  Maybe String
deref <- IO (Maybe String) -> IO (Maybe String)
forall a. IO (Maybe a) -> IO (Maybe a)
ignoringException (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readSymbolicLink String
fpath)
  case Maybe String
deref of
    Just String
slink -> String -> IO String
expandSym (if String -> Bool
isAbsolute String
slink
                    then String
slink
                    else (String -> String -> String) -> String -> [String] -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl String -> String -> String
combinePath (String -> String
takeDirectory String
fpath) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitPath String
slink)
    Maybe String
Nothing -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
fpath

-- | Make a path absolute.
makeAbsolute :: FilePath -> IO FilePath
makeAbsolute :: String -> IO String
makeAbsolute String
f
    | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
f) Bool -> Bool -> Bool
&& String -> Char
forall a. HasCallStack => [a] -> a
head String
f Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'~', Char
pathSeparator] = String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
f
    | Bool
otherwise = (String -> String) -> IO String -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
</> String
f) IO String
getCurrentDirectory

-- | Combines two paths, moves up one level on ..
combinePath :: FilePath -> String -> FilePath
combinePath :: String -> String -> String
combinePath String
x String
"."  = String
x
combinePath String
x String
".." = String -> String
takeDirectory String
x
combinePath String
"/" String
y  = String
"/" String -> String -> String
</> String
y
combinePath String
x String
y
    | String -> Bool
isDrive String
x = (String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
pathSeparator]) String -> String -> String
</> String
y -- "C:" </> "bin" = "C:bin"
    | Bool
otherwise = String
x String -> String -> String
</> String
y

-- Replace utility shorthands, similar to Emacs
--
-- @
-- somepath//someotherpath  ≅ /someotherpath
-- somepath/~/someotherpath ≅ ~/someotherpath
-- @
replaceShorthands :: T.Text -> T.Text
replaceShorthands :: Text -> Text
replaceShorthands = Text -> Text -> Text -> Text
r Text
"/~" Text
"~/" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
r Text
"//" Text
"/"
  where
    r :: T.Text -> T.Text -> T.Text -> T.Text
    r :: Text -> Text -> Text -> Text
r Text
s Text
r' Text
a = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
s Text
a of
      []     -> Text
T.empty
      [Text
a']   -> Text
a'
      Text
_ : [Text]
as -> Text
r' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. HasCallStack => [a] -> a
last [Text]
as

-- | Splits path into parts by path separator
--
-- Text version would look like
--
-- @'T.filter' (not . T.null) . T.split (`elem` pathSeparators)@
--
-- But we should move to @system-filepath@ package anyway.
splitPath :: FilePath -> [String]
splitPath :: String -> [String]
splitPath = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOneOf String
pathSeparators