{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE PatternSynonyms #-}
#endif
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
module HPath
(
Path
,Abs
,Rel
,PathParseException
,PathException
#if __GLASGOW_HASKELL__ >= 708
,pattern Path
#endif
,parseAbs
,parseRel
,parseAny
,rootPath
,pwdPath
,fromAbs
,fromRel
,toFilePath
,fromAny
,(</>)
,basename
,basename'
,dirname
,getAllParents
,getAllComponents
,getAllComponentsAfterRoot
,stripDir
,isParentOf
,isRootPath
,isPwdPath
,withAbsPath
,withRelPath
,abs
,rel
)
where
import Control.Exception (Exception)
import Control.Monad.Catch (MonadThrow(..))
#if MIN_VERSION_bytestring(0,10,8)
import Data.ByteString(ByteString, stripPrefix)
#else
import Data.ByteString(ByteString)
import qualified Data.List as L
#endif
import qualified Data.ByteString as BS
import Data.ByteString.UTF8
import Data.Data
import Data.Maybe
import Data.Word8
import HPath.Internal
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift(..), lift)
import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Prelude hiding (abs, any)
import System.Posix.FilePath hiding ((</>))
data Abs deriving (Typeable)
data Rel deriving (Typeable)
data PathParseException
= InvalidAbs ByteString
| InvalidRel ByteString
| Couldn'tStripPrefixTPS ByteString ByteString
deriving (Int -> PathParseException -> ShowS
[PathParseException] -> ShowS
PathParseException -> String
(Int -> PathParseException -> ShowS)
-> (PathParseException -> String)
-> ([PathParseException] -> ShowS)
-> Show PathParseException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathParseException] -> ShowS
$cshowList :: [PathParseException] -> ShowS
show :: PathParseException -> String
$cshow :: PathParseException -> String
showsPrec :: Int -> PathParseException -> ShowS
$cshowsPrec :: Int -> PathParseException -> ShowS
Show,Typeable)
instance Exception PathParseException
data PathException = RootDirHasNoBasename
deriving (Int -> PathException -> ShowS
[PathException] -> ShowS
PathException -> String
(Int -> PathException -> ShowS)
-> (PathException -> String)
-> ([PathException] -> ShowS)
-> Show PathException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathException] -> ShowS
$cshowList :: [PathException] -> ShowS
show :: PathException -> String
$cshow :: PathException -> String
showsPrec :: Int -> PathException -> ShowS
$cshowsPrec :: Int -> PathException -> ShowS
Show,Typeable)
instance Exception PathException
#if __GLASGOW_HASKELL__ >= 710
pattern Path :: ByteString -> Path a
#endif
#if __GLASGOW_HASKELL__ >= 708
pattern $mPath :: forall r a. Path a -> (ByteString -> r) -> (Void# -> r) -> r
Path x <- (MkPath x)
#endif
parseAbs :: MonadThrow m
=> ByteString -> m (Path Abs)
parseAbs :: ByteString -> m (Path Abs)
parseAbs ByteString
filepath =
if ByteString -> Bool
isAbsolute ByteString
filepath Bool -> Bool -> Bool
&&
ByteString -> Bool
isValid ByteString
filepath Bool -> Bool -> Bool
&&
Bool -> Bool
not (ByteString -> Bool
hasParentDir ByteString
filepath)
then Path Abs -> m (Path Abs)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Path Abs
forall b. ByteString -> Path b
MkPath (ByteString -> Path Abs)
-> (ByteString -> ByteString) -> ByteString -> Path Abs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
dropTrailingPathSeparator (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
normalise (ByteString -> Path Abs) -> ByteString -> Path Abs
forall a b. (a -> b) -> a -> b
$ ByteString
filepath)
else PathParseException -> m (Path Abs)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ByteString -> PathParseException
InvalidAbs ByteString
filepath)
parseRel :: MonadThrow m
=> ByteString -> m (Path Rel)
parseRel :: ByteString -> m (Path Rel)
parseRel ByteString
filepath =
if Bool -> Bool
not (ByteString -> Bool
isAbsolute ByteString
filepath) Bool -> Bool -> Bool
&&
ByteString
filepath ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= [Word8] -> ByteString
BS.pack [Word8
_period, Word8
_period] Bool -> Bool -> Bool
&&
Bool -> Bool
not (ByteString -> Bool
hasParentDir ByteString
filepath) Bool -> Bool -> Bool
&&
ByteString -> Bool
isValid ByteString
filepath
then Path Rel -> m (Path Rel)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Path Rel
forall b. ByteString -> Path b
MkPath (ByteString -> Path Rel)
-> (ByteString -> ByteString) -> ByteString -> Path Rel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
dropTrailingPathSeparator (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
normalise (ByteString -> Path Rel) -> ByteString -> Path Rel
forall a b. (a -> b) -> a -> b
$ ByteString
filepath)
else PathParseException -> m (Path Rel)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ByteString -> PathParseException
InvalidRel ByteString
filepath)
parseAny :: MonadThrow m => ByteString -> m (Either (Path Abs) (Path Rel))
parseAny :: ByteString -> m (Either (Path Abs) (Path Rel))
parseAny ByteString
filepath = case ByteString -> Maybe (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs ByteString
filepath of
Just Path Abs
p -> Either (Path Abs) (Path Rel) -> m (Either (Path Abs) (Path Rel))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Path Abs) (Path Rel) -> m (Either (Path Abs) (Path Rel)))
-> Either (Path Abs) (Path Rel) -> m (Either (Path Abs) (Path Rel))
forall a b. (a -> b) -> a -> b
$ Path Abs -> Either (Path Abs) (Path Rel)
forall a b. a -> Either a b
Left Path Abs
p
Maybe (Path Abs)
Nothing -> case ByteString -> Maybe (Path Rel)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Rel)
parseRel ByteString
filepath of
Just Path Rel
p -> Either (Path Abs) (Path Rel) -> m (Either (Path Abs) (Path Rel))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Path Abs) (Path Rel) -> m (Either (Path Abs) (Path Rel)))
-> Either (Path Abs) (Path Rel) -> m (Either (Path Abs) (Path Rel))
forall a b. (a -> b) -> a -> b
$ Path Rel -> Either (Path Abs) (Path Rel)
forall a b. b -> Either a b
Right Path Rel
p
Maybe (Path Rel)
Nothing -> PathParseException -> m (Either (Path Abs) (Path Rel))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ByteString -> PathParseException
InvalidRel ByteString
filepath)
rootPath :: Path Abs
rootPath :: Path Abs
rootPath = (ByteString -> Path Abs
forall b. ByteString -> Path b
MkPath (Word8 -> ByteString
BS.singleton Word8
_slash))
pwdPath :: Path Rel
pwdPath :: Path Rel
pwdPath = (ByteString -> Path Rel
forall b. ByteString -> Path b
MkPath (Word8 -> ByteString
BS.singleton Word8
_period))
toFilePath :: Path b -> ByteString
toFilePath :: Path b -> ByteString
toFilePath (MkPath ByteString
l) = ByteString
l
fromAbs :: Path Abs -> ByteString
fromAbs :: Path Abs -> ByteString
fromAbs = Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath
fromRel :: Path Rel -> ByteString
fromRel :: Path Rel -> ByteString
fromRel = Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath
fromAny :: Either (Path Abs) (Path Rel) -> ByteString
fromAny :: Either (Path Abs) (Path Rel) -> ByteString
fromAny = (Path Abs -> ByteString)
-> (Path Rel -> ByteString)
-> Either (Path Abs) (Path Rel)
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath
(</>) :: Path b -> Path Rel -> Path b
</> :: Path b -> Path Rel -> Path b
(</>) (MkPath ByteString
a) (MkPath ByteString
b) =
ByteString -> Path b
forall b. ByteString -> Path b
MkPath (ByteString -> ByteString
dropTrailingPathSeparator (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
normalise (ByteString -> ByteString
addTrailingPathSeparator ByteString
a ByteString -> ByteString -> ByteString
`BS.append` ByteString
b))
stripDir :: MonadThrow m => Path b -> Path b -> m (Path Rel)
stripDir :: Path b -> Path b -> m (Path Rel)
stripDir (MkPath ByteString
p) (MkPath ByteString
l)
| ByteString
p ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
l = Path Rel -> m (Path Rel)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Rel
pwdPath
| Bool
otherwise = case ByteString -> ByteString -> Maybe ByteString
stripPrefix (ByteString -> ByteString
addTrailingPathSeparator ByteString
p) ByteString
l of
Maybe ByteString
Nothing -> PathParseException -> m (Path Rel)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ByteString -> ByteString -> PathParseException
Couldn'tStripPrefixTPS ByteString
p ByteString
l)
Just ByteString
ok -> Path Rel -> m (Path Rel)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Path Rel
forall b. ByteString -> Path b
MkPath ByteString
ok)
getAllParents :: Path Abs -> [Path Abs]
getAllParents :: Path Abs -> [Path Abs]
getAllParents (MkPath ByteString
p)
| ByteString
np ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Word8 -> ByteString
BS.singleton Word8
pathSeparator = []
| Bool
otherwise = Path Abs -> Path Abs
dirname (ByteString -> Path Abs
forall b. ByteString -> Path b
MkPath ByteString
np) Path Abs -> [Path Abs] -> [Path Abs]
forall a. a -> [a] -> [a]
: Path Abs -> [Path Abs]
getAllParents (Path Abs -> Path Abs
dirname (Path Abs -> Path Abs) -> Path Abs -> Path Abs
forall a b. (a -> b) -> a -> b
$ ByteString -> Path Abs
forall b. ByteString -> Path b
MkPath ByteString
np)
where
np :: ByteString
np = ByteString -> ByteString
normalise ByteString
p
getAllComponents :: Path Rel -> [Path Rel]
getAllComponents :: Path Rel -> [Path Rel]
getAllComponents (MkPath ByteString
p) = (ByteString -> Path Rel) -> [ByteString] -> [Path Rel]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Path Rel
forall b. ByteString -> Path b
MkPath ([ByteString] -> [Path Rel])
-> (ByteString -> [ByteString]) -> ByteString -> [Path Rel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
splitDirectories (ByteString -> [Path Rel]) -> ByteString -> [Path Rel]
forall a b. (a -> b) -> a -> b
$ ByteString
p
getAllComponentsAfterRoot :: Path Abs -> [Path Rel]
getAllComponentsAfterRoot :: Path Abs -> [Path Rel]
getAllComponentsAfterRoot Path Abs
p = Path Rel -> [Path Rel]
getAllComponents (Maybe (Path Rel) -> Path Rel
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Path Rel) -> Path Rel) -> Maybe (Path Rel) -> Path Rel
forall a b. (a -> b) -> a -> b
$ Path Abs -> Path Abs -> Maybe (Path Rel)
forall (m :: * -> *) b.
MonadThrow m =>
Path b -> Path b -> m (Path Rel)
stripDir Path Abs
rootPath Path Abs
p)
dirname :: Path Abs -> Path Abs
dirname :: Path Abs -> Path Abs
dirname (MkPath ByteString
fp) = ByteString -> Path Abs
forall b. ByteString -> Path b
MkPath (ByteString -> ByteString
takeDirectory ByteString
fp)
basename :: MonadThrow m => Path b -> m (Path Rel)
basename :: Path b -> m (Path Rel)
basename (MkPath ByteString
l)
| Bool -> Bool
not (ByteString -> Bool
isAbsolute ByteString
rl) = Path Rel -> m (Path Rel)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Rel -> m (Path Rel)) -> Path Rel -> m (Path Rel)
forall a b. (a -> b) -> a -> b
$ ByteString -> Path Rel
forall b. ByteString -> Path b
MkPath ByteString
rl
| Bool
otherwise = PathException -> m (Path Rel)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM PathException
RootDirHasNoBasename
where
rl :: ByteString
rl = [ByteString] -> ByteString
forall a. [a] -> a
last ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
splitPath (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
l
basename' :: Path Rel -> Path Rel
basename' :: Path Rel -> Path Rel
basename' (MkPath ByteString
l) = ByteString -> Path Rel
forall b. ByteString -> Path b
MkPath (ByteString -> Path Rel)
-> (ByteString -> ByteString) -> ByteString -> Path Rel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
forall a. [a] -> a
last ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
splitPath (ByteString -> Path Rel) -> ByteString -> Path Rel
forall a b. (a -> b) -> a -> b
$ ByteString
l
isParentOf :: Path b -> Path b -> Bool
isParentOf :: Path b -> Path b -> Bool
isParentOf Path b
p Path b
l = case Path b -> Path b -> Maybe (Path Rel)
forall (m :: * -> *) b.
MonadThrow m =>
Path b -> Path b -> m (Path Rel)
stripDir Path b
p Path b
l :: Maybe (Path Rel) of
Maybe (Path Rel)
Nothing -> Bool
False
Just Path Rel
ok
| Path Rel -> Bool
isPwdPath Path Rel
ok -> Bool
False
| Bool
otherwise -> Bool
True
isRootPath :: Path Abs -> Bool
isRootPath :: Path Abs -> Bool
isRootPath = (Path Abs -> Path Abs -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs
rootPath)
isPwdPath :: Path Rel -> Bool
isPwdPath :: Path Rel -> Bool
isPwdPath = (Path Rel -> Path Rel -> Bool
forall a. Eq a => a -> a -> Bool
== Path Rel
pwdPath)
withAbsPath :: Path Abs -> (ByteString -> IO a) -> IO a
withAbsPath :: Path Abs -> (ByteString -> IO a) -> IO a
withAbsPath (MkPath ByteString
p) ByteString -> IO a
action = ByteString -> IO a
action ByteString
p
withRelPath :: Path Rel -> (ByteString -> IO a) -> IO a
withRelPath :: Path Rel -> (ByteString -> IO a) -> IO a
withRelPath (MkPath ByteString
p) ByteString -> IO a
action = ByteString -> IO a
action ByteString
p
#if MIN_VERSION_bytestring(0,10,8)
#else
stripPrefix :: ByteString -> ByteString -> Maybe ByteString
stripPrefix a b = BS.pack `fmap` L.stripPrefix (BS.unpack a) (BS.unpack b)
#endif
instance Typeable a => Lift (Path a) where
lift :: Path a -> Q Exp
lift (MkPath ByteString
bs) = [| MkPath (BS.pack $(lift $ BS.unpack bs)) :: Path $(pure a) |]
where
a :: Type
a = Name -> Type
TH.ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ OccName -> NameFlavour -> Name
TH.Name OccName
occ NameFlavour
flav
where
tc :: TyCon
tc = TypeRep -> TyCon
typeRepTyCon (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))
occ :: OccName
occ = String -> OccName
TH.OccName (TyCon -> String
tyConName TyCon
tc)
flav :: NameFlavour
flav = NameSpace -> PkgName -> ModName -> NameFlavour
TH.NameG NameSpace
TH.TcClsName (String -> PkgName
TH.PkgName (TyCon -> String
tyConPackage TyCon
tc)) (String -> ModName
TH.ModName (TyCon -> String
tyConModule TyCon
tc))
qq :: (ByteString -> Q Exp) -> QuasiQuoter
qq :: (ByteString -> Q Exp) -> QuasiQuoter
qq ByteString -> Q Exp
quoteExp' =
QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = (\String
s -> ByteString -> Q Exp
quoteExp' (ByteString -> Q Exp) -> (String -> ByteString) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
fromString (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
s)
, quotePat :: String -> Q Pat
quotePat = \String
_ ->
String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"illegal QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType :: String -> Q Type
quoteType = \String
_ ->
String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"illegal QuasiQuote (allowed as expression only, used as a type)"
, quoteDec :: String -> Q [Dec]
quoteDec = \String
_ ->
String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"illegal QuasiQuote (allowed as expression only, used as a declaration)"
}
mkAbs :: ByteString -> Q Exp
mkAbs :: ByteString -> Q Exp
mkAbs = (SomeException -> Q Exp)
-> (Path Abs -> Q Exp) -> Either SomeException (Path Abs) -> Q Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp)
-> (SomeException -> String) -> SomeException -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) Path Abs -> Q Exp
forall t. Lift t => t -> Q Exp
lift (Either SomeException (Path Abs) -> Q Exp)
-> (ByteString -> Either SomeException (Path Abs))
-> ByteString
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either SomeException (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs
mkRel :: ByteString -> Q Exp
mkRel :: ByteString -> Q Exp
mkRel = (SomeException -> Q Exp)
-> (Path Rel -> Q Exp) -> Either SomeException (Path Rel) -> Q Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp)
-> (SomeException -> String) -> SomeException -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) Path Rel -> Q Exp
forall t. Lift t => t -> Q Exp
lift (Either SomeException (Path Rel) -> Q Exp)
-> (ByteString -> Either SomeException (Path Rel))
-> ByteString
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either SomeException (Path Rel)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Rel)
parseRel
abs :: QuasiQuoter
abs :: QuasiQuoter
abs = (ByteString -> Q Exp) -> QuasiQuoter
qq ByteString -> Q Exp
mkAbs
rel :: QuasiQuoter
rel :: QuasiQuoter
rel = (ByteString -> Q Exp) -> QuasiQuoter
qq ByteString -> Q Exp
mkRel