{-# 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
    toTildePrefixState,
    TildePrefixState (..),
    TildeException (..),
    containsTildePrefix,

    -- * Functions
    OsStr.length,

    -- * Normalization
    normalize,
    glyphLength,
  )
where

import Control.Category ((>>>))
import Control.DeepSeq (NFData)
import Control.Exception (Exception (displayException))
import Control.Monad.Catch (MonadThrow, throwM)
import Data.Maybe (isJust)
import Data.Text qualified as T
import FileSystem.Internal (TildePrefixes)
import FileSystem.Internal qualified as Internal
import FileSystem.UTF8 qualified as UTF8
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 TildePrefixState
  = -- | The path contained no tilde prefix.
    TildePrefixStateNone OsString
  | -- | The path contained "tilde prefix(es)" e.g. @~/@ or @~\\ (windows only)@,
    -- which have been stripped. Note that the returned 'OsString' can be empty.
    TildePrefixStateStripped OsString
  deriving stock
    ( -- | @since 0.1
      TildePrefixState -> TildePrefixState -> Bool
(TildePrefixState -> TildePrefixState -> Bool)
-> (TildePrefixState -> TildePrefixState -> Bool)
-> Eq TildePrefixState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TildePrefixState -> TildePrefixState -> Bool
== :: TildePrefixState -> TildePrefixState -> Bool
$c/= :: TildePrefixState -> TildePrefixState -> Bool
/= :: TildePrefixState -> TildePrefixState -> Bool
Eq,
      -- | @since 0.1
      (forall x. TildePrefixState -> Rep TildePrefixState x)
-> (forall x. Rep TildePrefixState x -> TildePrefixState)
-> Generic TildePrefixState
forall x. Rep TildePrefixState x -> TildePrefixState
forall x. TildePrefixState -> Rep TildePrefixState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TildePrefixState -> Rep TildePrefixState x
from :: forall x. TildePrefixState -> Rep TildePrefixState x
$cto :: forall x. Rep TildePrefixState x -> TildePrefixState
to :: forall x. Rep TildePrefixState x -> TildePrefixState
Generic,
      -- | @since 0.1
      Int -> TildePrefixState -> FilePath -> FilePath
[TildePrefixState] -> FilePath -> FilePath
TildePrefixState -> FilePath
(Int -> TildePrefixState -> FilePath -> FilePath)
-> (TildePrefixState -> FilePath)
-> ([TildePrefixState] -> FilePath -> FilePath)
-> Show TildePrefixState
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> TildePrefixState -> FilePath -> FilePath
showsPrec :: Int -> TildePrefixState -> FilePath -> FilePath
$cshow :: TildePrefixState -> FilePath
show :: TildePrefixState -> FilePath
$cshowList :: [TildePrefixState] -> FilePath -> FilePath
showList :: [TildePrefixState] -> FilePath -> FilePath
Show
    )
  deriving anyclass
    ( -- | @since 0.1
      TildePrefixState -> ()
(TildePrefixState -> ()) -> NFData TildePrefixState
forall a. (a -> ()) -> NFData a
$crnf :: TildePrefixState -> ()
rnf :: TildePrefixState -> ()
NFData
    )

-- | Retrieves the path's "tilde state". Strips consecutive "tilde prefixes"
-- if they exist. If the string contains no prefixes, returns it unchanged.
--
-- @since 0.1
toTildePrefixState :: OsString -> TildePrefixState
toTildePrefixState :: OsString -> TildePrefixState
toTildePrefixState OsString
p =
  case OsString -> Maybe OsString
stripTildePrefixes OsString
p of
    -- No leading tilde; check original string.
    Maybe OsString
Nothing -> OsString -> TildePrefixState
TildePrefixStateNone OsString
p
    -- Leading tilde; check stripped.
    Just OsString
p' -> OsString -> TildePrefixState
TildePrefixStateStripped OsString
p'

-- | Returns true iff the string has a tilde prefix.
--
-- @since 0.1
containsTildePrefix :: OsString -> Bool
containsTildePrefix :: OsString -> Bool
containsTildePrefix = Maybe OsString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe OsString -> Bool)
-> (OsString -> Maybe OsString) -> OsString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OsString -> Maybe OsString
stripTildePrefixes

-- | 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
stripTildePrefixes :: OsString -> Maybe OsString
stripTildePrefixes :: OsString -> Maybe OsString
stripTildePrefixes = TildePrefixes -> OsString -> Maybe OsString
Internal.stripTildePrefixes TildePrefixes
tildePrefixes

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

-- | Returns the number of "visual characters" i.e. glyphs. This is done by
-- performing unicode normalization then taking the 'Text' length.
-- Note that this is /not/ the same as 'OsStr.length'.
--
-- @since 0.1
glyphLength :: OsString -> Int
glyphLength :: OsString -> Int
glyphLength =
  Text -> Int
UTF8.glyphLength
    (Text -> Int) -> (OsString -> Text) -> OsString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
    (FilePath -> Text) -> (OsString -> FilePath) -> OsString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OsString -> FilePath
decodeLenient

-- | Performs canonical unicode decomposition/composition. Converts to/from
-- 'Text' via lenient encodings.
--
-- @since 0.1
normalize :: OsString -> OsString
normalize :: OsString -> OsString
normalize =
  FilePath -> OsString
encodeLenient
    (FilePath -> OsString)
-> (OsString -> FilePath) -> OsString -> OsString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack
    (Text -> FilePath) -> (OsString -> Text) -> OsString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
UTF8.normalizeC
    (Text -> Text) -> (OsString -> Text) -> OsString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
    (FilePath -> Text) -> (OsString -> FilePath) -> OsString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OsString -> FilePath
decodeLenient