{-# LANGUAGE LambdaCase #-}
module HMGit.Commands.Porcelain.Diff.Core (
    ShowDiff
  , Diff (..)
  , DiffCfg (..)
  , showDiff
  , diffDefault
) where

import           HMGit.Internal.Core             (HMGitStatus (..), getStatus,
                                                  indexedBlobHashes, loadObject)
import           HMGit.Internal.Core.Runner      (HMGitT)
import           HMGit.Internal.Core.Runner.API  (hmGitRoot)
import           HMGit.Internal.Exceptions       (BugException (..),
                                                  MonadThrowable (..))
import           HMGit.Internal.Parser           (ObjectType (..))
import           HMGit.Internal.Parser.Pathspecs (pathspecs)

import           Control.Exception.Safe          (MonadCatch, catchAny, throw)
import           Control.Monad                   (MonadPlus (..), forM_)
import           Control.Monad.Extra             (whenM)
import           Control.Monad.IO.Class          (MonadIO (..))
import           Control.Monad.Trans             (lift)
import           Data.Algorithm.DiffContext      (getContextDiff,
                                                  prettyContextDiff)
import qualified Data.ByteString.Lazy.UTF8       as BLU
import           Data.Functor                    ((<&>))
import qualified Data.Map.Lazy                   as ML
import qualified Data.Set                        as S
import           Data.Void                       (Void)
import qualified Path                            as P
import qualified Path.IO                         as P
import qualified Text.PrettyPrint                as PP

type ShowDiff = FilePath -- ^ file name
    -> String -- ^ first contents
    -> String -- ^ second contents
    -> String

data DiffCfg = DiffCfg {
    DiffCfg -> ShowDiff
diffShow :: ShowDiff
  , DiffCfg -> [FilePath]
diffPath :: [FilePath]
  }

newtype Diff m = Diff { Diff m -> DiffCfg -> HMGitT m ()
diff :: DiffCfg -> HMGitT m () }

showDiff :: String -- ^ source prefix
    -> String -- ^ destination prefix
    -> ShowDiff
showDiff :: FilePath -> FilePath -> ShowDiff
showDiff FilePath
srcP FilePath
dstP FilePath
fname FilePath
lhs FilePath
rhs = Doc -> FilePath
PP.render
    (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> (FilePath -> Doc) -> ContextDiff FilePath -> Doc
forall c. Doc -> Doc -> (c -> Doc) -> ContextDiff c -> Doc
prettyContextDiff
        (FilePath -> Doc
PP.text (FilePath -> Doc) -> FilePath -> Doc
forall a b. (a -> b) -> a -> b
$ FilePath
srcP FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
fname)
        (FilePath -> Doc
PP.text (FilePath -> Doc) -> FilePath -> Doc
forall a b. (a -> b) -> a -> b
$ FilePath
dstP FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
fname)
        FilePath -> Doc
PP.text
        (Int -> [FilePath] -> [FilePath] -> ContextDiff FilePath
forall a. Eq a => Int -> [a] -> [a] -> ContextDiff a
getContextDiff Int
1 (FilePath -> [FilePath]
lines FilePath
lhs) (FilePath -> [FilePath]
lines FilePath
rhs))

diffDefault :: (MonadIO m, MonadCatch m, MonadPlus m) => Diff m
diffDefault :: Diff m
diffDefault = (DiffCfg -> HMGitT m ()) -> Diff m
forall (m :: * -> *). (DiffCfg -> HMGitT m ()) -> Diff m
Diff ((DiffCfg -> HMGitT m ()) -> Diff m)
-> (DiffCfg -> HMGitT m ()) -> Diff m
forall a b. (a -> b) -> a -> b
$ \DiffCfg
diffCfg -> do
    Path Abs Dir
cDir <- ReaderT HMGitConfig m (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
P.getCurrentDir
    Path Abs Dir
root <- ReaderT HMGitConfig m (Path Abs Dir)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs Dir)
hmGitRoot
    [Path Rel File]
changed <- HMGitT m HMGitStatus
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
HMGitT m HMGitStatus
getStatus HMGitT m HMGitStatus
-> (HMGitStatus -> [Path Rel File])
-> ReaderT HMGitConfig m [Path Rel File]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Set (Path Rel File) -> [Path Rel File]
forall a. Set a -> [a]
S.toList (Set (Path Rel File) -> [Path Rel File])
-> (HMGitStatus -> Set (Path Rel File))
-> HMGitStatus
-> [Path Rel File]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HMGitStatus -> Set (Path Rel File)
statusChanged
    Map (Path Rel File) FilePath
indexed <- HMGitT m (Map (Path Rel File) FilePath)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
HMGitT m (Map (Path Rel File) FilePath)
indexedBlobHashes
    [Path Rel File] -> (Path Rel File -> HMGitT m ()) -> HMGitT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Rel File]
changed ((Path Rel File -> HMGitT m ()) -> HMGitT m ())
-> (Path Rel File -> HMGitT m ()) -> HMGitT m ()
forall a b. (a -> b) -> a -> b
$ \Path Rel File
p -> ReaderT HMGitConfig m Bool -> HMGitT m () -> HMGitT m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Bool
True Bool
-> ReaderT HMGitConfig m FilePath -> ReaderT HMGitConfig m Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Path Abs Dir
-> SomeBase File -> [FilePath] -> ReaderT HMGitConfig m FilePath
forall (m :: * -> *).
(MonadCatch m, MonadIO m, Alternative m) =>
Path Abs Dir -> SomeBase File -> [FilePath] -> HMGitT m FilePath
pathspecs Path Abs Dir
cDir (Path Rel File -> SomeBase File
forall t. Path Rel t -> SomeBase t
P.Rel Path Rel File
p) (DiffCfg -> [FilePath]
diffPath DiffCfg
diffCfg)) ReaderT HMGitConfig m Bool
-> (SomeException -> ReaderT HMGitConfig m Bool)
-> ReaderT HMGitConfig m Bool
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` ReaderT HMGitConfig m Bool
-> SomeException -> ReaderT HMGitConfig m Bool
forall a b. a -> b -> a
const (Bool -> ReaderT HMGitConfig m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)) (HMGitT m () -> HMGitT m ()) -> HMGitT m () -> HMGitT m ()
forall a b. (a -> b) -> a -> b
$
        Maybe Void -> Maybe FilePath -> ReaderT HMGitConfig m FilePath
forall (m :: * -> *) (n :: * -> *) e.
(MonadThrowable m, MonadThrow n, Exception e) =>
Maybe e -> m ~> n
fromMonad (Maybe Void
forall a. Maybe a
Nothing :: Maybe Void) (Path Rel File -> Map (Path Rel File) FilePath -> Maybe FilePath
forall k a. Ord k => k -> Map k a -> Maybe a
ML.lookup Path Rel File
p Map (Path Rel File) FilePath
indexed)
            ReaderT HMGitConfig m FilePath
-> (FilePath -> ReaderT HMGitConfig m (ObjectType, ByteString))
-> ReaderT HMGitConfig m (ObjectType, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ReaderT HMGitConfig m (ObjectType, ByteString)
forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadPlus m) =>
FilePath -> HMGitT m (ObjectType, ByteString)
loadObject
            ReaderT HMGitConfig m (ObjectType, ByteString)
-> ((ObjectType, ByteString) -> HMGitT m ()) -> HMGitT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                (ObjectType
Blob, ByteString
contents) -> let contents' :: FilePath
contents' = ByteString -> FilePath
BLU.toString ByteString
contents in do
                    FilePath
working <- IO FilePath -> ReaderT HMGitConfig m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ReaderT HMGitConfig m FilePath)
-> IO FilePath -> ReaderT HMGitConfig m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
P.toFilePath (Path Abs Dir
root Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> Path Rel File
p)
                    IO () -> HMGitT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                        (IO () -> HMGitT m ()) -> IO () -> HMGitT m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStr
                        (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ DiffCfg -> ShowDiff
diffShow DiffCfg
diffCfg (Path Rel File -> FilePath
forall b t. Path b t -> FilePath
P.toFilePath Path Rel File
p) FilePath
contents' FilePath
working
                (ObjectType, ByteString)
_ -> m () -> HMGitT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
                    (m () -> HMGitT m ()) -> m () -> HMGitT m ()
forall a b. (a -> b) -> a -> b
$ BugException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw
                    (BugException -> m ()) -> BugException -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> BugException
BugException FilePath
"The object loaded by diff is expected to be a blob"