module Path
(
Path
,Abs
,Rel
,File
,Dir
,parseAbsDir
,parseRelDir
,parseAbsFile
,parseRelFile
,PathParseException
,mkAbsDir
,mkRelDir
,mkAbsFile
,mkRelFile
,(</>)
,stripDir
,isParentOf
,parent
,filename
,dirname
,toFilePath
,fromAbsDir
,fromRelDir
,fromAbsFile
,fromRelFile
)
where
import Control.Exception (Exception)
import Control.Monad.Catch (MonadThrow(..))
import Data.Data
import Data.List
import Data.Maybe
import Language.Haskell.TH
import Path.Internal
import qualified System.FilePath as FilePath
data Abs deriving (Typeable)
data Rel deriving (Typeable)
data File deriving (Typeable)
data Dir deriving (Typeable)
data PathParseException
= InvalidAbsDir FilePath
| InvalidRelDir FilePath
| InvalidAbsFile FilePath
| InvalidRelFile FilePath
| Couldn'tStripPrefixDir FilePath FilePath
deriving (Show,Typeable)
instance Exception PathParseException
parseAbsDir :: MonadThrow m
=> FilePath -> m (Path Abs Dir)
parseAbsDir filepath =
if FilePath.isAbsolute filepath &&
not (null (normalizeDir filepath)) &&
not ("~/" `isPrefixOf` filepath) &&
not (hasParentDir filepath)
then return (Path (normalizeDir filepath))
else throwM (InvalidAbsDir filepath)
parseRelDir :: MonadThrow m
=> FilePath -> m (Path Rel Dir)
parseRelDir filepath =
if not (FilePath.isAbsolute filepath) &&
not (null filepath) &&
not ("~/" `isPrefixOf` filepath) &&
not (hasParentDir filepath) &&
not (null (normalizeDir filepath)) &&
filepath /= ".."
then return (Path (normalizeDir filepath))
else throwM (InvalidRelDir filepath)
parseAbsFile :: MonadThrow m
=> FilePath -> m (Path Abs File)
parseAbsFile filepath =
if FilePath.isAbsolute filepath &&
not (FilePath.hasTrailingPathSeparator filepath) &&
not ("~/" `isPrefixOf` filepath) &&
not (hasParentDir filepath) &&
not (null (normalizeFile filepath)) &&
filepath /= ".."
then return (Path (normalizeFile filepath))
else throwM (InvalidAbsFile filepath)
parseRelFile :: MonadThrow m
=> FilePath -> m (Path Rel File)
parseRelFile filepath =
if not (FilePath.isAbsolute filepath ||
FilePath.hasTrailingPathSeparator filepath) &&
not (null filepath) &&
not ("~/" `isPrefixOf` filepath) &&
not (hasParentDir filepath) &&
not (null (normalizeFile filepath)) &&
filepath /= ".."
then return (Path (normalizeFile filepath))
else throwM (InvalidRelFile filepath)
hasParentDir :: FilePath -> Bool
hasParentDir filepath' =
("/.." `isSuffixOf` filepath) ||
("/../" `isInfixOf` filepath) ||
("../" `isPrefixOf` filepath)
where
filepath =
case FilePath.pathSeparator of
'/' -> filepath'
x -> map (\y -> if x == y then '/' else y) filepath'
mkAbsDir :: FilePath -> Q Exp
mkAbsDir s =
case parseAbsDir s of
Left err -> error (show err)
Right (Path str) ->
[|Path $(return (LitE (StringL str))) :: Path Abs Dir|]
mkRelDir :: FilePath -> Q Exp
mkRelDir s =
case parseRelDir s of
Left err -> error (show err)
Right (Path str) ->
[|Path $(return (LitE (StringL str))) :: Path Rel Dir|]
mkAbsFile :: FilePath -> Q Exp
mkAbsFile s =
case parseAbsFile s of
Left err -> error (show err)
Right (Path str) ->
[|Path $(return (LitE (StringL str))) :: Path Abs File|]
mkRelFile :: FilePath -> Q Exp
mkRelFile s =
case parseRelFile s of
Left err -> error (show err)
Right (Path str) ->
[|Path $(return (LitE (StringL str))) :: Path Rel File|]
toFilePath :: Path b t -> FilePath
toFilePath (Path l) = l
fromAbsDir :: Path Abs Dir -> FilePath
fromAbsDir = toFilePath
fromRelDir :: Path Rel Dir -> FilePath
fromRelDir = toFilePath
fromAbsFile :: Path Abs File -> FilePath
fromAbsFile = toFilePath
fromRelFile :: Path Rel File -> FilePath
fromRelFile = toFilePath
(</>) :: Path b Dir -> Path Rel t -> Path b t
(</>) (Path a) (Path b) = Path (a ++ b)
stripDir :: MonadThrow m
=> Path b Dir -> Path b t -> m (Path Rel t)
stripDir (Path p) (Path l) =
case stripPrefix p l of
Nothing -> throwM (Couldn'tStripPrefixDir p l)
Just "" -> throwM (Couldn'tStripPrefixDir p l)
Just ok -> return (Path ok)
isParentOf :: Path b Dir -> Path b t -> Bool
isParentOf p l =
isJust (stripDir p l)
parent :: Path Abs t -> Path Abs Dir
parent (Path fp) =
Path (normalizeDir (FilePath.takeDirectory (FilePath.dropTrailingPathSeparator fp)))
filename :: Path b File -> Path Rel File
filename (Path l) =
Path (normalizeFile (FilePath.takeFileName l))
dirname :: Path b Dir -> Path Rel Dir
dirname (Path l) =
Path (last (FilePath.splitPath l))
normalizeDir :: FilePath -> FilePath
normalizeDir =
clean . FilePath.addTrailingPathSeparator . FilePath.normalise
where clean "./" = ""
clean ('/':'/':xs) = clean ('/':xs)
clean x = x
normalizeFile :: FilePath -> FilePath
normalizeFile =
clean . FilePath.normalise
where clean "./" = ""
clean ('/':'/':xs) = clean ('/':xs)
clean x = x