{-# LANGUAGE TemplateHaskell #-}
-- For constraints on "append"
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

#if defined(IS_WINDOWS)
#define OS_NAME Windows
#define OS_PATH WindowsPath
#else
#define OS_NAME Posix
#define OS_PATH PosixPath
#endif

-- |
-- Module      : Streamly.Internal.FileSystem.OS_PATH.Seg
-- Copyright   : (c) 2023 Composewell Technologies
-- License     : BSD3
-- Maintainer  : streamly@composewell.com
-- Portability : GHC
--
-- This module provides a type safe path append operation by distinguishing
-- paths between rooted paths and branches. Rooted paths are represented by the
-- @Rooted OS_PATH@ type and branches are represented by the @Unrooted OS_PATH@
-- type. Rooted paths are paths that are attached to specific roots in the file
-- system. Rooted paths could be absolute or relative e.g. @\/usr\/bin@,
-- @.\/local\/bin@, or @.@. Unrootedes are a paths that are not attached to a
-- specific root e.g. @usr\/bin@, @local\/bin@, or @../bin@ are branches.
--
-- This distinction provides a safe path append operation which cannot fail.
-- These types do not allow appending a rooted path to any other path. Only
-- branches can be appended.
--
module Streamly.Internal.FileSystem.OS_PATH.Seg
    (
    -- * Types
      Rooted (..)
    , Unrooted (..)
    , IsSeg

    -- * Statically Verified Path Literals
    -- | Quasiquoters.
    , rt
    , ur

    -- * Statically Verified Path Strings
    -- | Template Haskell expression splices.
    , rtE
    , urE

    -- * Operations
    , join
    )
where

import Control.Monad ((>=>))
import Control.Monad.Catch (MonadThrow(..))
import Language.Haskell.TH (Q, Exp)
import Language.Haskell.TH.Syntax (lift)
import Language.Haskell.TH.Quote (QuasiQuoter)
import Streamly.Internal.Data.Path (IsPath(..), PathException(..))
import Streamly.Internal.FileSystem.Path.Common (mkQ)
import Streamly.Internal.FileSystem.OS_PATH (OS_PATH(..))

import qualified Streamly.Internal.FileSystem.OS_PATH as OsPath

{- $setup
>>> :m
>>> :set -XQuasiQuotes

For APIs that have not been released yet.

>>> import Streamly.Internal.FileSystem.PosixPath (PosixPath)
>>> import Streamly.Internal.FileSystem.PosixPath.Seg (Rooted, Unrooted, rt, ur)
>>> import qualified Streamly.Internal.FileSystem.PosixPath as Path
>>> import qualified Streamly.Internal.FileSystem.PosixPath.Seg as Seg
-}

newtype Rooted a = Rooted a
newtype Unrooted a = Unrooted a

instance IsPath OS_PATH (Rooted OS_PATH) where
    unsafeFromPath :: PosixPath -> Rooted PosixPath
unsafeFromPath = PosixPath -> Rooted PosixPath
forall a. a -> Rooted a
Rooted
    fromPath :: forall (m :: * -> *).
MonadThrow m =>
PosixPath -> m (Rooted PosixPath)
fromPath PosixPath
p =
        if PosixPath -> Bool
OsPath.isRooted PosixPath
p
        then Rooted PosixPath -> m (Rooted PosixPath)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PosixPath -> Rooted PosixPath
forall a. a -> Rooted a
Rooted PosixPath
p)
        -- XXX Add more detailed error msg with all valid examples.
        else PathException -> m (Rooted PosixPath)
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (PathException -> m (Rooted PosixPath))
-> PathException -> m (Rooted PosixPath)
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath
                ([Char] -> PathException) -> [Char] -> PathException
forall a b. (a -> b) -> a -> b
$ [Char]
"Must be a specific location, not a path segment: "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PosixPath -> [Char]
OsPath.toString PosixPath
p
    toPath :: Rooted PosixPath -> PosixPath
toPath (Rooted PosixPath
p) = PosixPath
p

instance IsPath OS_PATH (Unrooted OS_PATH) where
    unsafeFromPath :: PosixPath -> Unrooted PosixPath
unsafeFromPath = PosixPath -> Unrooted PosixPath
forall a. a -> Unrooted a
Unrooted
    fromPath :: forall (m :: * -> *).
MonadThrow m =>
PosixPath -> m (Unrooted PosixPath)
fromPath PosixPath
p =
        if PosixPath -> Bool
OsPath.isUnrooted PosixPath
p
        then Unrooted PosixPath -> m (Unrooted PosixPath)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PosixPath -> Unrooted PosixPath
forall a. a -> Unrooted a
Unrooted PosixPath
p)
        -- XXX Add more detailed error msg with all valid examples.
        else PathException -> m (Unrooted PosixPath)
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (PathException -> m (Unrooted PosixPath))
-> PathException -> m (Unrooted PosixPath)
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath
                ([Char] -> PathException) -> [Char] -> PathException
forall a b. (a -> b) -> a -> b
$ [Char]
"Must be a path segment, not a specific location: "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PosixPath -> [Char]
OsPath.toString PosixPath
p
    toPath :: Unrooted PosixPath -> PosixPath
toPath (Unrooted PosixPath
p) = PosixPath
p

-- | Constraint to check if a type has Rooted or Unrooted annotations.
class IsSeg a

instance IsSeg (Rooted a)
instance IsSeg (Unrooted a)

------------------------------------------------------------------------------
-- Statically Verified Strings
------------------------------------------------------------------------------

liftRooted :: Rooted OS_PATH -> Q Exp
liftRooted :: Rooted PosixPath -> Q Exp
liftRooted (Rooted PosixPath
p) =
    [| unsafeFromPath (OsPath.unsafeFromString $([Char] -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => [Char] -> m Exp
lift ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ PosixPath -> [Char]
OsPath.toString (PosixPath -> [Char]) -> PosixPath -> [Char]
forall a b. (a -> b) -> a -> b
$ PosixPath -> PosixPath
forall a b. IsPath a b => b -> a
toPath PosixPath
p)) :: Rooted OS_PATH |]

liftUnrooted :: Unrooted OS_PATH -> Q Exp
liftUnrooted :: Unrooted PosixPath -> Q Exp
liftUnrooted (Unrooted PosixPath
p) =
    [| unsafeFromPath (OsPath.unsafeFromString $([Char] -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => [Char] -> m Exp
lift ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ PosixPath -> [Char]
OsPath.toString (PosixPath -> [Char]) -> PosixPath -> [Char]
forall a b. (a -> b) -> a -> b
$ PosixPath -> PosixPath
forall a b. IsPath a b => b -> a
toPath PosixPath
p)) :: Unrooted OS_PATH |]

-- | Generates a Haskell expression of type @Rooted OS_PATH@.
--
rtE :: String -> Q Exp
rtE :: [Char] -> Q Exp
rtE = (SomeException -> Q Exp)
-> (Rooted PosixPath -> Q Exp)
-> Either SomeException (Rooted PosixPath)
-> Q Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Q Exp
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q Exp)
-> (SomeException -> [Char]) -> SomeException -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> [Char]
forall a. Show a => a -> [Char]
show) Rooted PosixPath -> Q Exp
liftRooted (Either SomeException (Rooted PosixPath) -> Q Exp)
-> ([Char] -> Either SomeException (Rooted PosixPath))
-> [Char]
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Either SomeException PosixPath
forall (m :: * -> *). MonadThrow m => [Char] -> m PosixPath
OsPath.fromString ([Char] -> Either SomeException PosixPath)
-> (PosixPath -> Either SomeException (Rooted PosixPath))
-> [Char]
-> Either SomeException (Rooted PosixPath)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> PosixPath -> Either SomeException (Rooted PosixPath)
forall a b (m :: * -> *). (IsPath a b, MonadThrow m) => a -> m b
forall (m :: * -> *).
MonadThrow m =>
PosixPath -> m (Rooted PosixPath)
fromPath)

-- | Generates a Haskell expression of type @Unrooted OS_PATH@.
--
urE :: String -> Q Exp
urE :: [Char] -> Q Exp
urE = (SomeException -> Q Exp)
-> (Unrooted PosixPath -> Q Exp)
-> Either SomeException (Unrooted PosixPath)
-> Q Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Q Exp
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q Exp)
-> (SomeException -> [Char]) -> SomeException -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> [Char]
forall a. Show a => a -> [Char]
show) Unrooted PosixPath -> Q Exp
liftUnrooted (Either SomeException (Unrooted PosixPath) -> Q Exp)
-> ([Char] -> Either SomeException (Unrooted PosixPath))
-> [Char]
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Either SomeException PosixPath
forall (m :: * -> *). MonadThrow m => [Char] -> m PosixPath
OsPath.fromString ([Char] -> Either SomeException PosixPath)
-> (PosixPath -> Either SomeException (Unrooted PosixPath))
-> [Char]
-> Either SomeException (Unrooted PosixPath)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> PosixPath -> Either SomeException (Unrooted PosixPath)
forall a b (m :: * -> *). (IsPath a b, MonadThrow m) => a -> m b
forall (m :: * -> *).
MonadThrow m =>
PosixPath -> m (Unrooted PosixPath)
fromPath)

------------------------------------------------------------------------------
-- Statically Verified Literals
------------------------------------------------------------------------------

-- XXX Define folds or parsers to parse the paths.
-- XXX Build these on top of the str quasiquoter so that we get interpolation
-- for free. Interpolated vars if any have to be of appropriate type depending
-- on the context so that we can splice them safely.

-- | Generates a @Rooted Path@ type from a quoted literal.
--
-- >>> Path.toString (Path.toPath ([rt|/usr|] :: Rooted PosixPath))
-- "/usr"
--
rt :: QuasiQuoter
rt :: QuasiQuoter
rt = ([Char] -> Q Exp) -> QuasiQuoter
mkQ [Char] -> Q Exp
rtE

-- | Generates a @Unrooted Path@ type from a quoted literal.
--
-- >>> Path.toString (Path.toPath ([ur|usr|] :: Unrooted PosixPath))
-- "usr"
--
ur :: QuasiQuoter
ur :: QuasiQuoter
ur = ([Char] -> Q Exp) -> QuasiQuoter
mkQ [Char] -> Q Exp
urE

-- The only safety we need for paths is: (1) The first path can only be a Dir
-- type path, and (2) second path can only be a Unrooted path.

-- | Append a 'Unrooted' type path to a 'Rooted' path or 'Unrooted' path.
--
-- >>> Path.toString (Path.toPath (Seg.join [rt|/usr|] [ur|bin|] :: Rooted PosixPath))
-- "/usr/bin"
-- >>> Path.toString (Path.toPath (Seg.join [ur|usr|] [ur|bin|] :: Unrooted PosixPath))
-- "usr/bin"
--
{-# INLINE join #-}
join ::
    (
      IsSeg (a OS_PATH)
    , IsPath OS_PATH (a OS_PATH)
    ) => a OS_PATH -> Unrooted OS_PATH -> a OS_PATH
join :: forall (a :: * -> *).
(IsSeg (a PosixPath), IsPath PosixPath (a PosixPath)) =>
a PosixPath -> Unrooted PosixPath -> a PosixPath
join a PosixPath
a (Unrooted PosixPath
c) =
    PosixPath -> a PosixPath
forall a b. IsPath a b => a -> b
unsafeFromPath (PosixPath -> a PosixPath) -> PosixPath -> a PosixPath
forall a b. (a -> b) -> a -> b
$ PosixPath -> PosixPath -> PosixPath
OsPath.unsafeJoin (a PosixPath -> PosixPath
forall a b. IsPath a b => b -> a
toPath a PosixPath
a) (PosixPath -> PosixPath
forall a b. IsPath a b => b -> a
toPath PosixPath
c)