2015-05-08 10:21:12 +00:00
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
|
|
{-# LANGUAGE EmptyDataDecls #-}
|
2015-05-07 18:14:23 +00:00
|
|
|
|
2015-05-08 10:21:12 +00:00
|
|
|
-- | A normalizing well-typed path type.
|
|
|
|
|
|
|
|
module Path
|
|
|
|
(-- * Types
|
|
|
|
Path
|
|
|
|
,Abs
|
|
|
|
,Rel
|
|
|
|
,File
|
|
|
|
,Dir
|
|
|
|
-- * Parsing
|
|
|
|
,parseAbsDir
|
|
|
|
,parseRelDir
|
|
|
|
,parseAbsFile
|
|
|
|
,parseRelFile
|
|
|
|
,PathParseException
|
|
|
|
-- * Constructors
|
|
|
|
,mkAbsDir
|
|
|
|
,mkRelDir
|
|
|
|
,mkAbsFile
|
|
|
|
,mkRelFile
|
2015-05-08 11:33:37 +00:00
|
|
|
-- * Operations
|
|
|
|
,(</>)
|
|
|
|
,stripDir
|
|
|
|
,isParentOf
|
2015-05-11 16:29:15 +00:00
|
|
|
,parent
|
2015-05-08 11:33:37 +00:00
|
|
|
,filename
|
2015-05-11 16:59:26 +00:00
|
|
|
,dirname
|
2015-05-08 10:21:12 +00:00
|
|
|
-- * Conversion
|
|
|
|
,toFilePath
|
2015-11-21 10:15:34 +00:00
|
|
|
,fromAbsDir
|
|
|
|
,fromRelDir
|
|
|
|
,fromAbsFile
|
|
|
|
,fromRelFile
|
2015-05-08 10:21:12 +00:00
|
|
|
)
|
|
|
|
where
|
|
|
|
|
|
|
|
import Control.Exception (Exception)
|
|
|
|
import Control.Monad.Catch (MonadThrow(..))
|
|
|
|
import Data.Data
|
|
|
|
import Data.List
|
2015-05-08 11:33:37 +00:00
|
|
|
import Data.Maybe
|
2015-05-08 10:21:12 +00:00
|
|
|
import Language.Haskell.TH
|
|
|
|
import Path.Internal
|
|
|
|
import qualified System.FilePath as FilePath
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- Types
|
|
|
|
|
|
|
|
-- | An absolute path.
|
2015-05-11 06:47:17 +00:00
|
|
|
data Abs deriving (Typeable)
|
2015-05-08 10:21:12 +00:00
|
|
|
|
|
|
|
-- | A relative path; one without a root.
|
2015-05-11 06:47:17 +00:00
|
|
|
data Rel deriving (Typeable)
|
2015-05-08 10:21:12 +00:00
|
|
|
|
|
|
|
-- | A file path.
|
2015-05-11 06:47:17 +00:00
|
|
|
data File deriving (Typeable)
|
2015-05-08 10:21:12 +00:00
|
|
|
|
|
|
|
-- | A directory path.
|
2015-05-11 06:47:17 +00:00
|
|
|
data Dir deriving (Typeable)
|
2015-05-08 10:21:12 +00:00
|
|
|
|
|
|
|
-- | Exception when parsing a location.
|
|
|
|
data PathParseException
|
|
|
|
= InvalidAbsDir FilePath
|
|
|
|
| InvalidRelDir FilePath
|
|
|
|
| InvalidAbsFile FilePath
|
|
|
|
| InvalidRelFile FilePath
|
2015-05-22 09:32:41 +00:00
|
|
|
| Couldn'tStripPrefixDir FilePath FilePath
|
2015-05-08 10:21:12 +00:00
|
|
|
deriving (Show,Typeable)
|
|
|
|
instance Exception PathParseException
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- Parsers
|
|
|
|
|
|
|
|
-- | Get a location for an absolute directory. Produces a normalized
|
|
|
|
-- path which always ends in a path separator.
|
|
|
|
--
|
|
|
|
-- Throws: 'PathParseException'
|
|
|
|
--
|
|
|
|
parseAbsDir :: MonadThrow m
|
|
|
|
=> FilePath -> m (Path Abs Dir)
|
|
|
|
parseAbsDir filepath =
|
|
|
|
if FilePath.isAbsolute filepath &&
|
|
|
|
not (null (normalizeDir filepath)) &&
|
2015-11-21 10:14:54 +00:00
|
|
|
not ("~/" `isPrefixOf` filepath) &&
|
2015-06-17 16:45:34 +00:00
|
|
|
not (hasParentDir filepath)
|
2015-05-08 10:21:12 +00:00
|
|
|
then return (Path (normalizeDir filepath))
|
|
|
|
else throwM (InvalidAbsDir filepath)
|
|
|
|
|
|
|
|
-- | Get a location for a relative directory. Produces a normalized
|
|
|
|
-- path which always ends in a path separator.
|
|
|
|
--
|
|
|
|
-- Throws: 'PathParseException'
|
|
|
|
--
|
|
|
|
parseRelDir :: MonadThrow m
|
|
|
|
=> FilePath -> m (Path Rel Dir)
|
|
|
|
parseRelDir filepath =
|
|
|
|
if not (FilePath.isAbsolute filepath) &&
|
|
|
|
not (null filepath) &&
|
2015-11-21 10:14:54 +00:00
|
|
|
not ("~/" `isPrefixOf` filepath) &&
|
2015-06-17 16:21:45 +00:00
|
|
|
not (hasParentDir filepath) &&
|
2015-05-22 09:32:41 +00:00
|
|
|
not (null (normalizeDir filepath)) &&
|
|
|
|
filepath /= ".."
|
2015-05-08 10:21:12 +00:00
|
|
|
then return (Path (normalizeDir filepath))
|
|
|
|
else throwM (InvalidRelDir filepath)
|
|
|
|
|
2015-05-08 13:57:03 +00:00
|
|
|
-- | Get a location for an absolute file.
|
2015-05-08 10:21:12 +00:00
|
|
|
--
|
|
|
|
-- Throws: 'PathParseException'
|
|
|
|
--
|
|
|
|
parseAbsFile :: MonadThrow m
|
|
|
|
=> FilePath -> m (Path Abs File)
|
|
|
|
parseAbsFile filepath =
|
|
|
|
if FilePath.isAbsolute filepath &&
|
|
|
|
not (FilePath.hasTrailingPathSeparator filepath) &&
|
2015-11-21 10:14:54 +00:00
|
|
|
not ("~/" `isPrefixOf` filepath) &&
|
2015-06-17 16:21:45 +00:00
|
|
|
not (hasParentDir filepath) &&
|
2015-05-22 09:32:41 +00:00
|
|
|
not (null (normalizeFile filepath)) &&
|
|
|
|
filepath /= ".."
|
2015-05-08 10:21:12 +00:00
|
|
|
then return (Path (normalizeFile filepath))
|
|
|
|
else throwM (InvalidAbsFile filepath)
|
|
|
|
|
2015-05-08 13:57:03 +00:00
|
|
|
-- | Get a location for a relative file.
|
2015-05-08 10:21:12 +00:00
|
|
|
--
|
|
|
|
-- Throws: 'PathParseException'
|
|
|
|
--
|
|
|
|
parseRelFile :: MonadThrow m
|
|
|
|
=> FilePath -> m (Path Rel File)
|
|
|
|
parseRelFile filepath =
|
2015-05-22 09:32:41 +00:00
|
|
|
if not (FilePath.isAbsolute filepath ||
|
|
|
|
FilePath.hasTrailingPathSeparator filepath) &&
|
2015-05-08 10:21:12 +00:00
|
|
|
not (null filepath) &&
|
2015-11-21 10:14:54 +00:00
|
|
|
not ("~/" `isPrefixOf` filepath) &&
|
2015-06-17 16:21:45 +00:00
|
|
|
not (hasParentDir filepath) &&
|
2015-05-22 09:32:41 +00:00
|
|
|
not (null (normalizeFile filepath)) &&
|
|
|
|
filepath /= ".."
|
2015-05-08 10:21:12 +00:00
|
|
|
then return (Path (normalizeFile filepath))
|
|
|
|
else throwM (InvalidRelFile filepath)
|
|
|
|
|
2015-06-17 16:21:45 +00:00
|
|
|
-- | Helper function: check if the filepath has any parent directories in it.
|
|
|
|
-- This handles the logic of checking for different path separators on Windows.
|
|
|
|
hasParentDir :: FilePath -> Bool
|
|
|
|
hasParentDir filepath' =
|
2015-11-21 10:14:54 +00:00
|
|
|
("/.." `isSuffixOf` filepath) ||
|
|
|
|
("/../" `isInfixOf` filepath) ||
|
|
|
|
("../" `isPrefixOf` filepath)
|
2015-06-17 16:21:45 +00:00
|
|
|
where
|
|
|
|
filepath =
|
|
|
|
case FilePath.pathSeparator of
|
|
|
|
'/' -> filepath'
|
|
|
|
x -> map (\y -> if x == y then '/' else y) filepath'
|
|
|
|
|
2015-05-08 10:21:12 +00:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- Constructors
|
|
|
|
|
|
|
|
-- | Make a 'Path Abs Dir'.
|
|
|
|
--
|
|
|
|
-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@)
|
|
|
|
-- may compile on your platform, but it may not compile on another
|
|
|
|
-- platform (Windows).
|
|
|
|
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|]
|
|
|
|
|
|
|
|
-- | Make a 'Path Rel 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|]
|
|
|
|
|
|
|
|
-- | Make a 'Path Abs File'.
|
|
|
|
--
|
|
|
|
-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@)
|
|
|
|
-- may compile on your platform, but it may not compile on another
|
|
|
|
-- platform (Windows).
|
|
|
|
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|]
|
|
|
|
|
|
|
|
-- | Make a 'Path Rel 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|]
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- Conversion
|
|
|
|
|
|
|
|
-- | Convert to a 'FilePath' type.
|
2015-06-18 06:58:01 +00:00
|
|
|
--
|
|
|
|
-- All directories have a trailing slash, so if you want no trailing
|
|
|
|
-- slash, you can use 'System.FilePath.dropTrailingPathSeparator' from
|
|
|
|
-- the filepath package.
|
2015-05-08 10:21:12 +00:00
|
|
|
toFilePath :: Path b t -> FilePath
|
|
|
|
toFilePath (Path l) = l
|
|
|
|
|
2015-11-21 10:15:34 +00:00
|
|
|
-- | Convert absolute path to directory to 'FilePath' type.
|
|
|
|
fromAbsDir :: Path Abs Dir -> FilePath
|
|
|
|
fromAbsDir = toFilePath
|
|
|
|
|
|
|
|
-- | Convert relative path to directory to 'FilePath' type.
|
|
|
|
fromRelDir :: Path Rel Dir -> FilePath
|
|
|
|
fromRelDir = toFilePath
|
|
|
|
|
|
|
|
-- | Convert absolute path to file to 'FilePath' type.
|
|
|
|
fromAbsFile :: Path Abs File -> FilePath
|
|
|
|
fromAbsFile = toFilePath
|
|
|
|
|
|
|
|
-- | Convert relative path to file to 'FilePath' type.
|
|
|
|
fromRelFile :: Path Rel File -> FilePath
|
|
|
|
fromRelFile = toFilePath
|
|
|
|
|
2015-05-08 11:33:37 +00:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- Operations
|
|
|
|
|
|
|
|
-- | Append two paths.
|
|
|
|
--
|
|
|
|
-- The following cases are valid and the equalities hold:
|
|
|
|
--
|
|
|
|
-- @$(mkAbsDir x) \<\/> $(mkRelDir y) = $(mkAbsDir (x ++ \"/\" ++ y))@
|
|
|
|
--
|
|
|
|
-- @$(mkAbsDir x) \<\/> $(mkRelFile y) = $(mkAbsFile (x ++ \"/\" ++ y))@
|
|
|
|
--
|
|
|
|
-- @$(mkRelDir x) \<\/> $(mkRelDir y) = $(mkRelDir (x ++ \"/\" ++ y))@
|
|
|
|
--
|
|
|
|
-- @$(mkRelDir x) \<\/> $(mkRelFile y) = $(mkRelFile (x ++ \"/\" ++ y))@
|
|
|
|
--
|
|
|
|
-- The following are proven not possible to express:
|
|
|
|
--
|
|
|
|
-- @$(mkAbsFile …) \<\/> x@
|
|
|
|
--
|
|
|
|
-- @$(mkRelFile …) \<\/> x@
|
|
|
|
--
|
|
|
|
-- @x \<\/> $(mkAbsFile …)@
|
|
|
|
--
|
|
|
|
-- @x \<\/> $(mkAbsDir …)@
|
|
|
|
--
|
|
|
|
(</>) :: Path b Dir -> Path Rel t -> Path b t
|
|
|
|
(</>) (Path a) (Path b) = Path (a ++ b)
|
|
|
|
|
|
|
|
-- | Strip directory from path, making it relative to that directory.
|
|
|
|
-- Returns 'Nothing' if directory is not a parent of the path.
|
|
|
|
--
|
|
|
|
-- The following properties hold:
|
|
|
|
--
|
2015-10-08 09:58:17 +00:00
|
|
|
-- @stripDir x (x \<\/> y) = y@
|
2015-05-08 11:33:37 +00:00
|
|
|
--
|
|
|
|
-- Cases which are proven not possible:
|
|
|
|
--
|
|
|
|
-- @stripDir (a :: Path Abs …) (b :: Path Rel …)@
|
|
|
|
--
|
2015-05-14 15:44:41 +00:00
|
|
|
-- @stripDir (a :: Path Rel …) (b :: Path Abs …)@
|
2015-05-08 11:33:37 +00:00
|
|
|
--
|
|
|
|
-- In other words the bases must match.
|
|
|
|
--
|
2015-05-22 09:32:57 +00:00
|
|
|
-- Throws: 'Couldn'tStripPrefixDir'
|
|
|
|
--
|
|
|
|
stripDir :: MonadThrow m
|
|
|
|
=> Path b Dir -> Path b t -> m (Path Rel t)
|
2015-05-08 11:33:37 +00:00
|
|
|
stripDir (Path p) (Path l) =
|
2015-05-27 15:08:03 +00:00
|
|
|
case stripPrefix p l of
|
2015-05-22 09:32:57 +00:00
|
|
|
Nothing -> throwM (Couldn'tStripPrefixDir p l)
|
2015-05-27 15:08:03 +00:00
|
|
|
Just "" -> throwM (Couldn'tStripPrefixDir p l)
|
|
|
|
Just ok -> return (Path ok)
|
2015-05-08 11:33:37 +00:00
|
|
|
|
|
|
|
-- | Is p a parent of the given location? Implemented in terms of
|
|
|
|
-- 'stripDir'. The bases must match.
|
|
|
|
isParentOf :: Path b Dir -> Path b t -> Bool
|
|
|
|
isParentOf p l =
|
|
|
|
isJust (stripDir p l)
|
|
|
|
|
|
|
|
-- | Take the absolute parent directory from the absolute path.
|
|
|
|
--
|
|
|
|
-- The following properties hold:
|
|
|
|
--
|
2015-10-08 09:58:17 +00:00
|
|
|
-- @parent (x \<\/> y) == x@
|
2015-05-08 11:33:37 +00:00
|
|
|
--
|
|
|
|
-- On the root, getting the parent is idempotent:
|
|
|
|
--
|
2015-05-11 16:29:15 +00:00
|
|
|
-- @parent (parent \"\/\") = \"\/\"@
|
2015-05-08 11:33:37 +00:00
|
|
|
--
|
2015-05-11 16:29:15 +00:00
|
|
|
parent :: Path Abs t -> Path Abs Dir
|
|
|
|
parent (Path fp) =
|
2015-05-08 11:33:37 +00:00
|
|
|
Path (normalizeDir (FilePath.takeDirectory (FilePath.dropTrailingPathSeparator fp)))
|
|
|
|
|
2015-05-11 16:29:15 +00:00
|
|
|
-- | Extract the file part of a path.
|
2015-05-08 11:33:37 +00:00
|
|
|
--
|
|
|
|
-- The following properties hold:
|
|
|
|
--
|
2015-10-08 09:58:17 +00:00
|
|
|
-- @filename (p \<\/> a) == filename a@
|
2015-05-08 11:33:37 +00:00
|
|
|
--
|
|
|
|
filename :: Path b File -> Path Rel File
|
2015-05-11 16:59:26 +00:00
|
|
|
filename (Path l) =
|
|
|
|
Path (normalizeFile (FilePath.takeFileName l))
|
|
|
|
|
|
|
|
-- | Extract the last directory name of a path.
|
|
|
|
--
|
|
|
|
-- The following properties hold:
|
|
|
|
--
|
2015-10-08 09:58:17 +00:00
|
|
|
-- @dirname (p \<\/> a) == dirname a@
|
2015-05-11 16:59:26 +00:00
|
|
|
--
|
|
|
|
dirname :: Path b Dir -> Path Rel Dir
|
|
|
|
dirname (Path l) =
|
|
|
|
Path (last (FilePath.splitPath l))
|
2015-05-08 11:33:37 +00:00
|
|
|
|
2015-05-08 10:21:12 +00:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- Internal functions
|
|
|
|
|
|
|
|
-- | Internal use for normalizing a directory.
|
|
|
|
normalizeDir :: FilePath -> FilePath
|
|
|
|
normalizeDir =
|
|
|
|
clean . FilePath.addTrailingPathSeparator . FilePath.normalise
|
|
|
|
where clean "./" = ""
|
|
|
|
clean ('/':'/':xs) = clean ('/':xs)
|
|
|
|
clean x = x
|
|
|
|
|
|
|
|
-- | Internal use for normalizing a fileectory.
|
|
|
|
normalizeFile :: FilePath -> FilePath
|
|
|
|
normalizeFile =
|
|
|
|
clean . FilePath.normalise
|
|
|
|
where clean "./" = ""
|
|
|
|
clean ('/':'/':xs) = clean ('/':xs)
|
|
|
|
clean x = x
|