content: {-# 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
    { orientation :: Orientation
    , tty         :: TTY
    , indent      :: Natural
    , context     :: Maybe Natural
    }
  
  newtype Render a = Render { unRender :: ReaderT RenderContext (Writer Text) a}
      deriving newtype
      ( Functor
      , Applicative
      , Monad
      , MonadReader RenderContext
      , MonadWriter Text
      )
  
  runRender :: Render a -> RenderContext ->  (a, Text)
  runRender render rc = runWriter $  runReaderT render.unRender rc
  
  runRender' :: Render () -> RenderContext -> Text
  runRender' render = snd . runRender render
  
  echo :: Text -> Render ()
  echo text = do
      RenderContext { indent } <- ask
      let n = fromIntegral indent
      tellLn (Text.replicate n " " <> text)
    where
      tellLn line = tell (line <> "\n")
  
  indented :: Natural -> Render a -> Render a
  indented n = local adapt
    where
      adapt context = 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 begin text =
      begin <> Text.intercalate middle (Text.splitOn "\n" text) <> end
    where
      end = "\ESC[0m"
  
      middle = end <> "\n" <> begin
  
  -- | Color text red
  red :: TTY -> Text -> Text
  red  IsTTY text = escape "\ESC[1;31m" text
  red NotTTY text = text
  
  -- | Color text background red
  redBackground  :: Orientation -> TTY -> Text -> Text
  redBackground Line IsTTY text = escape "\ESC[41m" prefix <> suffix
    where
      (prefix, suffix) = Text.break lineBoundary text
  redBackground Word IsTTY text = escape "\ESC[41m" prefix <> suffix
    where
      (prefix, suffix) = Text.break wordBoundary text
  redBackground Character IsTTY text = escape "\ESC[41m" text
  redBackground Line NotTTY text = "- " <> text
  redBackground _    NotTTY text = "←" <> text <> "←"
  
  -- | Color text green
  green :: TTY -> Text -> Text
  green IsTTY  text = escape "\ESC[1;32m" text
  green NotTTY text = text
  
  -- | Color text background green
  greenBackground :: Orientation -> TTY -> Text -> Text
  greenBackground Line IsTTY text = escape "\ESC[42m" prefix <> suffix
    where
      (prefix, suffix) = Text.break lineBoundary text
  greenBackground Word IsTTY text = escape "\ESC[42m" prefix <> suffix
    where
      (prefix, suffix) = Text.break wordBoundary text
  greenBackground Character IsTTY  text = escape "\ESC[42m" text
  greenBackground Line NotTTY text = "+ " <> text
  greenBackground _    NotTTY text = "→" <> text <> "→"
  
  -- | Color text grey
  grey :: Orientation -> TTY -> Text -> Text
  grey _    IsTTY  text = escape "\ESC[1;2m" text
  grey Line NotTTY text = "  " <> text
  grey _    NotTTY text = text
  
  -- | Format the left half of a diff
  minus :: TTY -> Text -> Text
  minus tty text = red tty ("- " <> text)
  
  -- | Format the right half of a diff
  plus :: TTY -> Text -> Text
  plus tty text = green tty ("+ " <> text)
  
  -- | Format text explaining a diff
  explain :: Text -> Text
  explain 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 Changed{..} k = do
      RenderContext { tty } <- ask
      k (minus tty, before)
      k (plus  tty, now)
  
  -- | Format the derivation outputs
  renderOutputs :: OutputNames -> Text
  renderOutputs (OutputNames outputs) =
      ":{" <> Text.intercalate "," (Data.Set.toList outputs) <> "}"
  
  renderDiffHumanReadable :: DerivationDiff -> Render ()
  renderDiffHumanReadable = \case
      DerivationsAreTheSame -> pure ()
      AlreadyCompared ->  echo (explain "These two derivations have already been compared")
      OnlyAlreadyComparedBelow {..} -> do
        renderOutputStructure outputStructure
        echo (explain "Skipping because only derivations that have already been compared and shown in the diff are below")
      NamesDontMatch {..} -> do
        renderOutputStructure outputStructure
        echo (explain "The derivation names do not match")
      OutputsDontMatch {..} -> do
        renderOutputStructure outputStructure
        echo (explain "The requested outputs do not match")
      DerivationDiff {..} -> do
        renderOutputStructure outputStructure
        renderOutputsDiff outputsDiff
        renderPlatformDiff platformDiff
        renderBuilderDiff builderDiff
        renderArgsDiff argumentsDiff
        renderSrcDiff sourcesDiff
        renderInputsDiff inputsDiff
        renderEnvDiff envDiff
  
    where
      renderOutputStructure os =
        renderWith os \(sign, OutputStructure path outputs) -> do
          echo (sign (Store.toText path <> renderOutputs outputs))
  
      renderOutputsDiff OutputsDiff{..} = do
        ifExist extraOutputs \eo -> do
          echo (explain "The set of outputs do not match:")
          renderWith eo \(sign, extraOutputs') -> do
            forM_ (Data.Map.toList extraOutputs') \(key, _value) -> do
                echo ("    " <> sign ("{" <> key <> "}"))
        mapM_ renderOutputHashDiff outputHashDiff
  
      renderOutputHashDiff OutputDiff{..} = do
        echo (explain ("{" <> outputName <> "}:"))
        echo (explain "    Hash algorithm:")
        renderWith hashDifference \(sign, hashAlgo) -> do
            echo ("        " <> sign hashAlgo)
  
      renderPlatformDiff mpd =
        ifExist mpd \pd -> do
          echo (explain "The platforms do not match")
          renderWith pd \(sign, platform) -> do
             echo ("    " <> sign platform)
  
      renderBuilderDiff mbd =
        ifExist mbd \bd -> do
          echo (explain "The builders do not match")
          renderWith bd \(sign, builder) -> do
            echo ("    " <> sign builder)
  
      renderArgsDiff mad =
        ifExist mad \(ArgumentsDiff ad) -> do
          RenderContext { tty } <- ask
          echo (explain "The arguments do not match")
          let renderDiff (Patience.Old arg) =
                  echo ("    " <> minus tty arg)
              renderDiff (Patience.New arg) =
                  echo ("    " <> plus tty arg)
              renderDiff (Patience.Both arg _) =
                  echo ("    " <> explain arg)
          mapM_ renderDiff ad
  
      renderSrcDiff SourcesDiff{..} = do
        ifExist extraSrcNames \esn -> do
          echo (explain "The set of input source names do not match:")
          renderWith esn \(sign, names) -> do
            forM_ names \name -> do
                echo ("    " <> sign name)
  
        mapM_ renderSrcFileDiff srcFilesDiff
  
      renderSrcFileDiff OneSourceFileDiff{..} = do
        echo (explain ("The input source named `" <> srcName <> "` differs"))
        ifExist srcContentDiff \scd -> do
          text <- renderText scd
          echo ("    " <> text)
      renderSrcFileDiff SomeSourceFileDiff{..} = do
        echo (explain ("The input sources named `" <> srcName <> "` differ"))
        renderWith srcFileDiff \(sign, paths) -> do
          forM_ paths \path -> do
              echo ("    " <>  sign (Store.toText path))
  
      renderInputsDiff InputsDiff{..} = do
        renderInputExtraNames inputExtraNames
        mapM_ renderInputDerivationsDiff inputDerivationDiffs
  
      renderInputExtraNames mien =
        ifExist mien \ien -> do
          echo (explain "The set of input derivation names do not match:")
          renderWith ien \(sign, names) -> do
            forM_ names \name -> do
                echo ("    " <> sign name)
  
      renderInputDerivationsDiff OneDerivationDiff{..} = do
        echo (explain ("The input derivation named `" <> drvName <> "` differs"))
        indented 2 (renderDiffHumanReadable drvDiff)
      renderInputDerivationsDiff SomeDerivationsDiff{..} = do
        echo (explain ("The set of input derivations named `" <> drvName <> "` do not match"))
        renderWith extraPartsDiff \(sign, extraPaths) -> do
          forM_ (Data.Map.toList extraPaths) \(extraPath, outputs) -> do
            echo ("    " <> sign (Store.toText extraPath <> renderOutputs outputs))
      renderInputDerivationsDiff ManyDerivationsAlreadyComparedDiff{..} = do
        echo (explain "Input derivations differ but have already been compared")
        forM_ (Data.Set.toList drvNames) \name -> do
          echo ("    " <> name)
  
      renderEnvDiff Nothing =
        echo (explain "Skipping environment comparison")
      renderEnvDiff (Just EnvironmentsAreEqual) = pure ()
      renderEnvDiff (Just EnvironmentDiff{..}) = do
        echo (explain "The environments do not match:")
        renderWith extraEnvDiff \(sign, extraEnv) -> do
          forM_ (Data.Map.toList extraEnv) \(key, value) -> do
              echo ("    " <> sign (key <> "=" <> value))
        forM_ envContentDiff \EnvVarDiff{..} -> do
          text <- renderText envValueDiff
          echo ("    " <> envKey <> "=" <> text)
  
      renderText :: TextDiff -> Render Text
      renderText (TextDiff chunks) = do
        RenderContext{ indent, orientation, tty, context } <- ask
  
        let n = fromIntegral indent
  
        let prefix = Text.replicate n " "
  
        let format text =
                if 80 <= n + Text.length text
                then "''\n" <> indentedText <> prefix <> "''"
                else text
              where
                indentedText =
                    (Text.unlines . fmap indentLine . Text.lines) text
                  where
                    indentLine line = prefix <> "    " <> line
  
        let renderChunk (Patience.Old  l  ) =
                redBackground   orientation tty l
            renderChunk (Patience.New    r) =
                greenBackground orientation tty r
            renderChunk (Patience.Both l _) =
                grey            orientation tty l
  
        let windowedChunks = case context of
                Nothing -> chunks
                Just m  -> fmap middle (filter predicate (zippers chunks))
                  where
                    notBoth (Patience.Both _ _) = False
                    notBoth  _                  = True
  
                    nat = fromIntegral m
  
                    predicate (before, line, after) =
                        any notBoth (line : take nat before ++ take nat after)
  
                    middle (_, line, _) = line
        return (format (Text.concat (fmap renderChunk windowedChunks)))
  
      ifExist m l = maybe (pure ()) l m
  
  zippers :: [a] -> [([a], a, [a])]
  zippers = go []
    where
      go _           []  = []
      go prefix (x : xs) = (prefix, x, xs) : go (x : prefix) xs
  