{-# LANGUAGE ExplicitForAll, FlexibleContexts, TupleSections #-}
module HMGit.Internal.Utils (
    strictOne
  , foldMapM
  , foldChoice
  , foldChoiceM
  , first3M
  , makeRelativeEx
  , (?*>)
  , (??)
  , bothM
  , hexStr
) where

import           HMGit.Internal.Exceptions (MonadThrowable (..),
                                            invalidArgument)


import           Control.Applicative       (Alternative (..))
import           Control.Exception.Safe    (Exception, MonadThrow,
                                            StringException (..), throw)
import           Control.Monad             (MonadPlus (..), (>=>))
import           Control.Monad.IO.Class    (MonadIO (..))
import           Data.Foldable             (foldlM)
import qualified Data.List.NonEmpty        as LN
import           Data.Monoid               (Alt (..))
import           Data.MonoTraversable      (Element, MonoFoldable, oconcatMap)
import           Data.Tuple.Extra          (first)
import           GHC.Stack                 (callStack)
import           System.Directory          (canonicalizePath)
import           System.FilePath           (isRelative, makeRelative,
                                            takeDirectory, takeDrive, (</>))
import           Text.Printf               (PrintfArg, printf)

stateEmpty :: (Foldable t, MonadPlus m) => (a, t b) -> m a
stateEmpty :: (a, t b) -> m a
stateEmpty (a, t b)
x
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ t b -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (t b -> Bool) -> t b -> Bool
forall a b. (a -> b) -> a -> b
$ (a, t b) -> t b
forall a b. (a, b) -> b
snd (a, t b)
x = m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    | Bool
otherwise = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ (a, t b) -> a
forall a b. (a, b) -> a
fst (a, t b)
x

nonEmpty :: MonadThrow m => [a] -> m (LN.NonEmpty a)
nonEmpty :: [a] -> m (NonEmpty a)
nonEmpty = Maybe StringException -> Maybe ~> m
forall (m :: * -> *) (n :: * -> *) e.
(MonadThrowable m, MonadThrow n, Exception e) =>
Maybe e -> m ~> n
fromMonad (StringException -> Maybe StringException
forall a. a -> Maybe a
Just (StringException -> Maybe StringException)
-> StringException -> Maybe StringException
forall a b. (a -> b) -> a -> b
$ String -> CallStack -> StringException
StringException String
"a given list is empty" CallStack
HasCallStack => CallStack
callStack)
    (Maybe (NonEmpty a) -> m (NonEmpty a))
-> ([a] -> Maybe (NonEmpty a)) -> [a] -> m (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
LN.nonEmpty

strictOne :: (MonadPlus m, MonadThrow m) => [a] -> m a
strictOne :: [a] -> m a
strictOne = [a] -> m (NonEmpty a)
forall (m :: * -> *) a. MonadThrow m => [a] -> m (NonEmpty a)
nonEmpty ([a] -> m (NonEmpty a)) -> (NonEmpty a -> m a) -> [a] -> m a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (a, [a]) -> m a
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, MonadPlus m) =>
(a, t b) -> m a
stateEmpty ((a, [a]) -> m a) -> (NonEmpty a -> (a, [a])) -> NonEmpty a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> a) -> ([a], [a]) -> (a, [a])
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first [a] -> a
forall a. [a] -> a
head (([a], [a]) -> (a, [a]))
-> (NonEmpty a -> ([a], [a])) -> NonEmpty a -> (a, [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> NonEmpty a -> ([a], [a])
forall a. Int -> NonEmpty a -> ([a], [a])
LN.splitAt Int
1

foldMapM :: (Monad m, Monoid w, Foldable t) => (a -> m w) -> t a -> m w
foldMapM :: (a -> m w) -> t a -> m w
foldMapM a -> m w
f = (w -> a -> m w) -> w -> t a -> m w
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\w
acc a
a -> do { w
w <- a -> m w
f a
a; w -> m w
forall (m :: * -> *) a. Monad m => a -> m a
return (w -> m w) -> w -> m w
forall a b. (a -> b) -> a -> b
$! w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
acc w
w }) w
forall a. Monoid a => a
mempty

foldChoice :: (Foldable t, Alternative f)
    => (a -> f b)
    -> t a
    -> f b
foldChoice :: (a -> f b) -> t a -> f b
foldChoice a -> f b
f = Alt f b -> f b
forall k (f :: k -> *) (a :: k). Alt f a -> f a
getAlt (Alt f b -> f b) -> (t a -> Alt f b) -> t a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Alt f b) -> t a -> Alt f b
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (f b -> Alt f b
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt (f b -> Alt f b) -> (a -> f b) -> a -> Alt f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f)

foldChoiceM :: (Monad m, Alternative f, Foldable t)
    => (a -> m (f b))
    -> t a
    -> m (f b)
foldChoiceM :: (a -> m (f b)) -> t a -> m (f b)
foldChoiceM a -> m (f b)
f = (Alt f b -> f b) -> m (Alt f b) -> m (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Alt f b -> f b
forall k (f :: k -> *) (a :: k). Alt f a -> f a
getAlt (m (Alt f b) -> m (f b)) -> (t a -> m (Alt f b)) -> t a -> m (f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m (Alt f b)) -> t a -> m (Alt f b)
forall (m :: * -> *) w (t :: * -> *) a.
(Monad m, Monoid w, Foldable t) =>
(a -> m w) -> t a -> m w
foldMapM ((f b -> Alt f b) -> m (f b) -> m (Alt f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f b -> Alt f b
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt (m (f b) -> m (Alt f b)) -> (a -> m (f b)) -> a -> m (Alt f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (f b)
f)

{-# INLINE hexStr #-}
hexStr :: (MonoFoldable mono, PrintfArg (Element mono))
    => mono
    -> String
hexStr :: mono -> String
hexStr = (Element mono -> String) -> mono -> String
forall mono m.
(MonoFoldable mono, Monoid m) =>
(Element mono -> m) -> mono -> m
oconcatMap (String -> Element mono -> String
forall r. PrintfType r => String -> r
printf String
"%02x")

first3M :: Functor m => (a -> m a') -> (a, b, c) -> m (a', b, c)
first3M :: (a -> m a') -> (a, b, c) -> m (a', b, c)
first3M a -> m a'
f (a
x,b
y,c
z) = (,b
y,c
z) (a' -> (a', b, c)) -> m a' -> m (a', b, c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m a'
f a
x

newtype DifferentDrives = DifferentDrives String
    deriving Int -> DifferentDrives -> ShowS
[DifferentDrives] -> ShowS
DifferentDrives -> String
(Int -> DifferentDrives -> ShowS)
-> (DifferentDrives -> String)
-> ([DifferentDrives] -> ShowS)
-> Show DifferentDrives
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DifferentDrives] -> ShowS
$cshowList :: [DifferentDrives] -> ShowS
show :: DifferentDrives -> String
$cshow :: DifferentDrives -> String
showsPrec :: Int -> DifferentDrives -> ShowS
$cshowsPrec :: Int -> DifferentDrives -> ShowS
Show

instance Exception DifferentDrives where

-- Inspired by Development.Shake.FilePath.makeRelativeEx
makeRelativeEx :: (MonadIO m, MonadThrow m)
    => FilePath
    -> FilePath
    -> m FilePath
makeRelativeEx :: String -> String -> m String
makeRelativeEx String
pathA String
pathB
    | String -> Bool
isRelative String
makeRelativePathAPathB = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
makeRelativePathAPathB
    | Bool
otherwise = do
        String
a' <- 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 -> IO String
canonicalizePath String
pathA
        String
b' <- 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 -> IO String
canonicalizePath String
pathB
        if ShowS
takeDrive String
a' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= ShowS
takeDrive String
b'
            then DifferentDrives -> m String
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (DifferentDrives -> m String) -> DifferentDrives -> m String
forall a b. (a -> b) -> a -> b
$ String -> DifferentDrives
DifferentDrives String
"Two paths do not exist on the same drive"
            else String -> String -> m String
forall (f :: * -> *). MonadThrow f => String -> String -> f String
makeRelativeEx' String
a' String
b'
    where
        makeRelativePathAPathB :: String
makeRelativePathAPathB = String -> ShowS
makeRelative String
pathA String
pathB

        makeRelativeEx' :: String -> String -> f String
makeRelativeEx' String
a String
b = do
            let rel :: String
rel = String -> ShowS
makeRelative String
a String
b
                parent :: String
parent = ShowS
takeDirectory String
a
            if String -> Bool
isRelative String
rel
                then String -> f String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
rel
                else if String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
parent
                    then (String
".." String -> ShowS
</>) ShowS -> f String -> f String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> f String
makeRelativeEx' String
parent String
b
                    -- Impossible: makeRelative should have succeeded in finding
                    -- a relative path once `a == "/"`.
                    else IOError -> f String
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw
                        (IOError -> f String) -> IOError -> f String
forall a b. (a -> b) -> a -> b
$ String -> IOError
invalidArgument
                        (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                            String
"Error calculating relative path from \""
                           , String
pathA
                           , String
"\" to \""
                           , ShowS
forall a. Show a => a -> String
show String
pathB
                           , String
"\""
                           ]

(?*>) :: Alternative f => Bool -> f a -> f a
Bool
b ?*> :: Bool -> f a -> f a
?*> f a
f = if Bool
b then f a
f else f a
forall (f :: * -> *) a. Alternative f => f a
empty

(??) :: Functor f => f (a -> b) -> a -> f b
f (a -> b)
fab ?? :: f (a -> b) -> a -> f b
?? a
a = ((a -> b) -> b) -> f (a -> b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a) f (a -> b)
fab
{-# INLINE (??) #-}

bothM :: Monad m => (a -> m b) -> (a, a) -> m (b, b)
bothM :: (a -> m b) -> (a, a) -> m (b, b)
bothM a -> m b
f (a
x, a
y) = do
    b
x' <- a -> m b
f a
x
    (b
x',) (b -> (b, b)) -> m b -> m (b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
f a
y