{-# LANGUAGE DeriveLift #-}
module StrongPath.Internal
( Path (..),
RelPathPrefix (..),
Abs,
Rel,
Dir,
File,
Posix,
Windows,
System,
Path',
File',
Dir',
Rel',
parseRelFileFP,
parseRelDirFP,
impossible,
prefixNumParentDirs,
relPathNumParentDirs,
relPathPrefix,
extractRelPathPrefix,
)
where
import Control.Monad.Catch (MonadThrow, throwM)
import Language.Haskell.TH.Syntax (Lift)
import qualified Path as P
import qualified Path.Posix as PP
import qualified Path.Windows as PW
data Path s b t
=
RelDir (P.Path P.Rel P.Dir) RelPathPrefix
| RelFile (P.Path P.Rel P.File) RelPathPrefix
| AbsDir (P.Path P.Abs P.Dir)
| AbsFile (P.Path P.Abs P.File)
|
RelDirW (PW.Path PW.Rel PW.Dir) RelPathPrefix
| RelFileW (PW.Path PW.Rel PW.File) RelPathPrefix
| AbsDirW (PW.Path PW.Abs PW.Dir)
| AbsFileW (PW.Path PW.Abs PW.File)
|
RelDirP (PP.Path PP.Rel PP.Dir) RelPathPrefix
| RelFileP (PP.Path PP.Rel PP.File) RelPathPrefix
| AbsDirP (PP.Path PP.Abs PP.Dir)
| AbsFileP (PP.Path PP.Abs PP.File)
deriving (Int -> Path s b t -> ShowS
[Path s b t] -> ShowS
Path s b t -> [Char]
(Int -> Path s b t -> ShowS)
-> (Path s b t -> [Char])
-> ([Path s b t] -> ShowS)
-> Show (Path s b t)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall s b t. Int -> Path s b t -> ShowS
forall s b t. [Path s b t] -> ShowS
forall s b t. Path s b t -> [Char]
showList :: [Path s b t] -> ShowS
$cshowList :: forall s b t. [Path s b t] -> ShowS
show :: Path s b t -> [Char]
$cshow :: forall s b t. Path s b t -> [Char]
showsPrec :: Int -> Path s b t -> ShowS
$cshowsPrec :: forall s b t. Int -> Path s b t -> ShowS
Show, Path s b t -> Path s b t -> Bool
(Path s b t -> Path s b t -> Bool)
-> (Path s b t -> Path s b t -> Bool) -> Eq (Path s b t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s b t. Path s b t -> Path s b t -> Bool
/= :: Path s b t -> Path s b t -> Bool
$c/= :: forall s b t. Path s b t -> Path s b t -> Bool
== :: Path s b t -> Path s b t -> Bool
$c== :: forall s b t. Path s b t -> Path s b t -> Bool
Eq, (forall (m :: * -> *). Quote m => Path s b t -> m Exp)
-> (forall (m :: * -> *).
Quote m =>
Path s b t -> Code m (Path s b t))
-> Lift (Path s b t)
forall s b t (m :: * -> *). Quote m => Path s b t -> m Exp
forall s b t (m :: * -> *).
Quote m =>
Path s b t -> Code m (Path s b t)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Path s b t -> m Exp
forall (m :: * -> *). Quote m => Path s b t -> Code m (Path s b t)
liftTyped :: forall (m :: * -> *). Quote m => Path s b t -> Code m (Path s b t)
$cliftTyped :: forall s b t (m :: * -> *).
Quote m =>
Path s b t -> Code m (Path s b t)
lift :: forall (m :: * -> *). Quote m => Path s b t -> m Exp
$clift :: forall s b t (m :: * -> *). Quote m => Path s b t -> m Exp
Lift)
data RelPathPrefix
=
ParentDir Int
| NoPrefix
deriving (Int -> RelPathPrefix -> ShowS
[RelPathPrefix] -> ShowS
RelPathPrefix -> [Char]
(Int -> RelPathPrefix -> ShowS)
-> (RelPathPrefix -> [Char])
-> ([RelPathPrefix] -> ShowS)
-> Show RelPathPrefix
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RelPathPrefix] -> ShowS
$cshowList :: [RelPathPrefix] -> ShowS
show :: RelPathPrefix -> [Char]
$cshow :: RelPathPrefix -> [Char]
showsPrec :: Int -> RelPathPrefix -> ShowS
$cshowsPrec :: Int -> RelPathPrefix -> ShowS
Show, RelPathPrefix -> RelPathPrefix -> Bool
(RelPathPrefix -> RelPathPrefix -> Bool)
-> (RelPathPrefix -> RelPathPrefix -> Bool) -> Eq RelPathPrefix
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelPathPrefix -> RelPathPrefix -> Bool
$c/= :: RelPathPrefix -> RelPathPrefix -> Bool
== :: RelPathPrefix -> RelPathPrefix -> Bool
$c== :: RelPathPrefix -> RelPathPrefix -> Bool
Eq, (forall (m :: * -> *). Quote m => RelPathPrefix -> m Exp)
-> (forall (m :: * -> *).
Quote m =>
RelPathPrefix -> Code m RelPathPrefix)
-> Lift RelPathPrefix
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => RelPathPrefix -> m Exp
forall (m :: * -> *).
Quote m =>
RelPathPrefix -> Code m RelPathPrefix
liftTyped :: forall (m :: * -> *).
Quote m =>
RelPathPrefix -> Code m RelPathPrefix
$cliftTyped :: forall (m :: * -> *).
Quote m =>
RelPathPrefix -> Code m RelPathPrefix
lift :: forall (m :: * -> *). Quote m => RelPathPrefix -> m Exp
$clift :: forall (m :: * -> *). Quote m => RelPathPrefix -> m Exp
Lift)
data Abs deriving ((forall (m :: * -> *). Quote m => Abs -> m Exp)
-> (forall (m :: * -> *). Quote m => Abs -> Code m Abs) -> Lift Abs
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Abs -> m Exp
forall (m :: * -> *). Quote m => Abs -> Code m Abs
liftTyped :: forall (m :: * -> *). Quote m => Abs -> Code m Abs
$cliftTyped :: forall (m :: * -> *). Quote m => Abs -> Code m Abs
lift :: forall (m :: * -> *). Quote m => Abs -> m Exp
$clift :: forall (m :: * -> *). Quote m => Abs -> m Exp
Lift)
data Rel dir deriving ((forall (m :: * -> *). Quote m => Rel dir -> m Exp)
-> (forall (m :: * -> *). Quote m => Rel dir -> Code m (Rel dir))
-> Lift (Rel dir)
forall dir (m :: * -> *). Quote m => Rel dir -> m Exp
forall dir (m :: * -> *). Quote m => Rel dir -> Code m (Rel dir)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Rel dir -> m Exp
forall (m :: * -> *). Quote m => Rel dir -> Code m (Rel dir)
liftTyped :: forall (m :: * -> *). Quote m => Rel dir -> Code m (Rel dir)
$cliftTyped :: forall dir (m :: * -> *). Quote m => Rel dir -> Code m (Rel dir)
lift :: forall (m :: * -> *). Quote m => Rel dir -> m Exp
$clift :: forall dir (m :: * -> *). Quote m => Rel dir -> m Exp
Lift)
data Dir dir deriving ((forall (m :: * -> *). Quote m => Dir dir -> m Exp)
-> (forall (m :: * -> *). Quote m => Dir dir -> Code m (Dir dir))
-> Lift (Dir dir)
forall dir (m :: * -> *). Quote m => Dir dir -> m Exp
forall dir (m :: * -> *). Quote m => Dir dir -> Code m (Dir dir)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Dir dir -> m Exp
forall (m :: * -> *). Quote m => Dir dir -> Code m (Dir dir)
liftTyped :: forall (m :: * -> *). Quote m => Dir dir -> Code m (Dir dir)
$cliftTyped :: forall dir (m :: * -> *). Quote m => Dir dir -> Code m (Dir dir)
lift :: forall (m :: * -> *). Quote m => Dir dir -> m Exp
$clift :: forall dir (m :: * -> *). Quote m => Dir dir -> m Exp
Lift)
data File file deriving ((forall (m :: * -> *). Quote m => File file -> m Exp)
-> (forall (m :: * -> *).
Quote m =>
File file -> Code m (File file))
-> Lift (File file)
forall file (m :: * -> *). Quote m => File file -> m Exp
forall file (m :: * -> *).
Quote m =>
File file -> Code m (File file)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => File file -> m Exp
forall (m :: * -> *). Quote m => File file -> Code m (File file)
liftTyped :: forall (m :: * -> *). Quote m => File file -> Code m (File file)
$cliftTyped :: forall file (m :: * -> *).
Quote m =>
File file -> Code m (File file)
lift :: forall (m :: * -> *). Quote m => File file -> m Exp
$clift :: forall file (m :: * -> *). Quote m => File file -> m Exp
Lift)
data Posix deriving ((forall (m :: * -> *). Quote m => Posix -> m Exp)
-> (forall (m :: * -> *). Quote m => Posix -> Code m Posix)
-> Lift Posix
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Posix -> m Exp
forall (m :: * -> *). Quote m => Posix -> Code m Posix
liftTyped :: forall (m :: * -> *). Quote m => Posix -> Code m Posix
$cliftTyped :: forall (m :: * -> *). Quote m => Posix -> Code m Posix
lift :: forall (m :: * -> *). Quote m => Posix -> m Exp
$clift :: forall (m :: * -> *). Quote m => Posix -> m Exp
Lift)
data Windows deriving ((forall (m :: * -> *). Quote m => Windows -> m Exp)
-> (forall (m :: * -> *). Quote m => Windows -> Code m Windows)
-> Lift Windows
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Windows -> m Exp
forall (m :: * -> *). Quote m => Windows -> Code m Windows
liftTyped :: forall (m :: * -> *). Quote m => Windows -> Code m Windows
$cliftTyped :: forall (m :: * -> *). Quote m => Windows -> Code m Windows
lift :: forall (m :: * -> *). Quote m => Windows -> m Exp
$clift :: forall (m :: * -> *). Quote m => Windows -> m Exp
Lift)
data System deriving ((forall (m :: * -> *). Quote m => System -> m Exp)
-> (forall (m :: * -> *). Quote m => System -> Code m System)
-> Lift System
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => System -> m Exp
forall (m :: * -> *). Quote m => System -> Code m System
liftTyped :: forall (m :: * -> *). Quote m => System -> Code m System
$cliftTyped :: forall (m :: * -> *). Quote m => System -> Code m System
lift :: forall (m :: * -> *). Quote m => System -> m Exp
$clift :: forall (m :: * -> *). Quote m => System -> m Exp
Lift)
type Path' = Path System
type Rel' = Rel ()
type Dir' = Dir ()
type File' = File ()
parseRelFileFP ::
MonadThrow m =>
(p -> RelPathPrefix -> Path s (Rel d) (File f)) ->
[Char] ->
(FilePath -> m p) ->
FilePath ->
m (Path s (Rel d) (File f))
parseRelFileFP :: forall (m :: * -> *) p s d f.
MonadThrow m =>
(p -> RelPathPrefix -> Path s (Rel d) (File f))
-> [Char]
-> ([Char] -> m p)
-> [Char]
-> m (Path s (Rel d) (File f))
parseRelFileFP p -> RelPathPrefix -> Path s (Rel d) (File f)
_ [Char]
_ [Char] -> m p
_ [Char]
"" = PathException -> m (Path s (Rel d) (File f))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([Char] -> PathException
P.InvalidRelFile [Char]
"")
parseRelFileFP p -> RelPathPrefix -> Path s (Rel d) (File f)
constructor [Char]
validSeparators [Char] -> m p
pathParser [Char]
fp = (p -> RelPathPrefix -> Path s (Rel d) (File f))
-> [Char]
-> ([Char] -> m p)
-> [Char]
-> m (Path s (Rel d) (File f))
forall (m :: * -> *) p s d1 t.
MonadThrow m =>
(p -> RelPathPrefix -> Path s (Rel d1) t)
-> [Char] -> ([Char] -> m p) -> [Char] -> m (Path s (Rel d1) t)
parseRelFP p -> RelPathPrefix -> Path s (Rel d) (File f)
constructor [Char]
validSeparators [Char] -> m p
pathParser [Char]
fp
parseRelDirFP ::
MonadThrow m =>
(p -> RelPathPrefix -> Path s (Rel d1) (Dir d2)) ->
[Char] ->
(FilePath -> m p) ->
FilePath ->
m (Path s (Rel d1) (Dir d2))
parseRelDirFP :: forall (m :: * -> *) p s d1 d2.
MonadThrow m =>
(p -> RelPathPrefix -> Path s (Rel d1) (Dir d2))
-> [Char]
-> ([Char] -> m p)
-> [Char]
-> m (Path s (Rel d1) (Dir d2))
parseRelDirFP p -> RelPathPrefix -> Path s (Rel d1) (Dir d2)
_ [Char]
_ [Char] -> m p
_ [Char]
"" = PathException -> m (Path s (Rel d1) (Dir d2))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([Char] -> PathException
P.InvalidRelDir [Char]
"")
parseRelDirFP p -> RelPathPrefix -> Path s (Rel d1) (Dir d2)
constructor [Char]
validSeparators [Char] -> m p
pathParser [Char]
fp = (p -> RelPathPrefix -> Path s (Rel d1) (Dir d2))
-> [Char]
-> ([Char] -> m p)
-> [Char]
-> m (Path s (Rel d1) (Dir d2))
forall (m :: * -> *) p s d1 t.
MonadThrow m =>
(p -> RelPathPrefix -> Path s (Rel d1) t)
-> [Char] -> ([Char] -> m p) -> [Char] -> m (Path s (Rel d1) t)
parseRelFP p -> RelPathPrefix -> Path s (Rel d1) (Dir d2)
constructor [Char]
validSeparators [Char] -> m p
pathParser [Char]
fp
parseRelFP ::
MonadThrow m =>
(p -> RelPathPrefix -> Path s (Rel d1) t) ->
[Char] ->
(FilePath -> m p) ->
FilePath ->
m (Path s (Rel d1) t)
parseRelFP :: forall (m :: * -> *) p s d1 t.
MonadThrow m =>
(p -> RelPathPrefix -> Path s (Rel d1) t)
-> [Char] -> ([Char] -> m p) -> [Char] -> m (Path s (Rel d1) t)
parseRelFP p -> RelPathPrefix -> Path s (Rel d1) t
_ [Char]
_ [Char] -> m p
_ [Char]
"" = [Char] -> m (Path s (Rel d1) t)
forall a. HasCallStack => [Char] -> a
error [Char]
"can't parse empty path"
parseRelFP p -> RelPathPrefix -> Path s (Rel d1) t
constructor [Char]
validSeparators [Char] -> m p
pathParser [Char]
fp = do
let (RelPathPrefix
prefix, [Char]
fp') = [Char] -> [Char] -> (RelPathPrefix, [Char])
extractRelPathPrefix [Char]
validSeparators [Char]
fp
fp'' :: [Char]
fp'' = if [Char]
fp' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"" then [Char]
"." else [Char]
fp'
(\p
p -> p -> RelPathPrefix -> Path s (Rel d1) t
constructor p
p RelPathPrefix
prefix) (p -> Path s (Rel d1) t) -> m p -> m (Path s (Rel d1) t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> m p
pathParser [Char]
fp''
extractRelPathPrefix :: [Char] -> FilePath -> (RelPathPrefix, FilePath)
[Char]
validSeparators [Char]
path =
let (Int
n, [Char]
path') = [Char] -> (Int, [Char])
dropParentDirs [Char]
path
in (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then RelPathPrefix
NoPrefix else Int -> RelPathPrefix
ParentDir Int
n, [Char]
path')
where
parentDirStrings :: [String]
parentDirStrings :: [[Char]]
parentDirStrings = [[Char
'.', Char
'.', Char
s] | Char
s <- [Char]
validSeparators]
pathStartsWithParentDir :: FilePath -> Bool
pathStartsWithParentDir :: [Char] -> Bool
pathStartsWithParentDir [Char]
p = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 [Char]
p [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
parentDirStrings
dropParentDirs :: FilePath -> (Int, FilePath)
dropParentDirs :: [Char] -> (Int, [Char])
dropParentDirs [Char]
p
| [Char] -> Bool
pathStartsWithParentDir [Char]
p =
let (Int
n, [Char]
p') = [Char] -> (Int, [Char])
dropParentDirs (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
3 [Char]
p)
in (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n, [Char]
p')
| [Char]
p [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".." = (Int
1, [Char]
"")
| Bool
otherwise = (Int
0, [Char]
p)
prefixNumParentDirs :: RelPathPrefix -> Int
prefixNumParentDirs :: RelPathPrefix -> Int
prefixNumParentDirs RelPathPrefix
NoPrefix = Int
0
prefixNumParentDirs (ParentDir Int
n) = Int
n
relPathNumParentDirs :: Path s (Rel r) t -> Int
relPathNumParentDirs :: forall s r t. Path s (Rel r) t -> Int
relPathNumParentDirs = RelPathPrefix -> Int
prefixNumParentDirs (RelPathPrefix -> Int)
-> (Path s (Rel r) t -> RelPathPrefix) -> Path s (Rel r) t -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path s (Rel r) t -> RelPathPrefix
forall s r t. Path s (Rel r) t -> RelPathPrefix
relPathPrefix
relPathPrefix :: Path s (Rel r) t -> RelPathPrefix
relPathPrefix :: forall s r t. Path s (Rel r) t -> RelPathPrefix
relPathPrefix Path s (Rel r) t
sp = case Path s (Rel r) t
sp of
RelDir Path Rel Dir
_ RelPathPrefix
pr -> RelPathPrefix
pr
RelFile Path Rel File
_ RelPathPrefix
pr -> RelPathPrefix
pr
RelDirW Path Rel Dir
_ RelPathPrefix
pr -> RelPathPrefix
pr
RelFileW Path Rel File
_ RelPathPrefix
pr -> RelPathPrefix
pr
RelDirP Path Rel Dir
_ RelPathPrefix
pr -> RelPathPrefix
pr
RelFileP Path Rel File
_ RelPathPrefix
pr -> RelPathPrefix
pr
Path s (Rel r) t
_ -> RelPathPrefix
forall a. a
impossible
impossible :: a
impossible :: forall a. a
impossible = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"This should be impossible."