{-# LANGUAGE CPP #-}

module Nix.Diff.Render.HumanReadable where

import Control.Monad (forM_)
import Control.Monad.Reader (MonadReader, ReaderT (runReaderT), ask, local)
import Control.Monad.Writer(MonadWriter, Writer, tell, runWriter)
import Data.Text (Text)
import Numeric.Natural (Natural)

import qualified Control.Monad.Reader
import qualified Data.Map
import qualified Data.Set
import qualified Data.Text            as Text
import qualified Patience

#if !MIN_VERSION_base(4,15,1)
import Control.Monad.Fail (MonadFail)
#endif

import Nix.Diff
import Nix.Diff.Types
import qualified Nix.Diff.Store as Store


data RenderContext = RenderContext
  { RenderContext -> Orientation
orientation :: Orientation
  , RenderContext -> TTY
tty         :: TTY
  , RenderContext -> Natural
indent      :: Natural
  , RenderContext -> Maybe Natural
context     :: Maybe Natural
  }

newtype Render a = Render { forall a. Render a -> ReaderT RenderContext (Writer Text) a
unRender :: ReaderT RenderContext (Writer Text) a}
    deriving newtype
    ( (forall a b. (a -> b) -> Render a -> Render b)
-> (forall a b. a -> Render b -> Render a) -> Functor Render
forall a b. a -> Render b -> Render a
forall a b. (a -> b) -> Render a -> Render b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Render a -> Render b
fmap :: forall a b. (a -> b) -> Render a -> Render b
$c<$ :: forall a b. a -> Render b -> Render a
<$ :: forall a b. a -> Render b -> Render a
Functor
    , Functor Render
Functor Render =>
(forall a. a -> Render a)
-> (forall a b. Render (a -> b) -> Render a -> Render b)
-> (forall a b c.
    (a -> b -> c) -> Render a -> Render b -> Render c)
-> (forall a b. Render a -> Render b -> Render b)
-> (forall a b. Render a -> Render b -> Render a)
-> Applicative Render
forall a. a -> Render a
forall a b. Render a -> Render b -> Render a
forall a b. Render a -> Render b -> Render b
forall a b. Render (a -> b) -> Render a -> Render b
forall a b c. (a -> b -> c) -> Render a -> Render b -> Render c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Render a
pure :: forall a. a -> Render a
$c<*> :: forall a b. Render (a -> b) -> Render a -> Render b
<*> :: forall a b. Render (a -> b) -> Render a -> Render b
$cliftA2 :: forall a b c. (a -> b -> c) -> Render a -> Render b -> Render c
liftA2 :: forall a b c. (a -> b -> c) -> Render a -> Render b -> Render c
$c*> :: forall a b. Render a -> Render b -> Render b
*> :: forall a b. Render a -> Render b -> Render b
$c<* :: forall a b. Render a -> Render b -> Render a
<* :: forall a b. Render a -> Render b -> Render a
Applicative
    , Applicative Render
Applicative Render =>
(forall a b. Render a -> (a -> Render b) -> Render b)
-> (forall a b. Render a -> Render b -> Render b)
-> (forall a. a -> Render a)
-> Monad Render
forall a. a -> Render a
forall a b. Render a -> Render b -> Render b
forall a b. Render a -> (a -> Render b) -> Render b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Render a -> (a -> Render b) -> Render b
>>= :: forall a b. Render a -> (a -> Render b) -> Render b
$c>> :: forall a b. Render a -> Render b -> Render b
>> :: forall a b. Render a -> Render b -> Render b
$creturn :: forall a. a -> Render a
return :: forall a. a -> Render a
Monad
    , MonadReader RenderContext
    , MonadWriter Text
    )

runRender :: Render a -> RenderContext ->  (a, Text)
runRender :: forall a. Render a -> RenderContext -> (a, Text)
runRender Render a
render RenderContext
rc = Writer Text a -> (a, Text)
forall w a. Writer w a -> (a, w)
runWriter (Writer Text a -> (a, Text)) -> Writer Text a -> (a, Text)
forall a b. (a -> b) -> a -> b
$  ReaderT RenderContext (Writer Text) a
-> RenderContext -> Writer Text a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Render a
render.unRender RenderContext
rc

runRender' :: Render () -> RenderContext -> Text
runRender' :: Render () -> RenderContext -> Text
runRender' Render ()
render = ((), Text) -> Text
forall a b. (a, b) -> b
snd (((), Text) -> Text)
-> (RenderContext -> ((), Text)) -> RenderContext -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render () -> RenderContext -> ((), Text)
forall a. Render a -> RenderContext -> (a, Text)
runRender Render ()
render

echo :: Text -> Render ()
echo :: Text -> Render ()
echo Text
text = do
    RenderContext { Natural
$sel:indent:RenderContext :: RenderContext -> Natural
indent :: Natural
indent } <- Render RenderContext
forall r (m :: * -> *). MonadReader r m => m r
ask
    let n :: Int
n = Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
indent
    Text -> Render ()
forall {w} {m :: * -> *}.
(MonadWriter w m, IsString w) =>
w -> m ()
tellLn (Int -> Text -> Text
Text.replicate Int
n Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text)
  where
    tellLn :: w -> m ()
tellLn w
line = w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (w
line w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
"\n")

indented :: Natural -> Render a -> Render a
indented :: forall a. Natural -> Render a -> Render a
indented Natural
n = (RenderContext -> RenderContext) -> Render a -> Render a
forall a. (RenderContext -> RenderContext) -> Render a -> Render a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local RenderContext -> RenderContext
adapt
  where
    adapt :: RenderContext -> RenderContext
adapt RenderContext
context = RenderContext
context { indent = context.indent + n }

data TTY = IsTTY | NotTTY

-- | This exists to improve compatibility with @less -R@.  See:
--
-- https://github.com/Gabriella439/nix-diff/issues/95
escape
    :: Text
    -- ^ Beginning of escape sequence
    -> Text
    -- ^ Text to escape
    -> Text
escape :: Text -> Text -> Text
escape Text
begin Text
text =
    Text
begin Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
middle (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"\n" Text
text) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end
  where
    end :: Text
end = Text
"\ESC[0m"

    middle :: Text
middle = Text
end Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
begin

-- | Color text red
red :: TTY -> Text -> Text
red :: TTY -> Text -> Text
red  TTY
IsTTY Text
text = Text -> Text -> Text
escape Text
"\ESC[1;31m" Text
text
red TTY
NotTTY Text
text = Text
text

-- | Color text background red
redBackground  :: Orientation -> TTY -> Text -> Text
redBackground :: Orientation -> TTY -> Text -> Text
redBackground Orientation
Line TTY
IsTTY Text
text = Text -> Text -> Text
escape Text
"\ESC[41m" Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix
  where
    (Text
prefix, Text
suffix) = (Char -> Bool) -> Text -> (Text, Text)
Text.break Char -> Bool
lineBoundary Text
text
redBackground Orientation
Word TTY
IsTTY Text
text = Text -> Text -> Text
escape Text
"\ESC[41m" Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix
  where
    (Text
prefix, Text
suffix) = (Char -> Bool) -> Text -> (Text, Text)
Text.break Char -> Bool
wordBoundary Text
text
redBackground Orientation
Character TTY
IsTTY Text
text = Text -> Text -> Text
escape Text
"\ESC[41m" Text
text
redBackground Orientation
Line TTY
NotTTY Text
text = Text
"- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text
redBackground Orientation
_    TTY
NotTTY Text
text = Text
"←" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"←"

-- | Color text green
green :: TTY -> Text -> Text
green :: TTY -> Text -> Text
green TTY
IsTTY  Text
text = Text -> Text -> Text
escape Text
"\ESC[1;32m" Text
text
green TTY
NotTTY Text
text = Text
text

-- | Color text background green
greenBackground :: Orientation -> TTY -> Text -> Text
greenBackground :: Orientation -> TTY -> Text -> Text
greenBackground Orientation
Line TTY
IsTTY Text
text = Text -> Text -> Text
escape Text
"\ESC[42m" Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix
  where
    (Text
prefix, Text
suffix) = (Char -> Bool) -> Text -> (Text, Text)
Text.break Char -> Bool
lineBoundary Text
text
greenBackground Orientation
Word TTY
IsTTY Text
text = Text -> Text -> Text
escape Text
"\ESC[42m" Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix
  where
    (Text
prefix, Text
suffix) = (Char -> Bool) -> Text -> (Text, Text)
Text.break Char -> Bool
wordBoundary Text
text
greenBackground Orientation
Character TTY
IsTTY  Text
text = Text -> Text -> Text
escape Text
"\ESC[42m" Text
text
greenBackground Orientation
Line TTY
NotTTY Text
text = Text
"+ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text
greenBackground Orientation
_    TTY
NotTTY Text
text = Text
"→" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"→"

-- | Color text grey
grey :: Orientation -> TTY -> Text -> Text
grey :: Orientation -> TTY -> Text -> Text
grey Orientation
_    TTY
IsTTY  Text
text = Text -> Text -> Text
escape Text
"\ESC[1;2m" Text
text
grey Orientation
Line TTY
NotTTY Text
text = Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text
grey Orientation
_    TTY
NotTTY Text
text = Text
text

-- | Format the left half of a diff
minus :: TTY -> Text -> Text
minus :: TTY -> Text -> Text
minus TTY
tty Text
text = TTY -> Text -> Text
red TTY
tty (Text
"- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text)

-- | Format the right half of a diff
plus :: TTY -> Text -> Text
plus :: TTY -> Text -> Text
plus TTY
tty Text
text = TTY -> Text -> Text
green TTY
tty (Text
"+ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text)

-- | Format text explaining a diff
explain :: Text -> Text
explain :: Text -> Text
explain Text
text = Text
"• " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text

{-| Utility to automate a common pattern of printing the two halves of a diff.
    This passes the correct formatting function to each half
-}
renderWith :: Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()
renderWith :: forall a.
Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()
renderWith Changed{a
before :: a
now :: a
$sel:before:Changed :: forall a. Changed a -> a
$sel:now:Changed :: forall a. Changed a -> a
..} (Text -> Text, a) -> Render ()
k = do
    RenderContext { TTY
$sel:tty:RenderContext :: RenderContext -> TTY
tty :: TTY
tty } <- Render RenderContext
forall r (m :: * -> *). MonadReader r m => m r
ask
    (Text -> Text, a) -> Render ()
k (TTY -> Text -> Text
minus TTY
tty, a
before)
    (Text -> Text, a) -> Render ()
k (TTY -> Text -> Text
plus  TTY
tty, a
now)

-- | Format the derivation outputs
renderOutputs :: OutputNames -> Text
renderOutputs :: OutputNames -> Text
renderOutputs (OutputNames Set Text
outputs) =
    Text
":{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"," (Set Text -> [Text]
forall a. Set a -> [a]
Data.Set.toList Set Text
outputs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"

renderDiffHumanReadable :: DerivationDiff -> Render ()
renderDiffHumanReadable :: DerivationDiff -> Render ()
renderDiffHumanReadable = \case
    DerivationDiff
DerivationsAreTheSame -> () -> Render ()
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    DerivationDiff
AlreadyCompared ->  Text -> Render ()
echo (Text -> Text
explain Text
"These two derivations have already been compared")
    OnlyAlreadyComparedBelow {Changed OutputStructure
outputStructure :: Changed OutputStructure
$sel:outputStructure:DerivationsAreTheSame :: DerivationDiff -> Changed OutputStructure
..} -> do
      Changed OutputStructure -> Render ()
renderOutputStructure Changed OutputStructure
outputStructure
      Text -> Render ()
echo (Text -> Text
explain Text
"Skipping because only derivations that have already been compared and shown in the diff are below")
    NamesDontMatch {Changed OutputStructure
$sel:outputStructure:DerivationsAreTheSame :: DerivationDiff -> Changed OutputStructure
outputStructure :: Changed OutputStructure
..} -> do
      Changed OutputStructure -> Render ()
renderOutputStructure Changed OutputStructure
outputStructure
      Text -> Render ()
echo (Text -> Text
explain Text
"The derivation names do not match")
    OutputsDontMatch {Changed OutputStructure
$sel:outputStructure:DerivationsAreTheSame :: DerivationDiff -> Changed OutputStructure
outputStructure :: Changed OutputStructure
..} -> do
      Changed OutputStructure -> Render ()
renderOutputStructure Changed OutputStructure
outputStructure
      Text -> Render ()
echo (Text -> Text
explain Text
"The requested outputs do not match")
    DerivationDiff {Maybe EnvironmentDiff
Maybe ArgumentsDiff
Maybe (Changed Text)
InputsDiff
SourcesDiff
OutputsDiff
Changed OutputStructure
$sel:outputStructure:DerivationsAreTheSame :: DerivationDiff -> Changed OutputStructure
outputStructure :: Changed OutputStructure
outputsDiff :: OutputsDiff
platformDiff :: Maybe (Changed Text)
builderDiff :: Maybe (Changed Text)
argumentsDiff :: Maybe ArgumentsDiff
sourcesDiff :: SourcesDiff
inputsDiff :: InputsDiff
envDiff :: Maybe EnvironmentDiff
$sel:outputsDiff:DerivationsAreTheSame :: DerivationDiff -> OutputsDiff
$sel:platformDiff:DerivationsAreTheSame :: DerivationDiff -> Maybe (Changed Text)
$sel:builderDiff:DerivationsAreTheSame :: DerivationDiff -> Maybe (Changed Text)
$sel:argumentsDiff:DerivationsAreTheSame :: DerivationDiff -> Maybe ArgumentsDiff
$sel:sourcesDiff:DerivationsAreTheSame :: DerivationDiff -> SourcesDiff
$sel:inputsDiff:DerivationsAreTheSame :: DerivationDiff -> InputsDiff
$sel:envDiff:DerivationsAreTheSame :: DerivationDiff -> Maybe EnvironmentDiff
..} -> do
      Changed OutputStructure -> Render ()
renderOutputStructure Changed OutputStructure
outputStructure
      OutputsDiff -> Render ()
renderOutputsDiff OutputsDiff
outputsDiff
      Maybe (Changed Text) -> Render ()
renderPlatformDiff Maybe (Changed Text)
platformDiff
      Maybe (Changed Text) -> Render ()
renderBuilderDiff Maybe (Changed Text)
builderDiff
      Maybe ArgumentsDiff -> Render ()
renderArgsDiff Maybe ArgumentsDiff
argumentsDiff
      SourcesDiff -> Render ()
renderSrcDiff SourcesDiff
sourcesDiff
      InputsDiff -> Render ()
renderInputsDiff InputsDiff
inputsDiff
      Maybe EnvironmentDiff -> Render ()
renderEnvDiff Maybe EnvironmentDiff
envDiff

  where
    renderOutputStructure :: Changed OutputStructure -> Render ()
renderOutputStructure Changed OutputStructure
os =
      Changed OutputStructure
-> ((Text -> Text, OutputStructure) -> Render ()) -> Render ()
forall a.
Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()
renderWith Changed OutputStructure
os \(Text -> Text
sign, OutputStructure StorePath
path OutputNames
outputs) -> do
        Text -> Render ()
echo (Text -> Text
sign (StorePath -> Text
Store.toText StorePath
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OutputNames -> Text
renderOutputs OutputNames
outputs))

    renderOutputsDiff :: OutputsDiff -> Render ()
renderOutputsDiff OutputsDiff{[OutputDiff]
Maybe (Changed (Map Text (DerivationOutput StorePath Text)))
extraOutputs :: Maybe (Changed (Map Text (DerivationOutput StorePath Text)))
outputHashDiff :: [OutputDiff]
$sel:extraOutputs:OutputsDiff :: OutputsDiff
-> Maybe (Changed (Map Text (DerivationOutput StorePath Text)))
$sel:outputHashDiff:OutputsDiff :: OutputsDiff -> [OutputDiff]
..} = do
      Maybe (Changed (Map Text (DerivationOutput StorePath Text)))
-> (Changed (Map Text (DerivationOutput StorePath Text))
    -> Render ())
-> Render ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
ifExist Maybe (Changed (Map Text (DerivationOutput StorePath Text)))
extraOutputs \Changed (Map Text (DerivationOutput StorePath Text))
eo -> do
        Text -> Render ()
echo (Text -> Text
explain Text
"The set of outputs do not match:")
        Changed (Map Text (DerivationOutput StorePath Text))
-> ((Text -> Text, Map Text (DerivationOutput StorePath Text))
    -> Render ())
-> Render ()
forall a.
Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()
renderWith Changed (Map Text (DerivationOutput StorePath Text))
eo \(Text -> Text
sign, Map Text (DerivationOutput StorePath Text)
extraOutputs') -> do
          [(Text, DerivationOutput StorePath Text)]
-> ((Text, DerivationOutput StorePath Text) -> Render ())
-> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Text (DerivationOutput StorePath Text)
-> [(Text, DerivationOutput StorePath Text)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map Text (DerivationOutput StorePath Text)
extraOutputs') \(Text
key, DerivationOutput StorePath Text
_value) -> do
              Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sign (Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"))
      (OutputDiff -> Render ()) -> [OutputDiff] -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ OutputDiff -> Render ()
renderOutputHashDiff [OutputDiff]
outputHashDiff

    renderOutputHashDiff :: OutputDiff -> Render ()
renderOutputHashDiff OutputDiff{Text
Changed Text
outputName :: Text
hashDifference :: Changed Text
$sel:outputName:OutputDiff :: OutputDiff -> Text
$sel:hashDifference:OutputDiff :: OutputDiff -> Changed Text
..} = do
      Text -> Render ()
echo (Text -> Text
explain (Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
outputName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}:"))
      Text -> Render ()
echo (Text -> Text
explain Text
"    Hash algorithm:")
      Changed Text -> ((Text -> Text, Text) -> Render ()) -> Render ()
forall a.
Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()
renderWith Changed Text
hashDifference \(Text -> Text
sign, Text
hashAlgo) -> do
          Text -> Render ()
echo (Text
"        " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sign Text
hashAlgo)

    renderPlatformDiff :: Maybe (Changed Text) -> Render ()
renderPlatformDiff Maybe (Changed Text)
mpd =
      Maybe (Changed Text) -> (Changed Text -> Render ()) -> Render ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
ifExist Maybe (Changed Text)
mpd \Changed Text
pd -> do
        Text -> Render ()
echo (Text -> Text
explain Text
"The platforms do not match")
        Changed Text -> ((Text -> Text, Text) -> Render ()) -> Render ()
forall a.
Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()
renderWith Changed Text
pd \(Text -> Text
sign, Text
platform) -> do
           Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sign Text
platform)

    renderBuilderDiff :: Maybe (Changed Text) -> Render ()
renderBuilderDiff Maybe (Changed Text)
mbd =
      Maybe (Changed Text) -> (Changed Text -> Render ()) -> Render ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
ifExist Maybe (Changed Text)
mbd \Changed Text
bd -> do
        Text -> Render ()
echo (Text -> Text
explain Text
"The builders do not match")
        Changed Text -> ((Text -> Text, Text) -> Render ()) -> Render ()
forall a.
Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()
renderWith Changed Text
bd \(Text -> Text
sign, Text
builder) -> do
          Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sign Text
builder)

    renderArgsDiff :: Maybe ArgumentsDiff -> Render ()
renderArgsDiff Maybe ArgumentsDiff
mad =
      Maybe ArgumentsDiff -> (ArgumentsDiff -> Render ()) -> Render ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
ifExist Maybe ArgumentsDiff
mad \(ArgumentsDiff NonEmpty (Item Text)
ad) -> do
        RenderContext { TTY
$sel:tty:RenderContext :: RenderContext -> TTY
tty :: TTY
tty } <- Render RenderContext
forall r (m :: * -> *). MonadReader r m => m r
ask
        Text -> Render ()
echo (Text -> Text
explain Text
"The arguments do not match")
        let renderDiff :: Item Text -> Render ()
renderDiff (Patience.Old Text
arg) =
                Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TTY -> Text -> Text
minus TTY
tty Text
arg)
            renderDiff (Patience.New Text
arg) =
                Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TTY -> Text -> Text
plus TTY
tty Text
arg)
            renderDiff (Patience.Both Text
arg Text
_) =
                Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
explain Text
arg)
        (Item Text -> Render ()) -> NonEmpty (Item Text) -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Item Text -> Render ()
renderDiff NonEmpty (Item Text)
ad

    renderSrcDiff :: SourcesDiff -> Render ()
renderSrcDiff SourcesDiff{[SourceFileDiff]
Maybe (Changed (Set Text))
extraSrcNames :: Maybe (Changed (Set Text))
srcFilesDiff :: [SourceFileDiff]
$sel:extraSrcNames:SourcesDiff :: SourcesDiff -> Maybe (Changed (Set Text))
$sel:srcFilesDiff:SourcesDiff :: SourcesDiff -> [SourceFileDiff]
..} = do
      Maybe (Changed (Set Text))
-> (Changed (Set Text) -> Render ()) -> Render ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
ifExist Maybe (Changed (Set Text))
extraSrcNames \Changed (Set Text)
esn -> do
        Text -> Render ()
echo (Text -> Text
explain Text
"The set of input source names do not match:")
        Changed (Set Text)
-> ((Text -> Text, Set Text) -> Render ()) -> Render ()
forall a.
Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()
renderWith Changed (Set Text)
esn \(Text -> Text
sign, Set Text
names) -> do
          Set Text -> (Text -> Render ()) -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set Text
names \Text
name -> do
              Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sign Text
name)

      (SourceFileDiff -> Render ()) -> [SourceFileDiff] -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SourceFileDiff -> Render ()
renderSrcFileDiff [SourceFileDiff]
srcFilesDiff

    renderSrcFileDiff :: SourceFileDiff -> Render ()
renderSrcFileDiff OneSourceFileDiff{Maybe TextDiff
Text
srcName :: Text
srcContentDiff :: Maybe TextDiff
$sel:srcName:OneSourceFileDiff :: SourceFileDiff -> Text
$sel:srcContentDiff:OneSourceFileDiff :: SourceFileDiff -> Maybe TextDiff
..} = do
      Text -> Render ()
echo (Text -> Text
explain (Text
"The input source named `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
srcName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` differs"))
      Maybe TextDiff -> (TextDiff -> Render ()) -> Render ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
ifExist Maybe TextDiff
srcContentDiff \TextDiff
scd -> do
        Text
text <- TextDiff -> Render Text
renderText TextDiff
scd
        Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text)
    renderSrcFileDiff SomeSourceFileDiff{Text
Changed [StorePath]
$sel:srcName:OneSourceFileDiff :: SourceFileDiff -> Text
srcName :: Text
srcFileDiff :: Changed [StorePath]
$sel:srcFileDiff:OneSourceFileDiff :: SourceFileDiff -> Changed [StorePath]
..} = do
      Text -> Render ()
echo (Text -> Text
explain (Text
"The input sources named `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
srcName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` differ"))
      Changed [StorePath]
-> ((Text -> Text, [StorePath]) -> Render ()) -> Render ()
forall a.
Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()
renderWith Changed [StorePath]
srcFileDiff \(Text -> Text
sign, [StorePath]
paths) -> do
        [StorePath] -> (StorePath -> Render ()) -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [StorePath]
paths \StorePath
path -> do
            Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text -> Text
sign (StorePath -> Text
Store.toText StorePath
path))

    renderInputsDiff :: InputsDiff -> Render ()
renderInputsDiff InputsDiff{[InputDerivationsDiff]
Maybe (Changed (Set Text))
inputExtraNames :: Maybe (Changed (Set Text))
inputDerivationDiffs :: [InputDerivationsDiff]
$sel:inputExtraNames:InputsDiff :: InputsDiff -> Maybe (Changed (Set Text))
$sel:inputDerivationDiffs:InputsDiff :: InputsDiff -> [InputDerivationsDiff]
..} = do
      Maybe (Changed (Set Text)) -> Render ()
forall {t :: * -> *}.
Foldable t =>
Maybe (Changed (t Text)) -> Render ()
renderInputExtraNames Maybe (Changed (Set Text))
inputExtraNames
      (InputDerivationsDiff -> Render ())
-> [InputDerivationsDiff] -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ InputDerivationsDiff -> Render ()
renderInputDerivationsDiff [InputDerivationsDiff]
inputDerivationDiffs

    renderInputExtraNames :: Maybe (Changed (t Text)) -> Render ()
renderInputExtraNames Maybe (Changed (t Text))
mien =
      Maybe (Changed (t Text))
-> (Changed (t Text) -> Render ()) -> Render ()
forall {f :: * -> *} {a}.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
ifExist Maybe (Changed (t Text))
mien \Changed (t Text)
ien -> do
        Text -> Render ()
echo (Text -> Text
explain Text
"The set of input derivation names do not match:")
        Changed (t Text)
-> ((Text -> Text, t Text) -> Render ()) -> Render ()
forall a.
Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()
renderWith Changed (t Text)
ien \(Text -> Text
sign, t Text
names) -> do
          t Text -> (Text -> Render ()) -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t Text
names \Text
name -> do
              Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sign Text
name)

    renderInputDerivationsDiff :: InputDerivationsDiff -> Render ()
renderInputDerivationsDiff OneDerivationDiff{Text
DerivationDiff
drvName :: Text
drvDiff :: DerivationDiff
$sel:drvName:OneDerivationDiff :: InputDerivationsDiff -> Text
$sel:drvDiff:OneDerivationDiff :: InputDerivationsDiff -> DerivationDiff
..} = do
      Text -> Render ()
echo (Text -> Text
explain (Text
"The input derivation named `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
drvName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` differs"))
      Natural -> Render () -> Render ()
forall a. Natural -> Render a -> Render a
indented Natural
2 (DerivationDiff -> Render ()
renderDiffHumanReadable DerivationDiff
drvDiff)
    renderInputDerivationsDiff SomeDerivationsDiff{Text
Changed (Map StorePath OutputNames)
$sel:drvName:OneDerivationDiff :: InputDerivationsDiff -> Text
drvName :: Text
extraPartsDiff :: Changed (Map StorePath OutputNames)
$sel:extraPartsDiff:OneDerivationDiff :: InputDerivationsDiff -> Changed (Map StorePath OutputNames)
..} = do
      Text -> Render ()
echo (Text -> Text
explain (Text
"The set of input derivations named `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
drvName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` do not match"))
      Changed (Map StorePath OutputNames)
-> ((Text -> Text, Map StorePath OutputNames) -> Render ())
-> Render ()
forall a.
Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()
renderWith Changed (Map StorePath OutputNames)
extraPartsDiff \(Text -> Text
sign, Map StorePath OutputNames
extraPaths) -> do
        [(StorePath, OutputNames)]
-> ((StorePath, OutputNames) -> Render ()) -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map StorePath OutputNames -> [(StorePath, OutputNames)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map StorePath OutputNames
extraPaths) \(StorePath
extraPath, OutputNames
outputs) -> do
          Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sign (StorePath -> Text
Store.toText StorePath
extraPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OutputNames -> Text
renderOutputs OutputNames
outputs))
    renderInputDerivationsDiff ManyDerivationsAlreadyComparedDiff{Set Text
drvNames :: Set Text
$sel:drvNames:OneDerivationDiff :: InputDerivationsDiff -> Set Text
..} = do
      Text -> Render ()
echo (Text -> Text
explain Text
"Input derivations differ but have already been compared")
      [Text] -> (Text -> Render ()) -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set Text -> [Text]
forall a. Set a -> [a]
Data.Set.toList Set Text
drvNames) \Text
name -> do
        Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)

    renderEnvDiff :: Maybe EnvironmentDiff -> Render ()
renderEnvDiff Maybe EnvironmentDiff
Nothing =
      Text -> Render ()
echo (Text -> Text
explain Text
"Skipping environment comparison")
    renderEnvDiff (Just EnvironmentDiff
EnvironmentsAreEqual) = () -> Render ()
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    renderEnvDiff (Just EnvironmentDiff{[EnvVarDiff]
Changed (Map Text Text)
extraEnvDiff :: Changed (Map Text Text)
envContentDiff :: [EnvVarDiff]
$sel:extraEnvDiff:EnvironmentsAreEqual :: EnvironmentDiff -> Changed (Map Text Text)
$sel:envContentDiff:EnvironmentsAreEqual :: EnvironmentDiff -> [EnvVarDiff]
..}) = do
      Text -> Render ()
echo (Text -> Text
explain Text
"The environments do not match:")
      Changed (Map Text Text)
-> ((Text -> Text, Map Text Text) -> Render ()) -> Render ()
forall a.
Changed a -> ((Text -> Text, a) -> Render ()) -> Render ()
renderWith Changed (Map Text Text)
extraEnvDiff \(Text -> Text
sign, Map Text Text
extraEnv) -> do
        [(Text, Text)] -> ((Text, Text) -> Render ()) -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map Text Text
extraEnv) \(Text
key, Text
value) -> do
            Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sign (Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value))
      [EnvVarDiff] -> (EnvVarDiff -> Render ()) -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [EnvVarDiff]
envContentDiff \EnvVarDiff{Text
TextDiff
envKey :: Text
envValueDiff :: TextDiff
$sel:envKey:EnvVarDiff :: EnvVarDiff -> Text
$sel:envValueDiff:EnvVarDiff :: EnvVarDiff -> TextDiff
..} -> do
        Text
text <- TextDiff -> Render Text
renderText TextDiff
envValueDiff
        Text -> Render ()
echo (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
envKey Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text)

    renderText :: TextDiff -> Render Text
    renderText :: TextDiff -> Render Text
renderText (TextDiff [Item Text]
chunks) = do
      RenderContext{ Natural
$sel:indent:RenderContext :: RenderContext -> Natural
indent :: Natural
indent, Orientation
$sel:orientation:RenderContext :: RenderContext -> Orientation
orientation :: Orientation
orientation, TTY
$sel:tty:RenderContext :: RenderContext -> TTY
tty :: TTY
tty, Maybe Natural
$sel:context:RenderContext :: RenderContext -> Maybe Natural
context :: Maybe Natural
context } <- Render RenderContext
forall r (m :: * -> *). MonadReader r m => m r
ask

      let n :: Int
n = Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
indent

      let prefix :: Text
prefix = Int -> Text -> Text
Text.replicate Int
n Text
" "

      let format :: Text -> Text
format Text
text =
              if Int
80 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
Text.length Text
text
              then Text
"''\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
indentedText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"''"
              else Text
text
            where
              indentedText :: Text
indentedText =
                  ([Text] -> Text
Text.unlines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
indentLine ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines) Text
text
                where
                  indentLine :: Text -> Text
indentLine Text
line = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
line

      let renderChunk :: Item Text -> Text
renderChunk (Patience.Old  Text
l  ) =
              Orientation -> TTY -> Text -> Text
redBackground   Orientation
orientation TTY
tty Text
l
          renderChunk (Patience.New    Text
r) =
              Orientation -> TTY -> Text -> Text
greenBackground Orientation
orientation TTY
tty Text
r
          renderChunk (Patience.Both Text
l Text
_) =
              Orientation -> TTY -> Text -> Text
grey            Orientation
orientation TTY
tty Text
l

      let windowedChunks :: [Item Text]
windowedChunks = case Maybe Natural
context of
              Maybe Natural
Nothing -> [Item Text]
chunks
              Just Natural
m  -> (([Item Text], Item Text, [Item Text]) -> Item Text)
-> [([Item Text], Item Text, [Item Text])] -> [Item Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Item Text], Item Text, [Item Text]) -> Item Text
forall {a} {b} {c}. (a, b, c) -> b
middle ((([Item Text], Item Text, [Item Text]) -> Bool)
-> [([Item Text], Item Text, [Item Text])]
-> [([Item Text], Item Text, [Item Text])]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Item Text], Item Text, [Item Text]) -> Bool
forall {a}. ([Item a], Item a, [Item a]) -> Bool
predicate ([Item Text] -> [([Item Text], Item Text, [Item Text])]
forall a. [a] -> [([a], a, [a])]
zippers [Item Text]
chunks))
                where
                  notBoth :: Item a -> Bool
notBoth (Patience.Both a
_ a
_) = Bool
False
                  notBoth  Item a
_                  = Bool
True

                  nat :: Int
nat = Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
m

                  predicate :: ([Item a], Item a, [Item a]) -> Bool
predicate ([Item a]
before, Item a
line, [Item a]
after) =
                      (Item a -> Bool) -> [Item a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Item a -> Bool
forall {a}. Item a -> Bool
notBoth (Item a
line Item a -> [Item a] -> [Item a]
forall a. a -> [a] -> [a]
: Int -> [Item a] -> [Item a]
forall a. Int -> [a] -> [a]
take Int
nat [Item a]
before [Item a] -> [Item a] -> [Item a]
forall a. [a] -> [a] -> [a]
++ Int -> [Item a] -> [Item a]
forall a. Int -> [a] -> [a]
take Int
nat [Item a]
after)

                  middle :: (a, b, c) -> b
middle (a
_, b
line, c
_) = b
line
      Text -> Render Text
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Text -> Text
format ([Text] -> Text
Text.concat ((Item Text -> Text) -> [Item Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Item Text -> Text
renderChunk [Item Text]
windowedChunks)))

    ifExist :: Maybe a -> (a -> f ()) -> f ()
ifExist Maybe a
m a -> f ()
l = f () -> (a -> f ()) -> Maybe a -> f ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) a -> f ()
l Maybe a
m

zippers :: [a] -> [([a], a, [a])]
zippers :: forall a. [a] -> [([a], a, [a])]
zippers = [a] -> [a] -> [([a], a, [a])]
forall {a}. [a] -> [a] -> [([a], a, [a])]
go []
  where
    go :: [a] -> [a] -> [([a], a, [a])]
go [a]
_           []  = []
    go [a]
prefix (a
x : [a]
xs) = ([a]
prefix, a
x, [a]
xs) ([a], a, [a]) -> [([a], a, [a])] -> [([a], a, [a])]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [([a], a, [a])]
go (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
prefix) [a]
xs