{-# LANGUAGE DeriveLift #-}

module StrongPath.Internal where

import Control.Monad.Catch (MonadThrow)
import Language.Haskell.TH.Syntax (Lift)
import qualified Path as P
import qualified Path.Posix as PP
import qualified Path.Windows as PW

-- | Strongly typed file path. Central type of the "StrongPath".
--
--   [@s@]: __Standard__: Posix or windows. Can be fixed ('Posix', 'Windows') or determined by the system ('System').
--
--   [@b@]: __Base__: Absolute ('Abs') or relative ('Rel').
--
--   [@t@]: __Type__: File ('File') or directory ('Dir').
--
-- Some examples:
--
-- > Path System (Dir HomeDir) (File FooFile)
-- > Path System Abs (Dir HomeDir)
-- > Path Posix (Rel ProjectRoot) (File ())
data Path s b t
  = -- System
    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)
  | -- Windows
    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)
  | -- Posix
    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 -> String
(Int -> Path s b t -> ShowS)
-> (Path s b t -> String)
-> ([Path s b t] -> ShowS)
-> Show (Path s b t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([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 -> String
showList :: [Path s b t] -> ShowS
$cshowList :: forall s b t. [Path s b t] -> ShowS
show :: Path s b t -> String
$cshow :: forall s b t. Path s b t -> String
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, Path s b t -> Q Exp
Path s b t -> Q (TExp (Path s b t))
(Path s b t -> Q Exp)
-> (Path s b t -> Q (TExp (Path s b t))) -> Lift (Path s b t)
forall s b t. Path s b t -> Q Exp
forall s b t. Path s b t -> Q (TExp (Path s b t))
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Path s b t -> Q (TExp (Path s b t))
$cliftTyped :: forall s b t. Path s b t -> Q (TExp (Path s b t))
lift :: Path s b t -> Q Exp
$clift :: forall s b t. Path s b t -> Q Exp
Lift)

data RelPathPrefix
  = -- | ../, Int saying how many times it repeats.
    ParentDir Int
  | NoPrefix
  deriving (Int -> RelPathPrefix -> ShowS
[RelPathPrefix] -> ShowS
RelPathPrefix -> String
(Int -> RelPathPrefix -> ShowS)
-> (RelPathPrefix -> String)
-> ([RelPathPrefix] -> ShowS)
-> Show RelPathPrefix
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelPathPrefix] -> ShowS
$cshowList :: [RelPathPrefix] -> ShowS
show :: RelPathPrefix -> String
$cshow :: RelPathPrefix -> String
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, RelPathPrefix -> Q Exp
RelPathPrefix -> Q (TExp RelPathPrefix)
(RelPathPrefix -> Q Exp)
-> (RelPathPrefix -> Q (TExp RelPathPrefix)) -> Lift RelPathPrefix
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: RelPathPrefix -> Q (TExp RelPathPrefix)
$cliftTyped :: RelPathPrefix -> Q (TExp RelPathPrefix)
lift :: RelPathPrefix -> Q Exp
$clift :: RelPathPrefix -> Q Exp
Lift)

-- | Describes 'Path' base as absolute.
data Abs deriving (Abs -> Q Exp
Abs -> Q (TExp Abs)
(Abs -> Q Exp) -> (Abs -> Q (TExp Abs)) -> Lift Abs
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Abs -> Q (TExp Abs)
$cliftTyped :: Abs -> Q (TExp Abs)
lift :: Abs -> Q Exp
$clift :: Abs -> Q Exp
Lift)

-- | Describes 'Path' base as relative to the directory @dir@.
data Rel dir deriving (Rel dir -> Q Exp
Rel dir -> Q (TExp (Rel dir))
(Rel dir -> Q Exp)
-> (Rel dir -> Q (TExp (Rel dir))) -> Lift (Rel dir)
forall dir. Rel dir -> Q Exp
forall dir. Rel dir -> Q (TExp (Rel dir))
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Rel dir -> Q (TExp (Rel dir))
$cliftTyped :: forall dir. Rel dir -> Q (TExp (Rel dir))
lift :: Rel dir -> Q Exp
$clift :: forall dir. Rel dir -> Q Exp
Lift)

-- | Means that path points to a directory @dir@.
-- To use as a type in place of @dir@, we recommend creating an empty
-- data type representing the specific directory, e.g. @data ProjectRootDir@.
data Dir dir deriving (Dir dir -> Q Exp
Dir dir -> Q (TExp (Dir dir))
(Dir dir -> Q Exp)
-> (Dir dir -> Q (TExp (Dir dir))) -> Lift (Dir dir)
forall dir. Dir dir -> Q Exp
forall dir. Dir dir -> Q (TExp (Dir dir))
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Dir dir -> Q (TExp (Dir dir))
$cliftTyped :: forall dir. Dir dir -> Q (TExp (Dir dir))
lift :: Dir dir -> Q Exp
$clift :: forall dir. Dir dir -> Q Exp
Lift)

-- | Means that path points to a file @file@.
-- To use as a type in place of @file@, we recommend creating an empty
-- data type representing the specific file, e.g. @data ProjectManifestFile@.
data File file deriving (File file -> Q Exp
File file -> Q (TExp (File file))
(File file -> Q Exp)
-> (File file -> Q (TExp (File file))) -> Lift (File file)
forall file. File file -> Q Exp
forall file. File file -> Q (TExp (File file))
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: File file -> Q (TExp (File file))
$cliftTyped :: forall file. File file -> Q (TExp (File file))
lift :: File file -> Q Exp
$clift :: forall file. File file -> Q Exp
Lift)

-- | Describes 'Path' standard as posix (e.g. @\/path\/to\/foobar@).
-- This makes 'Path' behave in system-independent fashion: code behaves the same
-- regardless of the system it is running on.
-- You will normally want to use it when dealing with paths from some external source,
-- or with paths that have explicitely fixed standard.
-- For example, if you are running your Haskell program on Windows and parsing logs which
-- were obtained from the Linux server, or maybe you are parsing Javascript import statements,
-- you will want to use 'Posix'.
data Posix deriving (Posix -> Q Exp
Posix -> Q (TExp Posix)
(Posix -> Q Exp) -> (Posix -> Q (TExp Posix)) -> Lift Posix
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Posix -> Q (TExp Posix)
$cliftTyped :: Posix -> Q (TExp Posix)
lift :: Posix -> Q Exp
$clift :: Posix -> Q Exp
Lift)

-- | Describes 'Path' standard as windows (e.g. @C:\\path\\to\\foobar@).
-- Check 'Posix' for more details, everything is analogous.
data Windows deriving (Windows -> Q Exp
Windows -> Q (TExp Windows)
(Windows -> Q Exp) -> (Windows -> Q (TExp Windows)) -> Lift Windows
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Windows -> Q (TExp Windows)
$cliftTyped :: Windows -> Q (TExp Windows)
lift :: Windows -> Q Exp
$clift :: Windows -> Q Exp
Lift)

-- | Describes 'Path' standard to be determined by the system/OS.
--
-- If the system is Windows, it will resolve to 'Windows' internally, and if not,
-- it will resolve to 'Posix'.
--
-- However, keep in mind that even if running on Windows, @Path Windows b t@
-- and @Path System b t@ are still considered to be different types,
-- even though @Path System b t @ internally uses Windows standard.
--
-- You will normally want to use 'System' if you are dealing with the paths on the disk of the host OS
-- (where your code is running), for example if user is providing you with the path to the file on the disk
-- that you will be doing something with.
-- Keep in mind that 'System' causes the behaviour of 'Path' to be system/platform-dependant.
data System deriving (System -> Q Exp
System -> Q (TExp System)
(System -> Q Exp) -> (System -> Q (TExp System)) -> Lift System
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: System -> Q (TExp System)
$cliftTyped :: System -> Q (TExp System)
lift :: System -> Q Exp
$clift :: System -> Q Exp
Lift) -- Depends on the platform, it is either Posix or Windows.

-- | 'System' is the most commonly used standard, so we provide you with a type alias for it.
type Path' = Path System

-- | When you don't want your path to be relative to anything specific,
-- it is convenient to use unit @()@.
type Rel' = Rel ()

-- | When you don't want your directory path to be named,
-- it is convenient to use unit @()@.
type Dir' = Dir ()

-- | When you don't want your file path to be named,
-- it is convenient to use unit @()@.
type File' = File ()

-- TODO: Extract `parseRelFP` and `extractRelPathPrefix` into StrongPath.FilePath.Internals?
parseRelFP ::
  MonadThrow m =>
  (p -> RelPathPrefix -> Path s (Rel d) t) ->
  [Char] ->
  (FilePath -> m p) ->
  FilePath ->
  m (Path s (Rel d) t)
parseRelFP :: (p -> RelPathPrefix -> Path s (Rel d) t)
-> String -> (String -> m p) -> String -> m (Path s (Rel d) t)
parseRelFP p -> RelPathPrefix -> Path s (Rel d) t
constructor String
validSeparators String -> m p
pathParser String
fp =
  let (RelPathPrefix
prefix, String
fp') = String -> String -> (RelPathPrefix, String)
extractRelPathPrefix String
validSeparators String
fp
      fp'' :: String
fp'' = if String
fp' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then String
"." else String
fp' -- Because Path Rel parsers can't handle just "".
   in (\p
p -> p -> RelPathPrefix -> Path s (Rel d) t
constructor p
p RelPathPrefix
prefix) (p -> Path s (Rel d) t) -> m p -> m (Path s (Rel d) t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m p
pathParser String
fp''

-- | Extracts a multiple "../" from start of the file path.
--   If path is completely ../../.., also handles the last one.
--   NOTE: We don't normalize path in any way.
extractRelPathPrefix :: [Char] -> FilePath -> (RelPathPrefix, FilePath)
extractRelPathPrefix :: String -> String -> (RelPathPrefix, String)
extractRelPathPrefix String
validSeparators String
path =
  let (Int
n, String
path') = String -> (Int, String)
dropParentDirs String
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, String
path')
  where
    parentDirStrings :: [String]
    parentDirStrings :: [String]
parentDirStrings = [[Char
'.', Char
'.', Char
s] | Char
s <- String
validSeparators]

    pathStartsWithParentDir :: FilePath -> Bool
    pathStartsWithParentDir :: String -> Bool
pathStartsWithParentDir String
p = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
3 String
p String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
parentDirStrings

    dropParentDirs :: FilePath -> (Int, FilePath)
    dropParentDirs :: String -> (Int, String)
dropParentDirs String
p
      | String -> Bool
pathStartsWithParentDir String
p =
        let (Int
n, String
p') = String -> (Int, String)
dropParentDirs (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
3 String
p)
         in (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n, String
p')
      | String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".." = (Int
1, String
"")
      | Bool
otherwise = (Int
0, String
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 :: 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 :: 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 :: a
impossible = String -> a
forall a. HasCallStack => String -> a
error String
"This should be impossible."