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(..)
  , buildDocDiff
  , buildDocDiffList
  ) where

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

import Data.Algorithm.Diff (PolyDiff(..), getDiffBy)
import Data.Text.Lazy as LT (lines, strip)
import Fmt (Buildable(..), Doc, unlessF, (<+>))
import Prettyprinter (align, fill, hardline, indent, line, 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 = buildStandard

buildStandard :: Buildable a => MismatchError a -> Doc
buildStandard = buildDoc . fmap build

buildStandardList :: Buildable a => MismatchError [a] -> Doc
buildStandardList = buildDoc . fmap buildList

buildDoc :: MismatchError Doc -> Doc
buildDoc MkMismatchError{..}
  =  fill 9 "Expected:" <+> align meExpected <> hardline
  <> fill 9 "Actual:"   <+> align meActual

renderMismatch :: MismatchError Doc -> Doc
renderMismatch errText
  =  hardline <> "Mismatch:" <> hardline
  <> indent 2 "--- expected +++ actual" <> hardline
  <> align (diff errText)

-- | Render a mismatch error with a diff.
--
-- This is intended to be used with types for which 'RenderDoc' outputs
-- multiline 'Doc'.
buildDocDiff :: Buildable a => MismatchError a -> Doc
buildDocDiff err = buildStandard err
  <> unlessF expectedAndActualBothSingleLine (renderMismatch errText)
  where
    errText = fmap build err
    expectedAndActualBothSingleLine = all (null . drop 1 . LT.lines . printRenderDoc 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'.
buildDocDiffList :: Buildable a => MismatchError [a] -> Doc
buildDocDiffList err = buildStandardList err
  <> unlessF simple (renderMismatch errText)
  where
    errText = fmap (renderList' . map (align . build)) 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 . printRenderDoc False) errText
    renderList' ds
      = case ds of
          []  -> "[]"
          [d] -> align $ "[ " <> d <> " ]"
          _   -> align $ vcat (zipWith (<>) ("[ " : repeat ", ") ds) <> line <> "]"

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