Fork chrisdone's path library
I wasn't happy with the way it dealt with Dir vs File things. In his version of the library, a `Path b Dir` always ends with a trailing path separator and `Path b File` never ends with a trailing path separator. IMO, it is nonsensical to make a Dir vs File distinction on path level, although it first seems nice. Some of the reasons are: * a path is just that: a path. It is completely disconnected from IO level and even if a `Dir`/`File` type theoretically allows us to say "this path ought to point to a file", there is literally zero guarantee that it will hold true at runtime. So this basically gives a false feeling of a type-safe file distinction. * it's imprecise about Dir vs File distinction, which makes it even worse, because a directory is also a file (just not a regular file). Add symlinks to that and the confusion is complete. * it makes the API oddly complicated for use cases where we basically don't care (yet) whether something turns out to be a directory or not Still, it comes also with a few perks: * it simplifies some functions, because they now have guarantees whether a path ends in a trailing path separator or not * it may be safer for interaction with other library functions, which behave differently depending on a trailing path separator (like probably shelly) Not limited to, but also in order to fix my remarks without breaking any benefits, I did: * rename the `Dir`/`File` types to `TPS`/`NoTPS`, so it's clear we are only giving information about trailing path separators and not actual file types we don't know about yet * add a `MaybeTPS` type, which does not mess with trailing path separators and also gives no guarantees about them... then added `toNoTPS` and `toTPS` to allow type-safe conversion * make some functions accept more general types, so we don't unnecessarily force paths with trailing separators for `(</>)` for example... instead these functions now examine the paths to still have correct behavior. This is really minor overhead. You might say now "but then I can append filepath to filepath". Well, as I said... we don't know whether it's a "filepath" at all. * merge `filename` and `dirname` into `basename` and make `parent` be `dirname`, so the function names match the name of the POSIX ones, which do (almost) the same... * fix a bug in `basename` (formerly `dirname`) which broke the type guarantees * add a pattern synonym for easier pattern matching without exporting the internal Path constructor
This commit is contained in:
415
src/HPath.hs
Normal file
415
src/HPath.hs
Normal file
@@ -0,0 +1,415 @@
|
||||
-- |
|
||||
-- Module : HPath
|
||||
-- Copyright : © 2015–2016 FP Complete, 2016 Julian Ospald
|
||||
-- License : BSD 3 clause
|
||||
--
|
||||
-- Maintainer : Julian Ospald <hasufell@posteo.de>
|
||||
-- Stability : experimental
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Support for well-typed paths.
|
||||
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE EmptyDataDecls #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
module HPath
|
||||
(
|
||||
-- * Types
|
||||
Abs
|
||||
,NoTPS
|
||||
,Path
|
||||
,Rel
|
||||
,TPS
|
||||
-- * PatternSynonyms/ViewPatterns
|
||||
,pattern Path
|
||||
-- * Parsing
|
||||
,PathParseException
|
||||
,parseAbsMaybeTPS
|
||||
,parseAbsNoTPS
|
||||
,parseAbsTPS
|
||||
,parseRelMaybeTPS
|
||||
,parseRelNoTPS
|
||||
,parseRelTPS
|
||||
-- * Constructors
|
||||
,mkAbsMaybeTPS
|
||||
,mkAbsNoTPS
|
||||
,mkAbsTPS
|
||||
,mkRelMaybeTPS
|
||||
,mkRelNoTPS
|
||||
,mkRelTPS
|
||||
-- * Operations
|
||||
,(</>)
|
||||
,basename
|
||||
,dirname
|
||||
,isParentOf
|
||||
,stripDir
|
||||
-- * Conversion
|
||||
,fromAbsMaybeTPS
|
||||
,fromAbsNoTPS
|
||||
,fromAbsTPS
|
||||
,fromRelMaybeTPS
|
||||
,fromRelNoTPS
|
||||
,fromRelTPS
|
||||
,toFilePath
|
||||
,toNoTPS
|
||||
,toTPS
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception (Exception)
|
||||
import Control.Monad.Catch (MonadThrow(..))
|
||||
import Data.Data
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Language.Haskell.TH
|
||||
import HPath.Internal
|
||||
import qualified System.FilePath as FilePath
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Types
|
||||
|
||||
-- | An absolute path.
|
||||
data Abs deriving (Typeable)
|
||||
|
||||
-- | A relative path; one without a root.
|
||||
data Rel deriving (Typeable)
|
||||
|
||||
-- | A path without trailing separator.
|
||||
data NoTPS deriving (Typeable)
|
||||
|
||||
-- | A path with trailing separator.
|
||||
data TPS deriving (Typeable)
|
||||
|
||||
-- | A path without any guarantee about whether it ends in a
|
||||
-- trailing path separators. Use `toTPS` and `toNoTPS`
|
||||
-- if that guarantee is required.
|
||||
data MaybeTPS deriving (Typeable)
|
||||
|
||||
-- | Exception when parsing a location.
|
||||
data PathParseException
|
||||
= InvalidAbsTPS FilePath
|
||||
| InvalidRelTPS FilePath
|
||||
| InvalidAbsNoTPS FilePath
|
||||
| InvalidRelNoTPS FilePath
|
||||
| InvalidAbsMaybeTPS FilePath
|
||||
| InvalidRelMaybeTPS FilePath
|
||||
| Couldn'tStripPrefixTPS FilePath FilePath
|
||||
deriving (Show,Typeable)
|
||||
instance Exception PathParseException
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- PatternSynonyms
|
||||
|
||||
pattern Path x <- (MkPath x)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Parsers
|
||||
|
||||
-- | Get a location for an absolute path. Produces a normalized
|
||||
-- path which always ends in a path separator.
|
||||
--
|
||||
-- Throws: 'PathParseException'
|
||||
--
|
||||
parseAbsTPS :: MonadThrow m
|
||||
=> FilePath -> m (Path Abs TPS)
|
||||
parseAbsTPS filepath =
|
||||
if FilePath.isAbsolute filepath &&
|
||||
not (null (normalizeTPS filepath)) &&
|
||||
not ("~/" `isPrefixOf` filepath) &&
|
||||
not (hasParentDir filepath) &&
|
||||
FilePath.isValid filepath
|
||||
then return (MkPath (normalizeTPS filepath))
|
||||
else throwM (InvalidAbsTPS filepath)
|
||||
|
||||
-- | Get a location for a relative path. Produces a normalized
|
||||
-- path which always ends in a path separator.
|
||||
--
|
||||
-- Note that @filepath@ may contain any number of @./@ but may not consist
|
||||
-- solely of @./@. It also may not contain a single @..@ anywhere.
|
||||
--
|
||||
-- Throws: 'PathParseException'
|
||||
--
|
||||
parseRelTPS :: MonadThrow m
|
||||
=> FilePath -> m (Path Rel TPS)
|
||||
parseRelTPS filepath =
|
||||
if not (FilePath.isAbsolute filepath) &&
|
||||
not (null filepath) &&
|
||||
not ("~/" `isPrefixOf` filepath) &&
|
||||
not (hasParentDir filepath) &&
|
||||
not (null (normalizeTPS filepath)) &&
|
||||
filepath /= "." && filepath /= ".." &&
|
||||
FilePath.isValid filepath
|
||||
then return (MkPath (normalizeTPS filepath))
|
||||
else throwM (InvalidRelTPS filepath)
|
||||
|
||||
-- | Get a location for an absolute path, which must not end with a trailing
|
||||
-- path separator.
|
||||
--
|
||||
-- Throws: 'PathParseException'
|
||||
--
|
||||
parseAbsNoTPS :: MonadThrow m
|
||||
=> FilePath -> m (Path Abs NoTPS)
|
||||
parseAbsNoTPS filepath =
|
||||
if FilePath.isAbsolute filepath &&
|
||||
not (FilePath.hasTrailingPathSeparator filepath) &&
|
||||
not ("~/" `isPrefixOf` filepath) &&
|
||||
not (hasParentDir filepath) &&
|
||||
not (null (normalizeNoTPS filepath)) &&
|
||||
FilePath.isValid filepath
|
||||
then return (MkPath (normalizeNoTPS filepath))
|
||||
else throwM (InvalidAbsNoTPS filepath)
|
||||
|
||||
-- | Get a location for a relative path, which must not end with a trailing
|
||||
-- path separator.
|
||||
--
|
||||
-- Note that @filepath@ may contain any number of @./@ but may not contain a
|
||||
-- single @..@ anywhere.
|
||||
--
|
||||
-- Throws: 'PathParseException'
|
||||
--
|
||||
parseRelNoTPS :: MonadThrow m
|
||||
=> FilePath -> m (Path Rel NoTPS)
|
||||
parseRelNoTPS filepath =
|
||||
if not (FilePath.isAbsolute filepath ||
|
||||
FilePath.hasTrailingPathSeparator filepath) &&
|
||||
not (null filepath) &&
|
||||
not ("~/" `isPrefixOf` filepath) &&
|
||||
not (hasParentDir filepath) &&
|
||||
not (null (normalizeNoTPS filepath)) &&
|
||||
filepath /= "." && filepath /= ".." &&
|
||||
FilePath.isValid filepath
|
||||
then return (MkPath (normalizeNoTPS filepath))
|
||||
else throwM (InvalidRelNoTPS filepath)
|
||||
|
||||
-- | Get a location for an absolute path that may or may not end in a trailing
|
||||
-- path separator. Use `toTPS` and `toNoTPS` if that guarantee is required.
|
||||
--
|
||||
-- Throws: 'PathParseException'
|
||||
--
|
||||
parseAbsMaybeTPS :: MonadThrow m
|
||||
=> FilePath -> m (Path Abs MaybeTPS)
|
||||
parseAbsMaybeTPS filepath =
|
||||
if FilePath.isAbsolute filepath &&
|
||||
not ("~/" `isPrefixOf` filepath) &&
|
||||
not (hasParentDir filepath) &&
|
||||
not (null (normalizeNoTPS filepath)) &&
|
||||
FilePath.isValid filepath
|
||||
then return (MkPath (normalizeNoTPS filepath))
|
||||
else throwM (InvalidAbsMaybeTPS filepath)
|
||||
|
||||
-- | Get a location for a relative path that may or may not end in a trailing
|
||||
-- path separator. Use `toTPS` and `toNoTPS` if that guarantee is required.
|
||||
--
|
||||
-- Note that @filepath@ may contain any number of @./@ but may not contain a
|
||||
-- single @..@ anywhere.
|
||||
--
|
||||
-- Throws: 'PathParseException'
|
||||
--
|
||||
parseRelMaybeTPS :: MonadThrow m
|
||||
=> FilePath -> m (Path Rel MaybeTPS)
|
||||
parseRelMaybeTPS filepath =
|
||||
if not (FilePath.isAbsolute filepath) &&
|
||||
not (null filepath) &&
|
||||
not ("~/" `isPrefixOf` filepath) &&
|
||||
not (hasParentDir filepath) &&
|
||||
not (null (normalizeNoTPS filepath)) &&
|
||||
filepath /= "." && filepath /= ".." &&
|
||||
FilePath.isValid filepath
|
||||
then return (MkPath (normalizeNoTPS filepath))
|
||||
else throwM (InvalidRelMaybeTPS filepath)
|
||||
|
||||
-- | 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' =
|
||||
("/.." `isSuffixOf` filepath) ||
|
||||
("/../" `isInfixOf` filepath) ||
|
||||
("../" `isPrefixOf` filepath)
|
||||
where
|
||||
filepath =
|
||||
case FilePath.pathSeparator of
|
||||
'/' -> filepath'
|
||||
x -> map (\y -> if x == y then '/' else y) filepath'
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Constructors
|
||||
|
||||
-- | Make a 'Path Abs TPS'.
|
||||
--
|
||||
-- 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).
|
||||
mkAbsTPS :: FilePath -> Q Exp
|
||||
mkAbsTPS s =
|
||||
case parseAbsTPS s of
|
||||
Left err -> error (show err)
|
||||
Right (MkPath str) ->
|
||||
[|MkPath $(return (LitE (StringL str))) :: Path Abs TPS|]
|
||||
|
||||
-- | Make a 'Path Rel TPS'.
|
||||
mkRelTPS :: FilePath -> Q Exp
|
||||
mkRelTPS s =
|
||||
case parseRelTPS s of
|
||||
Left err -> error (show err)
|
||||
Right (MkPath str) ->
|
||||
[|MkPath $(return (LitE (StringL str))) :: Path Rel TPS|]
|
||||
|
||||
-- | Make a 'Path Abs NoTPS'.
|
||||
--
|
||||
-- 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).
|
||||
mkAbsNoTPS :: FilePath -> Q Exp
|
||||
mkAbsNoTPS s =
|
||||
case parseAbsNoTPS s of
|
||||
Left err -> error (show err)
|
||||
Right (MkPath str) ->
|
||||
[|MkPath $(return (LitE (StringL str))) :: Path Abs NoTPS|]
|
||||
|
||||
-- | Make a 'Path Rel NoTPS'.
|
||||
mkRelNoTPS :: FilePath -> Q Exp
|
||||
mkRelNoTPS s =
|
||||
case parseRelNoTPS s of
|
||||
Left err -> error (show err)
|
||||
Right (MkPath str) ->
|
||||
[|MkPath $(return (LitE (StringL str))) :: Path Rel NoTPS|]
|
||||
|
||||
-- | Make a 'Path Rel MaybeTPS'.
|
||||
mkAbsMaybeTPS :: FilePath -> Q Exp
|
||||
mkAbsMaybeTPS s =
|
||||
case parseAbsMaybeTPS s of
|
||||
Left err -> error (show err)
|
||||
Right (MkPath str) ->
|
||||
[|MkPath $(return (LitE (StringL str))) :: Path Abs MaybeTPS|]
|
||||
|
||||
-- | Make a 'Path Rel MaybeTPS'.
|
||||
mkRelMaybeTPS :: FilePath -> Q Exp
|
||||
mkRelMaybeTPS s =
|
||||
case parseRelMaybeTPS s of
|
||||
Left err -> error (show err)
|
||||
Right (MkPath str) ->
|
||||
[|MkPath $(return (LitE (StringL str))) :: Path Rel MaybeTPS|]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Conversion
|
||||
|
||||
-- | Convert to a 'FilePath' type.
|
||||
--
|
||||
-- All TPS data types have a trailing slash, so if you want no trailing
|
||||
-- slash, you can use 'System.FilePath.dropTrailingPathSeparator' from
|
||||
-- the filepath package.
|
||||
toFilePath :: Path b t -> FilePath
|
||||
toFilePath (MkPath l) = l
|
||||
|
||||
fromAbsTPS :: Path Abs TPS -> FilePath
|
||||
fromAbsTPS = toFilePath
|
||||
|
||||
fromRelTPS :: Path Rel TPS -> FilePath
|
||||
fromRelTPS = toFilePath
|
||||
|
||||
fromAbsNoTPS :: Path Abs NoTPS -> FilePath
|
||||
fromAbsNoTPS = toFilePath
|
||||
|
||||
fromRelNoTPS :: Path Rel NoTPS -> FilePath
|
||||
fromRelNoTPS = toFilePath
|
||||
|
||||
fromAbsMaybeTPS :: Path Abs MaybeTPS -> FilePath
|
||||
fromAbsMaybeTPS = toFilePath
|
||||
|
||||
fromRelMaybeTPS :: Path Rel MaybeTPS -> FilePath
|
||||
fromRelMaybeTPS = toFilePath
|
||||
|
||||
toTPS :: Path b MaybeTPS -> Path b TPS
|
||||
toTPS (MkPath l) = MkPath (FilePath.addTrailingPathSeparator l)
|
||||
|
||||
toNoTPS :: Path b MaybeTPS -> Path b NoTPS
|
||||
toNoTPS (MkPath l) = MkPath (FilePath.dropTrailingPathSeparator l)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Operations
|
||||
|
||||
-- | Append two paths.
|
||||
--
|
||||
-- The second argument must always be a relative path, which ensures
|
||||
-- that undefinable things like `"/abc" </> "/def"` cannot happen.
|
||||
--
|
||||
-- Technically, the first argument can be a path that points to a non-directory,
|
||||
-- because this library is IO-agnostic and makes no assumptions about
|
||||
-- file types.
|
||||
(</>) :: Path b t1 -> Path Rel t2 -> Path b t2
|
||||
(</>) (MkPath a) (MkPath b) = MkPath (a' ++ b)
|
||||
where
|
||||
a' = FilePath.addTrailingPathSeparator a
|
||||
|
||||
-- | Strip directory from path, making it relative to that directory.
|
||||
-- Throws 'Couldn'tStripPrefixDir' if directory is not a parent of the path.
|
||||
--
|
||||
-- The bases must match.
|
||||
--
|
||||
stripDir :: MonadThrow m
|
||||
=> Path b t1 -> Path b t2 -> m (Path Rel t2)
|
||||
stripDir (MkPath p) (MkPath l) =
|
||||
case stripPrefix p' l of
|
||||
Nothing -> throwM (Couldn'tStripPrefixTPS p' l)
|
||||
Just "" -> throwM (Couldn'tStripPrefixTPS p' l)
|
||||
Just ok -> return (MkPath ok)
|
||||
where
|
||||
p' = FilePath.addTrailingPathSeparator p
|
||||
|
||||
-- | Is p a parent of the given location? Implemented in terms of
|
||||
-- 'stripDir'. The bases must match.
|
||||
isParentOf :: Path b t1 -> Path b t2 -> Bool
|
||||
isParentOf p l =
|
||||
isJust (stripDir p l)
|
||||
|
||||
-- | Extract the directory name of a path.
|
||||
--
|
||||
-- The following properties hold:
|
||||
--
|
||||
-- @dirname (p \<\/> a) == dirname p@
|
||||
--
|
||||
dirname :: Path Abs t -> Path Abs TPS
|
||||
dirname (MkPath fp) = MkPath (normalizeTPS (FilePath.takeDirectory $ FilePath.dropTrailingPathSeparator fp))
|
||||
|
||||
-- | Extract the file part of a path.
|
||||
--
|
||||
-- Throws InvalidRelTPS if it's passed e.g. '/', because there is no
|
||||
-- basename for that and it would break the `Path Rel t` type.
|
||||
--
|
||||
-- The following properties hold:
|
||||
--
|
||||
-- @basename (p \<\/> a) == basename a@
|
||||
--
|
||||
basename :: MonadThrow m => Path b t -> m (Path Rel t)
|
||||
basename (MkPath l)
|
||||
| not (FilePath.isAbsolute rl) = return $ MkPath rl
|
||||
| otherwise = throwM (InvalidRelTPS rl)
|
||||
where
|
||||
rl = case FilePath.hasTrailingPathSeparator l of
|
||||
True -> last (FilePath.splitPath l)
|
||||
False -> normalizeNoTPS (FilePath.takeFileName l)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Internal functions
|
||||
|
||||
-- | Internal use for normalizing a path while always adding
|
||||
-- a trailing path separator.
|
||||
normalizeTPS :: FilePath -> FilePath
|
||||
normalizeTPS =
|
||||
clean . FilePath.addTrailingPathSeparator . FilePath.normalise
|
||||
where clean "./" = ""
|
||||
clean ('/':'/':xs) = clean ('/':xs)
|
||||
clean x = x
|
||||
|
||||
-- | Internal use for normalizing a path without adding or removing
|
||||
-- a trailing path separator.
|
||||
normalizeNoTPS :: FilePath -> FilePath
|
||||
normalizeNoTPS =
|
||||
clean . FilePath.normalise
|
||||
where clean "./" = ""
|
||||
clean ('/':'/':xs) = clean ('/':xs)
|
||||
clean x = x
|
||||
|
||||
@@ -2,7 +2,7 @@
|
||||
|
||||
-- | Internal types and functions.
|
||||
|
||||
module Path.Internal
|
||||
module HPath.Internal
|
||||
(Path(..))
|
||||
where
|
||||
|
||||
@@ -13,12 +13,12 @@ import Data.Data
|
||||
--
|
||||
-- Internally is a string. The string can be of two formats only:
|
||||
--
|
||||
-- 1. File format: @file.txt@, @foo\/bar.txt@, @\/foo\/bar.txt@
|
||||
-- 2. Directory format: @foo\/@, @\/foo\/bar\/@
|
||||
-- 1. without trailing path separator: @file.txt@, @foo\/bar.txt@, @\/foo\/bar.txt@
|
||||
-- 2. with trailing path separator: @foo\/@, @\/foo\/bar\/@
|
||||
--
|
||||
-- All directories end in a trailing separator. There are no duplicate
|
||||
-- There are no duplicate
|
||||
-- path separators @\/\/@, no @..@, no @.\/@, no @~\/@, etc.
|
||||
newtype Path b t = Path FilePath
|
||||
data Path b t = MkPath FilePath
|
||||
deriving (Typeable)
|
||||
|
||||
-- | String equality.
|
||||
@@ -27,7 +27,7 @@ newtype Path b t = Path FilePath
|
||||
--
|
||||
-- @show x == show y ≡ x == y@
|
||||
instance Eq (Path b t) where
|
||||
(==) (Path x) (Path y) = x == y
|
||||
(==) (MkPath x) (MkPath y) = x == y
|
||||
|
||||
-- | String ordering.
|
||||
--
|
||||
@@ -35,7 +35,7 @@ instance Eq (Path b t) where
|
||||
--
|
||||
-- @show x \`compare\` show y ≡ x \`compare\` y@
|
||||
instance Ord (Path b t) where
|
||||
compare (Path x) (Path y) = compare x y
|
||||
compare (MkPath x) (MkPath y) = compare x y
|
||||
|
||||
-- | Same as 'Path.toFilePath'.
|
||||
--
|
||||
@@ -43,7 +43,8 @@ instance Ord (Path b t) where
|
||||
--
|
||||
-- @x == y ≡ show x == show y@
|
||||
instance Show (Path b t) where
|
||||
show (Path x) = show x
|
||||
show (MkPath x) = show x
|
||||
|
||||
instance NFData (Path b t) where
|
||||
rnf (Path x) = rnf x
|
||||
rnf (MkPath x) = rnf x
|
||||
|
||||
350
src/Path.hs
350
src/Path.hs
@@ -1,350 +0,0 @@
|
||||
-- |
|
||||
-- Module : Path
|
||||
-- Copyright : © 2015–2016 FP Complete
|
||||
-- License : BSD 3 clause
|
||||
--
|
||||
-- Maintainer : Chris Done <chrisdone@fpcomplete.com>
|
||||
-- Stability : experimental
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Support for well-typed paths.
|
||||
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE EmptyDataDecls #-}
|
||||
|
||||
module Path
|
||||
(-- * Types
|
||||
Path
|
||||
,Abs
|
||||
,Rel
|
||||
,File
|
||||
,Dir
|
||||
-- * Parsing
|
||||
,parseAbsDir
|
||||
,parseRelDir
|
||||
,parseAbsFile
|
||||
,parseRelFile
|
||||
,PathParseException
|
||||
-- * Constructors
|
||||
,mkAbsDir
|
||||
,mkRelDir
|
||||
,mkAbsFile
|
||||
,mkRelFile
|
||||
-- * Operations
|
||||
,(</>)
|
||||
,stripDir
|
||||
,isParentOf
|
||||
,parent
|
||||
,filename
|
||||
,dirname
|
||||
-- * Conversion
|
||||
,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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Types
|
||||
|
||||
-- | An absolute path.
|
||||
data Abs deriving (Typeable)
|
||||
|
||||
-- | A relative path; one without a root.
|
||||
data Rel deriving (Typeable)
|
||||
|
||||
-- | A file path.
|
||||
data File deriving (Typeable)
|
||||
|
||||
-- | A directory path.
|
||||
data Dir deriving (Typeable)
|
||||
|
||||
-- | Exception when parsing a location.
|
||||
data PathParseException
|
||||
= InvalidAbsDir FilePath
|
||||
| InvalidRelDir FilePath
|
||||
| InvalidAbsFile FilePath
|
||||
| InvalidRelFile FilePath
|
||||
| Couldn'tStripPrefixDir FilePath FilePath
|
||||
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)) &&
|
||||
not ("~/" `isPrefixOf` filepath) &&
|
||||
not (hasParentDir filepath) &&
|
||||
FilePath.isValid filepath
|
||||
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.
|
||||
--
|
||||
-- Note that @filepath@ may contain any number of @./@ but may not consist solely of @./@. It also may not contain a single @..@ anywhere.
|
||||
--
|
||||
-- Throws: 'PathParseException'
|
||||
--
|
||||
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 /= "." && filepath /= ".." &&
|
||||
FilePath.isValid filepath
|
||||
then return (Path (normalizeDir filepath))
|
||||
else throwM (InvalidRelDir filepath)
|
||||
|
||||
-- | Get a location for an absolute file.
|
||||
--
|
||||
-- Throws: 'PathParseException'
|
||||
--
|
||||
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.isValid filepath
|
||||
then return (Path (normalizeFile filepath))
|
||||
else throwM (InvalidAbsFile filepath)
|
||||
|
||||
-- | Get a location for a relative file.
|
||||
--
|
||||
-- Note that @filepath@ may contain any number of @./@ but may not contain a single @..@ anywhere.
|
||||
--
|
||||
-- Throws: 'PathParseException'
|
||||
--
|
||||
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 /= "." && filepath /= ".." &&
|
||||
FilePath.isValid filepath
|
||||
then return (Path (normalizeFile filepath))
|
||||
else throwM (InvalidRelFile filepath)
|
||||
|
||||
-- | 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' =
|
||||
("/.." `isSuffixOf` filepath) ||
|
||||
("/../" `isInfixOf` filepath) ||
|
||||
("../" `isPrefixOf` filepath)
|
||||
where
|
||||
filepath =
|
||||
case FilePath.pathSeparator of
|
||||
'/' -> filepath'
|
||||
x -> map (\y -> if x == y then '/' else y) filepath'
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- 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.
|
||||
--
|
||||
-- All directories have a trailing slash, so if you want no trailing
|
||||
-- slash, you can use 'System.FilePath.dropTrailingPathSeparator' from
|
||||
-- the filepath package.
|
||||
toFilePath :: Path b t -> FilePath
|
||||
toFilePath (Path l) = l
|
||||
|
||||
-- | 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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- 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.
|
||||
-- Throws 'Couldn'tStripPrefixDir' if directory is not a parent of the path.
|
||||
--
|
||||
-- The following properties hold:
|
||||
--
|
||||
-- @stripDir x (x \<\/> y) = y@
|
||||
--
|
||||
-- Cases which are proven not possible:
|
||||
--
|
||||
-- @stripDir (a :: Path Abs …) (b :: Path Rel …)@
|
||||
--
|
||||
-- @stripDir (a :: Path Rel …) (b :: Path Abs …)@
|
||||
--
|
||||
-- In other words the bases must match.
|
||||
--
|
||||
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)
|
||||
|
||||
-- | 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:
|
||||
--
|
||||
-- @parent (x \<\/> y) == x@
|
||||
--
|
||||
-- On the root, getting the parent is idempotent:
|
||||
--
|
||||
-- @parent (parent \"\/\") = \"\/\"@
|
||||
--
|
||||
parent :: Path Abs t -> Path Abs Dir
|
||||
parent (Path fp) =
|
||||
Path (normalizeDir (FilePath.takeDirectory (FilePath.dropTrailingPathSeparator fp)))
|
||||
|
||||
-- | Extract the file part of a path.
|
||||
--
|
||||
-- The following properties hold:
|
||||
--
|
||||
-- @filename (p \<\/> a) == filename a@
|
||||
--
|
||||
filename :: Path b File -> Path Rel File
|
||||
filename (Path l) =
|
||||
Path (normalizeFile (FilePath.takeFileName l))
|
||||
|
||||
-- | Extract the last directory name of a path.
|
||||
--
|
||||
-- The following properties hold:
|
||||
--
|
||||
-- @dirname (p \<\/> a) == dirname a@
|
||||
--
|
||||
dirname :: Path b Dir -> Path Rel Dir
|
||||
dirname (Path l) =
|
||||
Path (last (FilePath.splitPath l))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- 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
|
||||
Reference in New Issue
Block a user