{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

{-|
Module      : GHCup.Utils.Prelude
Description : MegaParsec utilities
Copyright   : (c) Julian Ospald, 2020
License     : LGPL-3.0
Maintainer  : hasufell@hasufell.de
Stability   : experimental
Portability : portable

GHCup specific prelude. Lots of Excepts functionality.
-}
module GHCup.Utils.Prelude
  (module GHCup.Utils.Prelude,
#if defined(IS_WINDOWS)
   module GHCup.Utils.Prelude.Windows
#else
   module GHCup.Utils.Prelude.Posix
#endif
  )
where

import           GHCup.Types
import           GHCup.Errors
import           GHCup.Types.Optics
import {-# SOURCE #-} GHCup.Utils.Logger (logWarn)
#if defined(IS_WINDOWS)
import           GHCup.Utils.Prelude.Windows
#else
import           GHCup.Utils.Prelude.Posix
#endif

import           Control.Applicative
import           Control.Exception.Safe
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Data.Bifunctor
import           Data.ByteString                ( ByteString )
import           Data.List                      ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )
import           Data.Maybe
import           Data.Foldable
import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
import           Data.String
import           Data.Text                      ( Text )
import           Data.Versions
import           Data.Word8                  hiding ( isDigit )
import           Haskus.Utils.Types.List
import           Haskus.Utils.Variant.Excepts
import           Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
import           System.IO.Error
import           System.IO.Temp
import           System.IO.Unsafe
import           System.Directory
import           System.FilePath

import           Control.Retry
import           GHC.IO.Exception

import qualified Data.ByteString               as B
import qualified Data.ByteString.Lazy          as L
import qualified Data.Strict.Maybe             as S
import qualified Data.List.Split               as Split
import qualified Data.List.NonEmpty            as NE
import qualified Data.Text                     as T
import qualified Data.Text.Encoding            as E
import qualified Data.Text.Encoding.Error      as E
import qualified Data.Text.Lazy                as TL
import qualified Data.Text.Lazy.Builder        as B
import qualified Data.Text.Lazy.Builder.Int    as B
import qualified Data.Text.Lazy.Encoding       as TLE


-- $setup
-- >>> import Data.ByteString.Internal (c2w, w2c)
-- >>> import Test.QuickCheck
-- >>> import Data.Word8
-- >>> import qualified Data.Text as T
-- >>> import qualified Data.Char as C
-- >>> import Data.List
-- >>> instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary


fS :: IsString a => String -> a
fS :: String -> a
fS = String -> a
forall a. IsString a => String -> a
fromString

fromStrictMaybe :: S.Maybe a -> Maybe a
fromStrictMaybe :: Maybe a -> Maybe a
fromStrictMaybe = Maybe a -> (a -> Maybe a) -> Maybe a -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
S.maybe Maybe a
forall a. Maybe a
Nothing a -> Maybe a
forall a. a -> Maybe a
Just

fSM :: S.Maybe a -> Maybe a
fSM :: Maybe a -> Maybe a
fSM = Maybe a -> Maybe a
forall a. Maybe a -> Maybe a
fromStrictMaybe

toStrictMaybe :: Maybe a -> S.Maybe a
toStrictMaybe :: Maybe a -> Maybe a
toStrictMaybe = Maybe a -> (a -> Maybe a) -> Maybe a -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe a
forall a. Maybe a
S.Nothing a -> Maybe a
forall a. a -> Maybe a
S.Just

tSM :: Maybe a -> S.Maybe a
tSM :: Maybe a -> Maybe a
tSM = Maybe a -> Maybe a
forall a. Maybe a -> Maybe a
toStrictMaybe

internalError :: String -> IO a
internalError :: String -> IO a
internalError = String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> (String -> String) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Internal error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)

iE :: String -> IO a
iE :: String -> IO a
iE = String -> IO a
forall a. String -> IO a
internalError


showT :: Show a => a -> Text
showT :: a -> Text
showT = String -> Text
forall a. IsString a => String -> a
fS (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | Like 'when', but where the test can be monadic.
whenM :: Monad m => m Bool -> m () -> m ()
whenM :: m Bool -> m () -> m ()
whenM ~m Bool
b ~m ()
t = m Bool -> m () -> m () -> m ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
b m ()
t (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Like 'unless', but where the test can be monadic.
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM :: m Bool -> m () -> m ()
unlessM ~m Bool
b ~m ()
f = m Bool -> m () -> m () -> m ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
b (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) m ()
f

-- | Like @if@, but where the test can be monadic.
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM :: m Bool -> m a -> m a -> m a
ifM ~m Bool
b ~m a
t ~m a
f = do
  Bool
b' <- m Bool
b
  if Bool
b' then m a
t else m a
f

whileM :: Monad m => m a -> (a -> m Bool) -> m a
whileM :: m a -> (a -> m Bool) -> m a
whileM ~m a
action ~a -> m Bool
f = do
  a
a  <- m a
action
  Bool
b' <- a -> m Bool
f a
a
  if Bool
b' then m a -> (a -> m Bool) -> m a
forall (m :: * -> *) a. Monad m => m a -> (a -> m Bool) -> m a
whileM m a
action a -> m Bool
f else a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
whileM_ :: m a -> (a -> m Bool) -> m ()
whileM_ ~m a
action = m a -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m a -> m ()) -> ((a -> m Bool) -> m a) -> (a -> m Bool) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> (a -> m Bool) -> m a
forall (m :: * -> *) a. Monad m => m a -> (a -> m Bool) -> m a
whileM m a
action

guardM :: (Monad m, Alternative m) => m Bool -> m ()
guardM :: m Bool -> m ()
guardM ~m Bool
f = Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> m Bool -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Bool
f


handleIO' :: (MonadIO m, MonadCatch m)
          => IOErrorType
          -> (IOException -> m a)
          -> m a
          -> m a
handleIO' :: IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
err IOException -> m a
handler = (IOException -> m a) -> m a -> m a
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO
  (\IOException
e -> if IOErrorType
err IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOException -> IOErrorType
ioeGetErrorType IOException
e then IOException -> m a
handler IOException
e else IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ IOException -> IO a
forall a. IOException -> IO a
ioError IOException
e)


(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
?? :: Maybe a -> e -> Excepts es m a
(??) Maybe a
m e
e = Excepts es m a
-> (a -> Excepts es m a) -> Maybe a -> Excepts es m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Excepts es m a
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE e
e) a -> Excepts es m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
m


(!?) :: forall e es a m
      . (Monad m, e :< es)
     => m (Maybe a)
     -> e
     -> Excepts es m a
!? :: m (Maybe a) -> e -> Excepts es m a
(!?) m (Maybe a)
em e
e = m (Maybe a) -> Excepts es m (Maybe a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Maybe a)
em Excepts es m (Maybe a)
-> (Maybe a -> Excepts es m a) -> Excepts es m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe a -> e -> Excepts es m a
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
Maybe a -> e -> Excepts es m a
?? e
e)


lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
lE :: Either e a -> Excepts es m a
lE = Excepts '[e] m a -> Excepts es m a
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[e] m a -> Excepts es m a)
-> (Either e a -> Excepts '[e] m a) -> Either e a -> Excepts es m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VEither '[e] a -> Excepts '[e] m a
forall (m :: * -> *) (es :: [*]) a.
Monad m =>
VEither es a -> Excepts es m a
veitherToExcepts (VEither '[e] a -> Excepts '[e] m a)
-> (Either e a -> VEither '[e] a) -> Either e a -> Excepts '[e] m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> VEither '[e] a
forall a b. Either a b -> VEither '[a] b
fromEither

lE' :: forall e' e es a m
     . (Monad m, e :< es)
    => (e' -> e)
    -> Either e' a
    -> Excepts es m a
lE' :: (e' -> e) -> Either e' a -> Excepts es m a
lE' e' -> e
f = Excepts '[e] m a -> Excepts es m a
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE (Excepts '[e] m a -> Excepts es m a)
-> (Either e' a -> Excepts '[e] m a)
-> Either e' a
-> Excepts es m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VEither '[e] a -> Excepts '[e] m a
forall (m :: * -> *) (es :: [*]) a.
Monad m =>
VEither es a -> Excepts es m a
veitherToExcepts (VEither '[e] a -> Excepts '[e] m a)
-> (Either e' a -> VEither '[e] a)
-> Either e' a
-> Excepts '[e] m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> VEither '[e] a
forall a b. Either a b -> VEither '[a] b
fromEither (Either e a -> VEither '[e] a)
-> (Either e' a -> Either e a) -> Either e' a -> VEither '[e] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e' -> e) -> Either e' a -> Either e a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first e' -> e
f

lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
lEM :: m (Either e a) -> Excepts es m a
lEM m (Either e a)
em = m (Either e a) -> Excepts es m (Either e a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Either e a)
em Excepts es m (Either e a)
-> (Either e a -> Excepts es m a) -> Excepts es m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either e a -> Excepts es m a
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
Either e a -> Excepts es m a
lE

lEM' :: forall e' e es a m
      . (Monad m, e :< es)
     => (e' -> e)
     -> m (Either e' a)
     -> Excepts es m a
lEM' :: (e' -> e) -> m (Either e' a) -> Excepts es m a
lEM' e' -> e
f m (Either e' a)
em = m (Either e' a) -> Excepts es m (Either e' a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Either e' a)
em Excepts es m (Either e' a)
-> (Either e' a -> Excepts es m a) -> Excepts es m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either e a -> Excepts es m a
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
Either e a -> Excepts es m a
lE (Either e a -> Excepts es m a)
-> (Either e' a -> Either e a) -> Either e' a -> Excepts es m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e' -> e) -> Either e' a -> Either e a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first e' -> e
f

-- for some obscure reason... this won't type-check if we move it to a different module
catchWarn :: forall es m env . ( Pretty (V es)
                             , MonadReader env m
                             , HasLog env
                             , MonadIO m
                             , Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn :: Excepts es m () -> Excepts '[] m ()
catchWarn = (V es -> Excepts '[] m ()) -> Excepts es m () -> Excepts '[] m ()
forall (m :: * -> *) (es :: [*]) (es' :: [*]) a.
Monad m =>
(V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
catchAllE @_ @es (\V es
v -> m () -> Excepts '[] m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[] m ()) -> m () -> Excepts '[] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (String -> Text
T.pack (String -> Text) -> (V es -> String) -> V es -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V es -> String
forall a. Pretty a => a -> String
prettyShow (V es -> Text) -> V es -> Text
forall a b. (a -> b) -> a -> b
$ V es
v))

fromEither :: Either a b -> VEither '[a] b
fromEither :: Either a b -> VEither '[a] b
fromEither = (a -> VEither '[a] b)
-> (b -> VEither '[a] b) -> Either a b -> VEither '[a] b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (V '[a] -> VEither '[a] b
forall x (xs :: [*]). V xs -> VEither xs x
VLeft (V '[a] -> VEither '[a] b) -> (a -> V '[a]) -> a -> VEither '[a] b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> V '[a]
forall c (cs :: [*]). (c :< cs) => c -> V cs
V) b -> VEither '[a] b
forall x (xs :: [*]). x -> VEither xs x
VRight


liftIOException' :: ( MonadCatch m
                    , MonadIO m
                    , Monad m
                    , e :< es'
                    , LiftVariant es es'
                    )
                 => IOErrorType
                 -> e
                 -> Excepts es m a
                 -> Excepts es' m a
liftIOException' :: IOErrorType -> e -> Excepts es m a -> Excepts es' m a
liftIOException' IOErrorType
errType e
ex =
  (IOException -> Excepts es' m a)
-> Excepts es' m a -> Excepts es' m a
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO
      (\IOException
e ->
        if IOErrorType
errType IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOException -> IOErrorType
ioeGetErrorType IOException
e then e -> Excepts es' m a
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE e
ex else IO a -> Excepts es' m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Excepts es' m a) -> IO a -> Excepts es' m a
forall a b. (a -> b) -> a -> b
$ IOException -> IO a
forall a. IOException -> IO a
ioError IOException
e
      )
    (Excepts es' m a -> Excepts es' m a)
-> (Excepts es m a -> Excepts es' m a)
-> Excepts es m a
-> Excepts es' m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Excepts es m a -> Excepts es' m a
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE


liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es')
                => IOErrorType
                -> e
                -> m a
                -> Excepts es' m a
liftIOException :: IOErrorType -> e -> m a -> Excepts es' m a
liftIOException IOErrorType
errType e
ex =
  (IOException -> Excepts es' m a)
-> Excepts es' m a -> Excepts es' m a
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO
      (\IOException
e ->
        if IOErrorType
errType IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOException -> IOErrorType
ioeGetErrorType IOException
e then e -> Excepts es' m a
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE e
ex else IO a -> Excepts es' m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Excepts es' m a) -> IO a -> Excepts es' m a
forall a b. (a -> b) -> a -> b
$ IOException -> IO a
forall a. IOException -> IO a
ioError IOException
e
      )
    (Excepts es' m a -> Excepts es' m a)
-> (m a -> Excepts es' m a) -> m a -> Excepts es' m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Excepts es' m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift


-- | Uses safe-exceptions.
hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()
hideError :: IOErrorType -> m () -> m ()
hideError IOErrorType
err = (IOException -> m ()) -> m () -> m ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> if IOErrorType
err IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOException -> IOErrorType
ioeGetErrorType IOException
e then () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IOException -> IO ()) -> IOException -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> IO ()
forall a. IOException -> IO a
ioError (IOException -> m ()) -> IOException -> m ()
forall a b. (a -> b) -> a -> b
$ IOException
e)


hideErrorDef :: (MonadIO m, MonadCatch m) => [IOErrorType] -> a -> m a -> m a
hideErrorDef :: [IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType]
errs a
def =
  (IOException -> m a) -> m a -> m a
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> if IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> [IOErrorType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IOErrorType]
errs then a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def else IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ IOException -> IO a
forall a. IOException -> IO a
ioError IOException
e)


hideErrorDefM :: (MonadIO m, MonadCatch m) => [IOErrorType] -> m a -> m a -> m a
hideErrorDefM :: [IOErrorType] -> m a -> m a -> m a
hideErrorDefM [IOErrorType]
errs m a
def =
  (IOException -> m a) -> m a -> m a
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> if IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> [IOErrorType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IOErrorType]
errs then m a
def else IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ IOException -> IO a
forall a. IOException -> IO a
ioError IOException
e)


-- TODO: does this work?
hideExcept :: forall e es es' a m
            . (Monad m, e :< es, LiftVariant (Remove e es) es')
           => e
           -> a
           -> Excepts es m a
           -> Excepts es' m a
hideExcept :: e -> a -> Excepts es m a -> Excepts es' m a
hideExcept e
_ a
a =
  (e -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es, LiftVariant (Remove e es) es') =>
(e -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
catchLiftLeft ((\e
_ -> a -> Excepts es' m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) :: (e -> Excepts es' m a))


hideExcept' :: forall e es es' m
             . (Monad m, e :< es, LiftVariant (Remove e es) es')
            => e
            -> Excepts es m ()
            -> Excepts es' m ()
hideExcept' :: e -> Excepts es m () -> Excepts es' m ()
hideExcept' e
_ =
  (e -> Excepts es' m ()) -> Excepts es m () -> Excepts es' m ()
forall e (es :: [*]) (es' :: [*]) a (m :: * -> *).
(Monad m, e :< es, LiftVariant (Remove e es) es') =>
(e -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
catchLiftLeft ((\e
_ -> () -> Excepts es' m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) :: (e -> Excepts es' m ()))


reThrowAll :: forall e es es' a m
            . (Monad m, e :< es')
           => (V es -> e)
           -> Excepts es m a
           -> Excepts es' m a
reThrowAll :: (V es -> e) -> Excepts es m a -> Excepts es' m a
reThrowAll V es -> e
f = (V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
forall (m :: * -> *) (es :: [*]) (es' :: [*]) a.
Monad m =>
(V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
catchAllE (e -> Excepts es' m a
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (e -> Excepts es' m a) -> (V es -> e) -> V es -> Excepts es' m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V es -> e
f)


reThrowAllIO :: forall e es es' a m
              . (MonadCatch m, Monad m, MonadIO m, e :< es')
             => (V es -> e)
             -> (IOException -> e)
             -> Excepts es m a
             -> Excepts es' m a
reThrowAllIO :: (V es -> e)
-> (IOException -> e) -> Excepts es m a -> Excepts es' m a
reThrowAllIO V es -> e
f IOException -> e
g = (IOException -> Excepts es' m a)
-> Excepts es' m a -> Excepts es' m a
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (e -> Excepts es' m a
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (e -> Excepts es' m a)
-> (IOException -> e) -> IOException -> Excepts es' m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> e
g) (Excepts es' m a -> Excepts es' m a)
-> (Excepts es m a -> Excepts es' m a)
-> Excepts es m a
-> Excepts es' m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
forall (m :: * -> *) (es :: [*]) (es' :: [*]) a.
Monad m =>
(V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
catchAllE (e -> Excepts es' m a
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (e -> Excepts es' m a) -> (V es -> e) -> V es -> Excepts es' m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V es -> e
f)


throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
throwEither :: Either a b -> m b
throwEither Either a b
a = case Either a b
a of
  Left  a
e -> a -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM a
e
  Right b
r -> b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r


throwEither' :: (Exception a, MonadThrow m) => a -> Either x b -> m b
throwEither' :: a -> Either x b -> m b
throwEither' a
e Either x b
eth = case Either x b
eth of
  Left  x
_ -> a -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM a
e
  Right b
r -> b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r

throwMaybe :: (Exception a, MonadThrow m) => a -> Maybe b -> m b
throwMaybe :: a -> Maybe b -> m b
throwMaybe a
a Maybe b
m = case Maybe b
m of
  Maybe b
Nothing -> a -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM a
a
  Just b
r -> b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r

throwMaybeM :: (Exception a, MonadThrow m) => a -> m (Maybe b) -> m b
throwMaybeM :: a -> m (Maybe b) -> m b
throwMaybeM a
a m (Maybe b)
am = do
  Maybe b
m <- m (Maybe b)
am
  a -> Maybe b -> m b
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
a -> Maybe b -> m b
throwMaybe a
a Maybe b
m


verToBS :: Version -> ByteString
verToBS :: Version -> ByteString
verToBS = Text -> ByteString
E.encodeUtf8 (Text -> ByteString) -> (Version -> Text) -> Version -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Text
prettyVer

verToS :: Version -> String
verToS :: Version -> String
verToS = Text -> String
T.unpack (Text -> String) -> (Version -> Text) -> Version -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Text
prettyVer

intToText :: Integral a => a -> T.Text
intToText :: a -> Text
intToText = Text -> Text
TL.toStrict (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
B.toLazyText (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
forall a. Integral a => a -> Builder
B.decimal


pvpToVersion :: MonadThrow m => PVP -> Text -> m Version
pvpToVersion :: PVP -> Text -> m Version
pvpToVersion PVP
pvp_ Text
rest =
  (ParsingError -> m Version)
-> (Version -> m Version)
-> Either ParsingError Version
-> m Version
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ParsingError
_ -> ParseError -> m Version
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseError -> m Version) -> ParseError -> m Version
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError String
"Couldn't convert PVP to Version") Version -> m Version
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParsingError Version -> m Version)
-> (PVP -> Either ParsingError Version) -> PVP -> m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either ParsingError Version
version (Text -> Either ParsingError Version)
-> (PVP -> Text) -> PVP -> Either ParsingError Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest) (Text -> Text) -> (PVP -> Text) -> PVP -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PVP -> Text
prettyPVP (PVP -> m Version) -> PVP -> m Version
forall a b. (a -> b) -> a -> b
$ PVP
pvp_

-- | Convert a version to a PVP and unparsable rest.
--
-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v
versionToPVP :: MonadThrow m => Version -> m (PVP, Text)
versionToPVP :: Version -> m (PVP, Text)
versionToPVP (Version (Just Word
_) NonEmpty VChunk
_ [VChunk]
_ Maybe Text
_) = ParseError -> m (PVP, Text)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseError -> m (PVP, Text)) -> ParseError -> m (PVP, Text)
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError String
"Unexpected epoch"
versionToPVP Version
v = (ParsingError -> m (PVP, Text))
-> (PVP -> m (PVP, Text))
-> Either ParsingError PVP
-> m (PVP, Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ParsingError
_ -> (, Version -> Text
rest Version
v) (PVP -> (PVP, Text)) -> m PVP -> m (PVP, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> m PVP
forall (m :: * -> *). MonadThrow m => Version -> m PVP
alternative Version
v) ((PVP, Text) -> m (PVP, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((PVP, Text) -> m (PVP, Text))
-> (PVP -> (PVP, Text)) -> PVP -> m (PVP, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Text
forall a. Monoid a => a
mempty)) (Either ParsingError PVP -> m (PVP, Text))
-> (Version -> Either ParsingError PVP) -> Version -> m (PVP, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either ParsingError PVP
pvp (Text -> Either ParsingError PVP)
-> (Version -> Text) -> Version -> Either ParsingError PVP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Text
prettyVer (Version -> m (PVP, Text)) -> Version -> m (PVP, Text)
forall a b. (a -> b) -> a -> b
$ Version
v
 where
  alternative :: MonadThrow m => Version -> m PVP
  alternative :: Version -> m PVP
alternative Version
v' = case (VChunk -> Bool) -> NonEmpty VChunk -> [VChunk]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.takeWhile VChunk -> Bool
isDigit (Version -> NonEmpty VChunk
_vChunks Version
v') of
    [] -> ParseError -> m PVP
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseError -> m PVP) -> ParseError -> m PVP
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError String
"Couldn't convert Version to PVP"
    [VChunk]
xs -> PVP -> m PVP
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PVP -> m PVP) -> PVP -> m PVP
forall a b. (a -> b) -> a -> b
$ [Int] -> PVP
pvpFromList (VChunk -> Int
unsafeDigit (VChunk -> Int) -> [VChunk] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VChunk]
xs)

  rest :: Version -> Text
  rest :: Version -> Text
rest (Version Maybe Word
_ NonEmpty VChunk
cs [VChunk]
pr Maybe Text
me) =
    let chunks :: [VChunk]
chunks = (VChunk -> Bool) -> NonEmpty VChunk -> [VChunk]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.dropWhile VChunk -> Bool
isDigit NonEmpty VChunk
cs
        ver :: [Text]
ver = Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse (String -> Text
T.pack String
".") ([Text] -> [Text]) -> ([VChunk] -> [Text]) -> [VChunk] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VChunk] -> [Text]
forall (t :: * -> *). Functor t => t VChunk -> t Text
chunksAsT ([VChunk] -> [Text]) -> [VChunk] -> [Text]
forall a b. (a -> b) -> a -> b
$ [VChunk]
chunks
        me' :: [Text]
me' = [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
m -> [String -> Text
T.pack String
"+",Text
m]) Maybe Text
me
        pr' :: [Text]
pr' = [Text] -> ([Text] -> [Text]) -> [Text] -> [Text]
forall (f :: * -> *) b a.
Foldable f =>
f b -> (f a -> f b) -> f a -> f b
foldable [] (String -> Text
T.pack String
"-" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse (String -> Text
T.pack String
".") ([VChunk] -> [Text]
forall (t :: * -> *). Functor t => t VChunk -> t Text
chunksAsT [VChunk]
pr)
        prefix :: Text
prefix = case ([Text]
ver, [Text]
pr', [Text]
me') of
                   (Text
_:[Text]
_, [Text]
_, [Text]
_) -> String -> Text
T.pack String
"."
                   ([Text], [Text], [Text])
_           -> String -> Text
T.pack String
""
    in Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text]
ver [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
pr' [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
me')
   where
    chunksAsT :: Functor t => t VChunk -> t Text
    chunksAsT :: t VChunk -> t Text
chunksAsT = (VChunk -> Text) -> t VChunk -> t Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((VUnit -> Text) -> VChunk -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap VUnit -> Text
f)
      where
        f :: VUnit -> Text
        f :: VUnit -> Text
f (Digits Word
i) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word -> String
forall a. Show a => a -> String
show Word
i
        f (Str Text
s)    = Text
s

    foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b
    foldable :: f b -> (f a -> f b) -> f a -> f b
foldable f b
d f a -> f b
g f a
f | f a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null f a
f    = f b
d
                   | Bool
otherwise = f a -> f b
g f a
f



  isDigit :: VChunk -> Bool
  isDigit :: VChunk -> Bool
isDigit (Digits Word
_ :| []) = Bool
True
  isDigit VChunk
_                = Bool
False

  unsafeDigit :: VChunk -> Int
  unsafeDigit :: VChunk -> Int
unsafeDigit (Digits Word
x :| []) = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
x
  unsafeDigit VChunk
_ = String -> Int
forall a. HasCallStack => String -> a
error String
"unsafeDigit: wrong input"

pvpFromList :: [Int] -> PVP
pvpFromList :: [Int] -> PVP
pvpFromList = NonEmpty Word -> PVP
PVP (NonEmpty Word -> PVP) -> ([Int] -> NonEmpty Word) -> [Int] -> PVP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word] -> NonEmpty Word
forall a. [a] -> NonEmpty a
NE.fromList ([Word] -> NonEmpty Word)
-> ([Int] -> [Word]) -> [Int] -> NonEmpty Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Word) -> [Int] -> [Word]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Safe 'decodeUtf8With'. Replaces an invalid input byte with
-- the Unicode replacement character U+FFFD.
decUTF8Safe :: ByteString -> Text
decUTF8Safe :: ByteString -> Text
decUTF8Safe = OnDecodeError -> ByteString -> Text
E.decodeUtf8With OnDecodeError
E.lenientDecode

decUTF8Safe' :: L.ByteString -> Text
decUTF8Safe' :: ByteString -> Text
decUTF8Safe' = Text -> Text
TL.toStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
TLE.decodeUtf8With OnDecodeError
E.lenientDecode


-- | Escape a version for use in regex
escapeVerRex :: Version -> ByteString
escapeVerRex :: Version -> ByteString
escapeVerRex = [Word8] -> ByteString
B.pack ([Word8] -> ByteString)
-> (Version -> [Word8]) -> Version -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [Word8]
go ([Word8] -> [Word8]) -> (Version -> [Word8]) -> Version -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
B.unpack (ByteString -> [Word8])
-> (Version -> ByteString) -> Version -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> ByteString
verToBS
 where
  go :: [Word8] -> [Word8]
go [] = []
  go (Word8
x : [Word8]
xs) | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_period = [Word8
_backslash, Word8
_period] [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8] -> [Word8]
go [Word8]
xs
              | Bool
otherwise    = Word8
x Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8] -> [Word8]
go [Word8]
xs

-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
createDirRecursive' :: FilePath -> IO ()
createDirRecursive' :: String -> IO ()
createDirRecursive' String
p =
  (IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> if IOException -> Bool
isAlreadyExistsError IOException
e then IOException -> IO ()
isSymlinkDir IOException
e else IOException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
    (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String -> IO ()
createDirectoryIfMissing Bool
True
    (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
p

 where
  isSymlinkDir :: IOException -> IO ()
isSymlinkDir IOException
e = do
    Bool
ft <- String -> IO Bool
pathIsSymbolicLink String
p
    case Bool
ft of
      Bool
True -> do
        String
rp <- String -> IO String
canonicalizePath String
p
        Bool
rft <- String -> IO Bool
doesDirectoryExist String
rp
        case Bool
rft of
          Bool
True -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Bool
_ -> IOException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e
      Bool
_ -> IOException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e


-- | Recursively copy the contents of one directory to another path.
--
-- This is a rip-off of Cabal library.
copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
copyDirectoryRecursive :: String -> String -> (String -> String -> IO ()) -> IO ()
copyDirectoryRecursive String
srcDir String
destDir String -> String -> IO ()
doCopy = do
  [String]
srcFiles <- String -> IO [String]
getDirectoryContentsRecursive String
srcDir
  String -> [(String, String)] -> IO ()
copyFilesWith String
destDir [ (String
srcDir, String
f)
                          | String
f <- [String]
srcFiles ]
  where
    -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
    -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
    copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
    copyFilesWith :: String -> [(String, String)] -> IO ()
copyFilesWith String
targetDir [(String, String)]
srcFiles = do

      -- Create parent directories for everything
      let dirs :: [String]
dirs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
targetDir String -> String -> String
</>) ([String] -> [String])
-> ([(String, String)] -> [String])
-> [(String, String)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> ([(String, String)] -> [String])
-> [(String, String)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
takeDirectory (String -> String)
-> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd) ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ [(String, String)]
srcFiles
      (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Bool -> String -> IO ()
createDirectoryIfMissing Bool
True) [String]
dirs

      -- Copy all the files
      [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let src :: String
src  = String
srcBase   String -> String -> String
</> String
srcFile
                      dest :: String
dest = String
targetDir String -> String -> String
</> String
srcFile
                   in String -> String -> IO ()
doCopy String
src String
dest
                | (String
srcBase, String
srcFile) <- [(String, String)]
srcFiles ]


-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive :: String -> IO [String]
getDirectoryContentsRecursive String
topdir = [String] -> IO [String]
recurseDirectories [String
""]
  where
    recurseDirectories :: [FilePath] -> IO [FilePath]
    recurseDirectories :: [String] -> IO [String]
recurseDirectories []         = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    recurseDirectories (String
dir:[String]
dirs) = IO [String] -> IO [String]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ do
      ([String]
files, [String]
dirs') <- [String] -> [String] -> [String] -> IO ([String], [String])
collect [] [] ([String] -> IO ([String], [String]))
-> IO [String] -> IO ([String], [String])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO [String]
getDirectoryContents (String
topdir String -> String -> String
</> String
dir)
      [String]
files' <- [String] -> IO [String]
recurseDirectories ([String]
dirs' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
dirs)
      [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
files [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
files')

      where
        collect :: [String] -> [String] -> [String] -> IO ([String], [String])
collect [String]
files [String]
dirs' []              = ([String], [String]) -> IO ([String], [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
files
                                                     ,[String] -> [String]
forall a. [a] -> [a]
reverse [String]
dirs')
        collect [String]
files [String]
dirs' (String
entry:[String]
entries) | String -> Bool
ignore String
entry
                                            = [String] -> [String] -> [String] -> IO ([String], [String])
collect [String]
files [String]
dirs' [String]
entries
        collect [String]
files [String]
dirs' (String
entry:[String]
entries) = do
          let dirEntry :: String
dirEntry = String
dir String -> String -> String
</> String
entry
          Bool
isDirectory <- String -> IO Bool
doesDirectoryExist (String
topdir String -> String -> String
</> String
dirEntry)
          if Bool
isDirectory
            then [String] -> [String] -> [String] -> IO ([String], [String])
collect [String]
files (String
dirEntryString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
dirs') [String]
entries
            else [String] -> [String] -> [String] -> IO ([String], [String])
collect (String
dirEntryString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
files) [String]
dirs' [String]
entries

        ignore :: String -> Bool
ignore [Char
'.']      = Bool
True
        ignore [Char
'.', Char
'.'] = Bool
True
        ignore String
_          = Bool
False


-- https://github.com/haskell/directory/issues/110
-- https://github.com/haskell/directory/issues/96
-- https://www.sqlite.org/src/info/89f1848d7f
recyclePathForcibly :: ( MonadIO m
                       , MonadReader env m
                       , HasDirs env
                       , MonadMask m
                       )
                    => FilePath
                    -> m ()
recyclePathForcibly :: String -> m ()
recyclePathForcibly String
fp
  | Bool
isWindows = do
      Dirs { String
$sel:recycleDir:Dirs :: Dirs -> String
recycleDir :: String
recycleDir } <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
      String
tmp <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
createTempDirectory String
recycleDir String
"recyclePathForcibly"
      let dest :: String
dest = String
tmp String -> String -> String
</> String -> String
takeFileName String
fp
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO ()
moveFile String
fp String
dest)
          m () -> (IOException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
          (\IOException
e -> if | IOException -> Bool
isDoesNotExistError IOException
e -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    | IOException -> Bool
isPermissionError IOException
e Bool -> Bool -> Bool
|| IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
UnsupportedOperation {- EXDEV on windows -} -> m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removePathForcibly String
fp)
                    | Bool
otherwise -> IOException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
          m () -> m () -> m ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally`
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removePathForcibly String
tmp)
  | Bool
otherwise = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removePathForcibly String
fp


rmPathForcibly :: ( MonadIO m
                  , MonadMask m
                  )
               => FilePath
               -> m ()
rmPathForcibly :: String -> m ()
rmPathForcibly String
fp
  | Bool
isWindows = m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removePathForcibly String
fp)
  | Bool
otherwise = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removePathForcibly String
fp


rmDirectory :: (MonadIO m, MonadMask m)
            => FilePath
            -> m ()
rmDirectory :: String -> m ()
rmDirectory String
fp
  | Bool
isWindows = m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectory String
fp)
  | Bool
otherwise = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectory String
fp


-- https://www.sqlite.org/src/info/89f1848d7f
-- https://github.com/haskell/directory/issues/96
recycleFile :: ( MonadIO m
               , MonadMask m
               , MonadReader env m
               , HasDirs env
               )
            => FilePath
            -> m ()
recycleFile :: String -> m ()
recycleFile String
fp
  | Bool
isWindows = do
      Dirs { String
recycleDir :: String
$sel:recycleDir:Dirs :: Dirs -> String
recycleDir } <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
doesDirectoryExist String
fp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOException -> IO ()
forall a. IOException -> IO a
ioError (Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
InappropriateType String
"recycleFile" String
"" Maybe CInt
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
fp))
      String
tmp <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> String -> IO String
createTempDirectory String
recycleDir String
"recycleFile"
      let dest :: String
dest = String
tmp String -> String -> String
</> String -> String
takeFileName String
fp
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO ()
moveFile String
fp String
dest)
        m () -> (IOException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
          (\IOException
e -> if IOException -> Bool
isPermissionError IOException
e Bool -> Bool -> Bool
|| IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
UnsupportedOperation {- EXDEV on windows -} then m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removePathForcibly String
fp) else IOException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
        m () -> m () -> m ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally`
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removePathForcibly String
tmp)
  | Bool
otherwise = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
fp


rmFile :: ( MonadIO m
          , MonadMask m
          )
      => FilePath
      -> m ()
rmFile :: String -> m ()
rmFile String
fp
  | Bool
isWindows = m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
fp)
  | Bool
otherwise = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
fp


rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
                => FilePath
                -> m ()
rmDirectoryLink :: String -> m ()
rmDirectoryLink String
fp
  | Bool
isWindows = m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryLink String
fp)
  | Bool
otherwise = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryLink String
fp


recover :: (MonadIO m, MonadMask m) => m a -> m a
recover :: m a -> m a
recover m a
action = 
  RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
recovering (Int -> RetryPolicyM m
forall (m :: * -> *). MonadIO m => Int -> RetryPolicyM m
fullJitterBackoff Int
25000 RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
limitRetries Int
10)
    [\RetryStatus
_ -> (IOException -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\IOException
e -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ IOException -> Bool
isPermissionError IOException
e)
    ,\RetryStatus
_ -> (IOException -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\IOException
e -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
InappropriateType))
    ,\RetryStatus
_ -> (IOException -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\IOException
e -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
UnsatisfiedConstraints))
    ]
    (\RetryStatus
_ -> m a
action)


copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m ()
copyFileE :: String -> String -> Excepts xs m ()
copyFileE String
from = (IOException -> Excepts xs m ())
-> Excepts xs m () -> Excepts xs m ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (CopyError -> Excepts xs m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (CopyError -> Excepts xs m ())
-> (IOException -> CopyError) -> IOException -> Excepts xs m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CopyError
CopyError (String -> CopyError)
-> (IOException -> String) -> IOException -> CopyError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall a. Show a => a -> String
show) (Excepts xs m () -> Excepts xs m ())
-> (String -> Excepts xs m ()) -> String -> Excepts xs m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Excepts xs m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts xs m ())
-> (String -> IO ()) -> String -> Excepts xs m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> IO ()
copyFile String
from


-- | Gathering monoidal values
--
-- >>> traverseFold (pure . (:["0"])) ["1","2"]
-- ["1","0","2","0"]
-- >>> traverseFold Just ["1","2","3","4","5"]
-- Just "12345"
--
-- prop> \t -> traverseFold Just t === Just (mconcat t)
traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
traverseFold :: (a -> m b) -> t a -> m b
traverseFold a -> m b
f = (m b -> a -> m b) -> m b -> t a -> m b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\m b
mb a
a -> b -> b -> b
forall a. Semigroup a => a -> a -> a
(<>) (b -> b -> b) -> m b -> m (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
mb m (b -> b) -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> m b
f a
a) (b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
forall a. Monoid a => a
mempty)

-- | Gathering monoidal values
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forFold :: t a -> (a -> m b) -> m b
forFold = \t a
t -> ((a -> m b) -> t a -> m b
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Applicative m, Monoid b) =>
(a -> m b) -> t a -> m b
`traverseFold` t a
t)


-- | Strip @\\r@ and @\\n@ from 'String's
--
-- >>> stripNewline "foo\n\n\n"
-- "foo"
-- >>> stripNewline "foo\n\n\nfoo"
-- "foofoo"
-- >>> stripNewline "foo\r"
-- "foo"
-- >>> stripNewline "foo"
-- "foo"
--
-- prop> \t -> stripNewline (t <> "\n") === stripNewline t
-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewline t == t
stripNewline :: String -> String
stripNewline :: String -> String
stripNewline = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"\n\r")


-- | Strip @\\r@ and @\\n@ from end of 'String'.
--
-- >>> stripNewlineEnd "foo\n\n\n"
-- "foo"
-- >>> stripNewlineEnd "foo\n\n\nfoo"
-- "foo\n\n\nfoo"
-- >>> stripNewlineEnd "foo\r"
-- "foo"
-- >>> stripNewlineEnd "foo"
-- "foo"
--
-- prop> \t -> stripNewlineEnd (t <> "\n") === stripNewlineEnd t
-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewlineEnd t == t
stripNewlineEnd :: String -> String
stripNewlineEnd :: String -> String
stripNewlineEnd = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"\n\r")


-- | Strip @\\r@ and @\\n@ from 'Text's
--
-- >>> stripNewline' "foo\n\n\n"
-- "foo"
-- >>> stripNewline' "foo\n\n\nfoo"
-- "foofoo"
-- >>> stripNewline' "foo\r"
-- "foo"
-- >>> stripNewline' "foo"
-- "foo"
--
-- prop> \t -> stripNewline' (t <> "\n") === stripNewline' t
-- prop> \t -> not (T.any (isNewLine . c2w) t) ==> stripNewline' t == t
stripNewline' :: T.Text -> T.Text
stripNewline' :: Text -> Text
stripNewline' = (Char -> Bool) -> Text -> Text
T.filter (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"\n\r")


-- | Is the word8 a newline?
--
-- >>> isNewLine (c2w '\n')
-- True
-- >>> isNewLine (c2w '\r')
-- True
--
-- prop> \w -> w /= _lf && w /= _cr ==> not (isNewLine w)
isNewLine :: Word8 -> Bool
isNewLine :: Word8 -> Bool
isNewLine Word8
w
  | Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_lf = Bool
True
  | Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_cr = Bool
True
  | Bool
otherwise = Bool
False


-- | Split on a PVP suffix.
--
-- >>> splitOnPVP "-" "ghc-iserv-dyn-9.3.20210706"
-- ("ghc-iserv-dyn","9.3.20210706")
-- >>> splitOnPVP "-" "ghc-iserv-dyn"
-- ("ghc-iserv-dyn","")
splitOnPVP :: String -> String -> (String, String)
splitOnPVP :: String -> String -> (String, String)
splitOnPVP String
c String
s = case String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
Split.splitOn String
c String
s of
  []  -> (String, String)
def
  [String
_] -> (String, String)
def
  [String]
xs
    | let l :: String
l = [String] -> String
forall a. [a] -> a
last [String]
xs
    , (Right PVP
_) <- Text -> Either ParsingError PVP
pvp (String -> Text
T.pack String
l) -> (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
c ([String] -> [String]
forall a. [a] -> [a]
init [String]
xs), String
l)
    | Bool
otherwise -> (String, String)
def
 where
  def :: (String, String)
def = (String
s, String
"")



-- | Like 'find', but where the test can be monadic.
--
-- >>> findM (Just . C.isUpper) "teST"
-- Just (Just 'S')
-- >>> findM (Just . C.isUpper) "test"
-- Just Nothing
-- >>> findM (Just . const True) ["x",undefined]
-- Just (Just "x")
findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
findM :: (a -> m Bool) -> [a] -> m (Maybe a)
findM ~a -> m Bool
p = (a -> m (Maybe a) -> m (Maybe a))
-> m (Maybe a) -> [a] -> m (Maybe a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x -> m Bool -> m (Maybe a) -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (a -> m Bool
p a
x) (Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x)) (Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)


-- | Drops the given suffix from a list.
--   It returns the original sequence if the sequence doesn't end with the given suffix.
--
-- >>> dropSuffix "!" "Hello World!"
-- "Hello World"
-- >>> dropSuffix "!" "Hello World!!"
-- "Hello World!"
-- >>> dropSuffix "!" "Hello World."
-- "Hello World."
dropSuffix :: Eq a => [a] -> [a] -> [a]
dropSuffix :: [a] -> [a] -> [a]
dropSuffix [a]
a [a]
b = [a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
fromMaybe [a]
b (Maybe [a] -> [a]) -> Maybe [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [a]
a [a]
b

-- | Return the prefix of the second list if its suffix
--   matches the entire first list.
--
-- >>> stripSuffix "bar" "foobar"
-- Just "foo"
-- >>> stripSuffix ""    "baz"
-- Just "baz"
-- >>> stripSuffix "foo" "quux"
-- Nothing
stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
stripSuffix :: [a] -> [a] -> Maybe [a]
stripSuffix [a]
a [a]
b = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
a) ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
b)


-- | Drops the given prefix from a list.
--   It returns the original sequence if the sequence doesn't start with the given prefix.
--
-- >>> dropPrefix "Mr. " "Mr. Men"
-- "Men"
-- >>> dropPrefix "Mr. " "Dr. Men"
-- "Dr. Men"
dropPrefix :: Eq a => [a] -> [a] -> [a]
dropPrefix :: [a] -> [a] -> [a]
dropPrefix [a]
a [a]
b = [a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
fromMaybe [a]
b (Maybe [a] -> [a]) -> Maybe [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
a [a]
b



-- | Break a list into pieces separated by the first
-- list argument, consuming the delimiter. An empty delimiter is
-- invalid, and will cause an error to be raised.
--
-- >>> splitOn "\r\n" "a\r\nb\r\nd\r\ne"
-- ["a","b","d","e"]
-- >>> splitOn "aaa"  "aaaXaaaXaaaXaaa"
-- ["","X","X","X",""]
-- >>> splitOn "x"    "x"
-- ["",""]
-- >>> splitOn "x"    ""
-- [""]
--
-- prop> \s x -> s /= "" ==> intercalate s (splitOn s x) == x
-- prop> \c x -> splitOn [c] x                           == split (==c) x
splitOn :: Eq a => [a] -> [a] -> [[a]]
splitOn :: [a] -> [a] -> [[a]]
splitOn [] [a]
_ = String -> [[a]]
forall a. HasCallStack => String -> a
error String
"splitOn, needle may not be empty"
splitOn [a]
_ [] = [[]]
splitOn [a]
needle [a]
haystack = [a]
a [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
b then [] else [a] -> [a] -> [[a]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [a]
needle ([a] -> [[a]]) -> [a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
needle) [a]
b
    where ([a]
a,[a]
b) = [a] -> [a] -> ([a], [a])
forall a. Eq a => [a] -> [a] -> ([a], [a])
breakOn [a]
needle [a]
haystack


-- | Splits a list into components delimited by separators,
-- where the predicate returns True for a separator element.  The
-- resulting components do not contain the separators.  Two adjacent
-- separators result in an empty component in the output.
--
-- >>> split (== 'a') "aabbaca"
-- ["","","bb","c",""]
-- >>> split (== 'a') ""
-- [""]
-- >>> split (== ':') "::xyz:abc::123::"
-- ["","","xyz","abc","","123","",""]
-- >>> split (== ',') "my,list,here"
-- ["my","list","here"]
split :: (a -> Bool) -> [a] -> [[a]]
split :: (a -> Bool) -> [a] -> [[a]]
split a -> Bool
_ [] = [[]]
split a -> Bool
f (a
x:[a]
xs)
  | a -> Bool
f a
x = [] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [[a]]
forall a. (a -> Bool) -> [a] -> [[a]]
split a -> Bool
f [a]
xs
  | [a]
y:[[a]]
ys <- (a -> Bool) -> [a] -> [[a]]
forall a. (a -> Bool) -> [a] -> [[a]]
split a -> Bool
f [a]
xs = (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
y) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
ys
  | Bool
otherwise = [[]]


-- | Find the first instance of @needle@ in @haystack@.
-- The first element of the returned tuple
-- is the prefix of @haystack@ before @needle@ is matched.  The second
-- is the remainder of @haystack@, starting with the match.
-- If you want the remainder /without/ the match, use 'stripInfix'.
--
-- >>> breakOn "::" "a::b::c"
-- ("a","::b::c")
-- >>> breakOn "/" "foobar"
-- ("foobar","")
--
-- prop> \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack
breakOn :: Eq a => [a] -> [a] -> ([a], [a])
breakOn :: [a] -> [a] -> ([a], [a])
breakOn [a]
needle [a]
haystack | [a]
needle [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [a]
haystack = ([], [a]
haystack)
breakOn [a]
_ [] = ([], [])
breakOn [a]
needle (a
x:[a]
xs) = ([a] -> [a]) -> ([a], [a]) -> ([a], [a])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (([a], [a]) -> ([a], [a])) -> ([a], [a]) -> ([a], [a])
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> ([a], [a])
forall a. Eq a => [a] -> [a] -> ([a], [a])
breakOn [a]
needle [a]
xs