{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Provides utilities for working with 'OsString'.
--
-- @since 0.1
module FileSystem.OsString
  ( -- * Types
    OsString,

    -- * Encoding

    -- ** Total
    osstr,
    osstrPathSep,
    encode,
    encodeLenient,

    -- ** Partial
    encodeThrowM,
    encodeFail,
    unsafeEncode,

    -- * Decoding

    -- ** Total
    decode,
    decodeLenient,
    decodeDisplayEx,
    decodeShow,

    -- ** Partial
    decodeThrowM,
    decodeFail,
    unsafeDecode,

    -- * Errors
    EncodingException (..),

    -- * Tildes
    toTildeState,
    TildeState (..),
    TildeException (..),
  )
where

import Control.Category ((>>>))
import Control.DeepSeq (NFData)
import Control.Exception (Exception (displayException))
import Control.Monad.Catch (MonadThrow, throwM)
import FileSystem.Internal (TildePrefixes)
import FileSystem.Internal qualified as Internal
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Language.Haskell.TH.Quote
  ( QuasiQuoter
      ( QuasiQuoter,
        quoteDec,
        quoteExp,
        quotePat,
        quoteType
      ),
  )
import System.OsString (OsString, osstr)
import System.OsString qualified as OsStr
import System.OsString.Encoding (EncodingException (EncodingError))

-- NOTE: -Wno-redundant-constraints is because the HasCallStack is redundant
-- on some of these functions when the exceptions library is too old.
-- Disabling the warning is easier than trying to get it right with cpp.

-- | Like 'osstr', except it runs paths through a "replace function" first.
-- On unix, replaces @\\@ with @/@. On windows, does the opposite.
--
-- This is convenient for writing paths in a platform-agnostic way i.e. we
-- are expecting a path
--
-- @
--   "path\/to\/foo" -- unix
--   "path\\to\\foo" -- windows
-- @
--
-- The normal way to handle this would be to use the combine function '(</>)'
-- i.e.
--
-- @
--   [osstr|path|] '</>' [osstr|to|] '</>' [osstr|foo|]
-- @
--
-- This can be quite cumbersome for long paths, so we provide this alternative,
-- allowing:
--
-- @
--   [osstrPathSep|path\/to\/foo]
-- @
--
-- Which will automatically convert slashes.
osstrPathSep :: QuasiQuoter
osstrPathSep :: QuasiQuoter
osstrPathSep =
  QuasiQuoter
    { quoteExp :: FilePath -> Q Exp
quoteExp = QuasiQuoter
osstr.quoteExp (FilePath -> Q Exp) -> (FilePath -> FilePath) -> FilePath -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
Internal.replaceSlashes,
      quotePat :: FilePath -> Q Pat
quotePat = QuasiQuoter
osstr.quotePat (FilePath -> Q Pat) -> (FilePath -> FilePath) -> FilePath -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
Internal.replaceSlashes,
      quoteType :: FilePath -> Q Type
quoteType = QuasiQuoter
osstr.quoteType (FilePath -> Q Type)
-> (FilePath -> FilePath) -> FilePath -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
Internal.replaceSlashes,
      quoteDec :: FilePath -> Q [Dec]
quoteDec = QuasiQuoter
osstr.quoteDec (FilePath -> Q [Dec])
-> (FilePath -> FilePath) -> FilePath -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
Internal.replaceSlashes
    }

-- | Encodes a 'String' to an 'OsString'. This is a pure version of String's
-- 'OsStr.encodeUtf' that returns the 'EncodingException' in the event of an
-- error.
--
-- @since 0.1
encode :: String -> Either EncodingException OsString
encode :: FilePath -> Either EncodingException OsString
encode = TextEncoding
-> TextEncoding -> FilePath -> Either EncodingException OsString
OsStr.encodeWith TextEncoding
utf8Encoder TextEncoding
utf16Encoder
  where
    (TextEncoding
utf8Encoder, TextEncoding
utf16Encoder) = (TextEncoding, TextEncoding)
Internal.utfEncodings

-- | Total conversion from 'String' to 'OsString', replacing encode failures
-- with the closest visual match.
--
-- @since 0.1
encodeLenient :: String -> OsString
encodeLenient :: FilePath -> OsString
encodeLenient = Either EncodingException OsString -> OsString
forall {a}. Either EncodingException a -> a
elimEx (Either EncodingException OsString -> OsString)
-> (FilePath -> Either EncodingException OsString)
-> FilePath
-> OsString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextEncoding
-> TextEncoding -> FilePath -> Either EncodingException OsString
OsStr.encodeWith TextEncoding
uft8Encoding TextEncoding
utf16Encoding
  where
    (TextEncoding
uft8Encoding, TextEncoding
utf16Encoding, Either EncodingException a -> a
elimEx) = (TextEncoding, TextEncoding, Either EncodingException a -> a)
forall a.
(TextEncoding, TextEncoding, Either EncodingException a -> a)
Internal.utfEncodingsLenient

-- | 'encode' that throws 'EncodingException'.
--
-- @since 0.1
encodeThrowM :: (HasCallStack, MonadThrow m) => String -> m OsString
encodeThrowM :: forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
FilePath -> m OsString
encodeThrowM =
  FilePath -> Either EncodingException OsString
encode (FilePath -> Either EncodingException OsString)
-> (Either EncodingException OsString -> m OsString)
-> FilePath
-> m OsString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
    Right OsString
txt -> OsString -> m OsString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OsString
txt
    Left EncodingException
ex -> EncodingException -> m OsString
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM EncodingException
ex
{-# INLINEABLE encodeThrowM #-}

-- | 'encodeThrowM' with 'MonadFail'.
--
-- @since 0.1
encodeFail :: (HasCallStack, MonadFail m) => String -> m OsString
encodeFail :: forall (m :: * -> *).
(HasCallStack, MonadFail m) =>
FilePath -> m OsString
encodeFail FilePath
fp = case FilePath -> Either EncodingException OsString
encode FilePath
fp of
  Right OsString
txt -> OsString -> m OsString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OsString
txt
  Left EncodingException
ex -> FilePath -> m OsString
forall a. FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (EncodingException -> FilePath
forall e. Exception e => e -> FilePath
displayException EncodingException
ex)
{-# INLINEABLE encodeFail #-}

-- | Unsafely converts a 'String' to 'OsString' falling back to 'error'.
--
-- __WARNING: Partial__
--
-- @since 0.1
unsafeEncode :: (HasCallStack) => String -> OsString
unsafeEncode :: HasCallStack => FilePath -> OsString
unsafeEncode FilePath
fp = case FilePath -> Either EncodingException OsString
encode FilePath
fp of
  Left EncodingException
ex -> FilePath -> OsString
forall a. HasCallStack => FilePath -> a
error (EncodingException -> FilePath
forall e. Exception e => e -> FilePath
displayException EncodingException
ex)
  Right OsString
p -> OsString
p

-- | Decodes an 'OsString' to a 'String'. This is a pure version of String's
-- 'OsStr.decodeUtf'.
--
-- @since 0.1
decode :: OsString -> Either EncodingException String
decode :: OsString -> Either EncodingException FilePath
decode = TextEncoding
-> TextEncoding -> OsString -> Either EncodingException FilePath
OsStr.decodeWith TextEncoding
utf8Encoder TextEncoding
utf16Encoder
  where
    (TextEncoding
utf8Encoder, TextEncoding
utf16Encoder) = (TextEncoding, TextEncoding)
Internal.utfEncodings

-- | Total conversion from 'OsString' to 'String', replacing decode failures
-- with the closest visual match.
--
-- @since 0.1
decodeLenient :: OsString -> String
decodeLenient :: OsString -> FilePath
decodeLenient = Either EncodingException FilePath -> FilePath
forall {a}. Either EncodingException a -> a
elimEx (Either EncodingException FilePath -> FilePath)
-> (OsString -> Either EncodingException FilePath)
-> OsString
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextEncoding
-> TextEncoding -> OsString -> Either EncodingException FilePath
OsStr.decodeWith TextEncoding
uft8Encoding TextEncoding
utf16Encoding
  where
    (TextEncoding
uft8Encoding, TextEncoding
utf16Encoding, Either EncodingException a -> a
elimEx) = (TextEncoding, TextEncoding, Either EncodingException a -> a)
forall a.
(TextEncoding, TextEncoding, Either EncodingException a -> a)
Internal.utfEncodingsLenient

-- | 'decode' that throws 'EncodingException'.
--
-- @since 0.1
decodeThrowM :: (HasCallStack, MonadThrow m) => OsString -> m String
decodeThrowM :: forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
OsString -> m FilePath
decodeThrowM =
  OsString -> Either EncodingException FilePath
decode (OsString -> Either EncodingException FilePath)
-> (Either EncodingException FilePath -> m FilePath)
-> OsString
-> m FilePath
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
    Right FilePath
txt -> FilePath -> m FilePath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
txt
    Left EncodingException
ex -> EncodingException -> m FilePath
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM EncodingException
ex
{-# INLINEABLE decodeThrowM #-}

-- | 'decode' with 'MonadFail'.
--
-- @since 0.1
decodeFail :: (HasCallStack, MonadFail m) => OsString -> m String
decodeFail :: forall (m :: * -> *).
(HasCallStack, MonadFail m) =>
OsString -> m FilePath
decodeFail OsString
p = case OsString -> Either EncodingException FilePath
decode OsString
p of
  Right FilePath
txt -> FilePath -> m FilePath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
txt
  Left EncodingException
ex -> FilePath -> m FilePath
forall a. FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (EncodingException -> FilePath
forall e. Exception e => e -> FilePath
displayException EncodingException
ex)
{-# INLINEABLE decodeFail #-}

-- | Total conversion from 'OsString' to 'String'. If decoding fails, displays
-- the exception.
--
-- @since 0.1
decodeDisplayEx :: OsString -> String
decodeDisplayEx :: OsString -> FilePath
decodeDisplayEx OsString
p = case OsString -> Either EncodingException FilePath
decode OsString
p of
  Left EncodingException
ex -> (EncodingException -> FilePath
forall e. Exception e => e -> FilePath
displayException EncodingException
ex)
  Right FilePath
s -> FilePath
s

-- | Total conversion from 'OsString' to 'String'. If decoding fails, falls back
-- to its 'Show' instance.
--
-- @since 0.1
decodeShow :: OsString -> String
decodeShow :: OsString -> FilePath
decodeShow OsString
p = case OsString -> Either EncodingException FilePath
decode OsString
p of
  Left EncodingException
_ -> OsString -> FilePath
forall a. Show a => a -> FilePath
show OsString
p
  Right FilePath
s -> FilePath
s

-- | Unsafely converts an 'OsString' to a 'String' falling back to 'error'.
--
-- __WARNING: Partial__
--
-- @since 0.1
unsafeDecode :: (HasCallStack) => OsString -> String
unsafeDecode :: HasCallStack => OsString -> FilePath
unsafeDecode OsString
p = case OsString -> Either EncodingException FilePath
decode OsString
p of
  Left EncodingException
ex -> FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error (EncodingException -> FilePath
forall e. Exception e => e -> FilePath
displayException EncodingException
ex)
  Right FilePath
fp -> FilePath
fp

-- | Exception for a path containing a tilde.
newtype TildeException = MkTildeException OsString
  deriving stock
    ( -- | @since 0.1
      TildeException -> TildeException -> Bool
(TildeException -> TildeException -> Bool)
-> (TildeException -> TildeException -> Bool) -> Eq TildeException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TildeException -> TildeException -> Bool
== :: TildeException -> TildeException -> Bool
$c/= :: TildeException -> TildeException -> Bool
/= :: TildeException -> TildeException -> Bool
Eq,
      -- | @since 0.1
      (forall x. TildeException -> Rep TildeException x)
-> (forall x. Rep TildeException x -> TildeException)
-> Generic TildeException
forall x. Rep TildeException x -> TildeException
forall x. TildeException -> Rep TildeException x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TildeException -> Rep TildeException x
from :: forall x. TildeException -> Rep TildeException x
$cto :: forall x. Rep TildeException x -> TildeException
to :: forall x. Rep TildeException x -> TildeException
Generic,
      -- | @since 0.1
      Int -> TildeException -> FilePath -> FilePath
[TildeException] -> FilePath -> FilePath
TildeException -> FilePath
(Int -> TildeException -> FilePath -> FilePath)
-> (TildeException -> FilePath)
-> ([TildeException] -> FilePath -> FilePath)
-> Show TildeException
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> TildeException -> FilePath -> FilePath
showsPrec :: Int -> TildeException -> FilePath -> FilePath
$cshow :: TildeException -> FilePath
show :: TildeException -> FilePath
$cshowList :: [TildeException] -> FilePath -> FilePath
showList :: [TildeException] -> FilePath -> FilePath
Show
    )
  deriving anyclass
    ( -- | @since 0.1
      TildeException -> ()
(TildeException -> ()) -> NFData TildeException
forall a. (a -> ()) -> NFData a
$crnf :: TildeException -> ()
rnf :: TildeException -> ()
NFData
    )

-- | @since 0.1
instance Exception TildeException where
  displayException :: TildeException -> FilePath
displayException (MkTildeException OsString
p) =
    FilePath
"Unexpected tilde in OsString: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> OsString -> FilePath
decodeLenient OsString
p

-- | Represents the "tilde state" for a given path.
data TildeState
  = -- | The path contains no tildes.
    TildeStateNone OsString
  | -- | The path contained a "tilde prefix" e.g. @~/@ or @~\\ (windows only)@,
    -- which has been stripped. It contains no other tildes. Note that the
    -- returned 'OsString' can be empty.
    TildeStatePrefix OsString
  | -- | The path contained a non-prefix tilde.
    TildeStateNonPrefix OsString
  deriving stock
    ( -- | @since 0.1
      TildeState -> TildeState -> Bool
(TildeState -> TildeState -> Bool)
-> (TildeState -> TildeState -> Bool) -> Eq TildeState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TildeState -> TildeState -> Bool
== :: TildeState -> TildeState -> Bool
$c/= :: TildeState -> TildeState -> Bool
/= :: TildeState -> TildeState -> Bool
Eq,
      -- | @since 0.1
      (forall x. TildeState -> Rep TildeState x)
-> (forall x. Rep TildeState x -> TildeState) -> Generic TildeState
forall x. Rep TildeState x -> TildeState
forall x. TildeState -> Rep TildeState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TildeState -> Rep TildeState x
from :: forall x. TildeState -> Rep TildeState x
$cto :: forall x. Rep TildeState x -> TildeState
to :: forall x. Rep TildeState x -> TildeState
Generic,
      -- | @since 0.1
      Int -> TildeState -> FilePath -> FilePath
[TildeState] -> FilePath -> FilePath
TildeState -> FilePath
(Int -> TildeState -> FilePath -> FilePath)
-> (TildeState -> FilePath)
-> ([TildeState] -> FilePath -> FilePath)
-> Show TildeState
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> TildeState -> FilePath -> FilePath
showsPrec :: Int -> TildeState -> FilePath -> FilePath
$cshow :: TildeState -> FilePath
show :: TildeState -> FilePath
$cshowList :: [TildeState] -> FilePath -> FilePath
showList :: [TildeState] -> FilePath -> FilePath
Show
    )
  deriving anyclass
    ( -- | @since 0.1
      TildeState -> ()
(TildeState -> ()) -> NFData TildeState
forall a. (a -> ()) -> NFData a
$crnf :: TildeState -> ()
rnf :: TildeState -> ()
NFData
    )

-- | Retrieves the path's "tilde state".
--
-- @since 0.1
toTildeState :: OsString -> TildeState
toTildeState :: OsString -> TildeState
toTildeState OsString
p =
  case OsString -> Maybe OsString
stripTildePrefix OsString
p of
    -- No leading tilde; check original string.
    Maybe OsString
Nothing -> (OsString -> TildeState) -> OsString -> TildeState
f OsString -> TildeState
TildeStateNone OsString
p
    -- Leading tilde; check stripped.
    Just OsString
p' -> (OsString -> TildeState) -> OsString -> TildeState
f OsString -> TildeState
TildeStatePrefix OsString
p'
  where
    f :: (OsString -> TildeState) -> OsString -> TildeState
    f :: (OsString -> TildeState) -> OsString -> TildeState
f OsString -> TildeState
toState OsString
q =
      if OsString -> Bool
Internal.containsTilde OsString
q
        then OsString -> TildeState
TildeStateNonPrefix OsString
q
        else OsString -> TildeState
toState OsString
q

-- | Strip tilde prefix of path @p@, returning @Just p'@ if @p@ was stripped.
-- On unix, strips @~/@. On windows, attempts to strip the same @~/@.
-- If that was unsuccessful, then attempts @~\\@.
--
-- The singular character @~@ is returned as the empty string, on both
-- platforms.
--
-- @since 0.1
stripTildePrefix :: OsString -> Maybe OsString
stripTildePrefix :: OsString -> Maybe OsString
stripTildePrefix = TildePrefixes -> OsString -> Maybe OsString
Internal.stripTildePrefix TildePrefixes
tildePrefixes

tildePrefixes :: TildePrefixes
tildePrefixes :: TildePrefixes
tildePrefixes = ([osstr|~/|], [osstr|~\|])