MismatchError.hs

-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{- | Helper utilities for rendering mismatch-type errors.

For cases where it's useful to get a diff-style mismatch report, i.e. where
types can be rendered multi-line, a few override instances are needed.

The diff is produced by printing the types in a multiline format, then computing
the line diff with the standard algorithm (as implemented by the @Diff@
package).

In general, assuming the type in question is @T@, those instances
can look like this:

@
instance Buildable (MismatchError T) where
  build = buildRenderDocExtended

instance RenderDoc (MismatchError T) where
  renderDoc ctx = renderDocDiff ctx . fmap Prettier
@

The @fmap Prettier@ part is only required to enable multi-line rendering.

Additionally, if there's a need to show mismatch errors for lists, the following
instance can be used:

@
instance RenderDoc (MismatchError [T]) where
  renderDoc ctx = renderDocDiffList ctx . (fmap . fmap) Prettier
@
-}
module Morley.Util.MismatchError
  ( MismatchError(..)
  , renderDocDiff
  , renderDocDiffList
  ) where

import Prelude hiding (First, (<$>))

import Data.Algorithm.Diff (PolyDiff(..), getDiffBy)
import Data.Text.Lazy as LT (lines, strip)
import Fmt (Buildable(..), nameF)
import Text.PrettyPrint.Leijen.Text (Doc, align, fill, indent, text, vcat, (<$>), (<+>))

import Morley.Michelson.Printer.Util

-- | A helper record datatype representing a mismatch between two values of
-- some type. One is assumed to be in some sense the "expected" value, the other
-- one is assumed to be the "actual" value.
data MismatchError a = MkMismatchError
  { meExpected :: a -- ^ Expected value
  , meActual :: a -- ^ Actual value
  } deriving stock (Show, Eq, Generic, Functor, Foldable)
    deriving anyclass (NFData, Container)

instance {-# OVERLAPPABLE #-} Buildable a => Buildable (MismatchError a) where
  build MkMismatchError{..} =
    nameF "Expected" (build meExpected) <> nameF "Actual" (build meActual)

instance {-# OVERLAPPABLE #-} RenderDoc a => RenderDoc (MismatchError a) where
  renderDoc = renderDocStandard

renderDocStandard :: RenderDoc a => RenderContext -> MismatchError a -> Doc
renderDocStandard _ (fmap (align . renderDoc doesntNeedParens) -> MkMismatchError{..})
  =   fill 9 "Expected:" <+> meExpected
  <$> fill 9 "Actual:"   <+> meActual

renderDocStandardList :: RenderDoc a => RenderContext -> MismatchError [a] -> Doc
renderDocStandardList _ (fmap (align . renderDocList doesntNeedParens) -> MkMismatchError{..})
  =   fill 9 "Expected:" <+> meExpected
  <$> fill 9 "Actual:"   <+> meActual

-- | Render a mismatch error with a diff.
--
-- This is intended to be used with types for which 'RenderDoc' outputs
-- multiline 'Doc'. Generally those are types wrapped in 'Prettier'.
renderDocDiff :: RenderDoc a => RenderContext -> MismatchError a -> Doc
renderDocDiff ctx err = renderDocStandard ctx err
  <$> if expectedAndActualBothSingleLine
      then mempty
      else "Mismatch:"
       <$> indent 2 "--- expected +++ actual"
       <$> align (diff errText)
  where
    errText = fmap (renderDoc doesntNeedParens) err
    expectedAndActualBothSingleLine = all (null . drop 1 . LT.lines . printDoc False) errText

-- | Render a mismatch error of lists with a diff.
--
-- This is intended to be used with types for which 'RenderDoc' outputs
-- multiline 'Doc'. Generally those are types wrapped in 'Prettier'.
renderDocDiffList :: RenderDoc a => RenderContext -> MismatchError [a] -> Doc
renderDocDiffList ctx err = renderDocStandardList ctx err
  <$> if simple
      then mempty
      else "Mismatch:"
       <$> indent 2 "--- expected +++ actual"
       <$> align (diff errText)
  where
    errText = fmap (renderList' . map (align . renderDoc doesntNeedParens)) err
    -- "simple" here means that at least one is true:
    --
    -- * one of the lists is empty
    -- * rendered representation for both expected and actual types are single-line
    simple = any null err || all (null . drop 1 . LT.lines . printDoc False) errText
    renderList' ds
      = case ds of
          []  -> "[]"
          [d] -> align $ "[ " <> d <> " ]"
          _   -> align $ vcat (zipWith (<>) ("[ " : repeat ", ") ds) <$> "]"

diff :: MismatchError Doc -> Doc
diff (fmap $ LT.lines . printDoc False -> MkMismatchError{..}) = vcat $
  showLine `fmap` getDiffBy ((==) `on` LT.strip) meExpected meActual
  where
    showLine = \case
      (Both _ b) -> indent 2 $ text b
      (First x) -> "-" <+> text x
      (Second x) -> "+" <+> text x