{- | The types in 'Generic.Diff' have derived 'Show' instances that don't help at all in
one of the goals for the library, which is readability. This module lets us render those types
in a friendly way.
-}
module Generics.Diff.Render
  ( -- * Rendering
    renderDiffResult
  , renderDiffResultWith

    -- * Printing
  , printDiffResult
  , printDiffResultWith

    -- * Options
  , RenderOpts
  , defaultRenderOpts
  , indentSize
  , numberedLevels

    -- * Helper rendering functions
  , renderDiffError
  , renderDiffErrorWith
  , renderDiffErrorNested
  , renderDiffErrorNestedWith
  , renderListDiffError
  , renderListDiffErrorWith
  )
where

import Data.SOP.NS
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TB
import qualified Data.Text.Lazy.IO as TL
import Generics.Diff.Type
import Generics.SOP as SOP
import Numeric.Natural

{- | Configuration type used to tweak the output of 'renderDiffResultWith'.

Use 'defaultRenderOpts' and the field accessors below to construct.
-}
data RenderOpts = RenderOpts
  { RenderOpts -> Natural
indentSize :: Natural
  -- ^ How many spaces to indent each new "level" of comparison.
  , RenderOpts -> Bool
numberedLevels :: Bool
  -- ^ Whether or not to include level numbers in the output.
  }
  deriving (Int -> RenderOpts -> ShowS
[RenderOpts] -> ShowS
RenderOpts -> String
(Int -> RenderOpts -> ShowS)
-> (RenderOpts -> String)
-> ([RenderOpts] -> ShowS)
-> Show RenderOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RenderOpts -> ShowS
showsPrec :: Int -> RenderOpts -> ShowS
$cshow :: RenderOpts -> String
show :: RenderOpts -> String
$cshowList :: [RenderOpts] -> ShowS
showList :: [RenderOpts] -> ShowS
Show)

-- | Sensible rendering defaults. No numbers, 2-space indentation.
defaultRenderOpts :: RenderOpts
defaultRenderOpts :: RenderOpts
defaultRenderOpts =
  RenderOpts
    { indentSize :: Natural
indentSize = Natural
2
    , numberedLevels :: Bool
numberedLevels = Bool
False
    }

-- | Print a 'DiffResult' to the terminal.
printDiffResult :: DiffResult a -> IO ()
printDiffResult :: forall a. DiffResult a -> IO ()
printDiffResult = RenderOpts -> DiffResult a -> IO ()
forall a. RenderOpts -> DiffResult a -> IO ()
printDiffResultWith RenderOpts
defaultRenderOpts

-- | Print a 'DiffResult' to the terminal, using custom 'RenderOpts'.
printDiffResultWith :: RenderOpts -> DiffResult a -> IO ()
printDiffResultWith :: forall a. RenderOpts -> DiffResult a -> IO ()
printDiffResultWith RenderOpts
opts =
  Text -> IO ()
TL.putStrLn (Text -> IO ()) -> (DiffResult a -> Text) -> DiffResult a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TB.toLazyText (Builder -> Text)
-> (DiffResult a -> Builder) -> DiffResult a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderOpts -> DiffResult a -> Builder
forall a. RenderOpts -> DiffResult a -> Builder
renderDiffResultWith RenderOpts
opts

-- | Render a 'DiffResult' using a lazy 'TB.Builder'.
renderDiffResult :: DiffResult a -> TB.Builder
renderDiffResult :: forall a. DiffResult a -> Builder
renderDiffResult = RenderOpts -> DiffResult a -> Builder
forall a. RenderOpts -> DiffResult a -> Builder
renderDiffResultWith RenderOpts
defaultRenderOpts

-- | Render a 'DiffResult' using a lazy 'TB.Builder', using custom 'RenderOpts'.
renderDiffResultWith :: RenderOpts -> DiffResult a -> TB.Builder
renderDiffResultWith :: forall a. RenderOpts -> DiffResult a -> Builder
renderDiffResultWith RenderOpts
opts = RenderOpts -> RDiffResult -> Builder
renderRDiffResultWith RenderOpts
opts (RDiffResult -> Builder)
-> (DiffResult a -> RDiffResult) -> DiffResult a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffResult a -> RDiffResult
forall a. DiffResult a -> RDiffResult
diffResultR

-- | Render a 'DiffError' using a lazy 'TB.Builder'.
renderDiffError :: DiffError a -> TB.Builder
renderDiffError :: forall a. DiffError a -> Builder
renderDiffError = RenderOpts -> DiffError a -> Builder
forall a. RenderOpts -> DiffError a -> Builder
renderDiffErrorWith RenderOpts
defaultRenderOpts

-- | Render a 'DiffError' using a lazy 'TB.Builder', using custom 'RenderOpts'.
renderDiffErrorWith :: RenderOpts -> DiffError a -> TB.Builder
renderDiffErrorWith :: forall a. RenderOpts -> DiffError a -> Builder
renderDiffErrorWith RenderOpts
opts = RenderOpts -> Int -> RDiffError -> Builder
renderRDiffErrorWith RenderOpts
opts Int
0 (RDiffError -> Builder)
-> (DiffError a -> RDiffError) -> DiffError a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffError a -> RDiffError
forall a. DiffError a -> RDiffError
diffErrorR

-- | Render a 'DiffErrorNested' using a lazy 'TB.Builder'.
renderDiffErrorNested :: DiffErrorNested xss -> TB.Builder
renderDiffErrorNested :: forall (xss :: [[*]]). DiffErrorNested xss -> Builder
renderDiffErrorNested = RenderOpts -> DiffErrorNested xss -> Builder
forall (xss :: [[*]]). RenderOpts -> DiffErrorNested xss -> Builder
renderDiffErrorNestedWith RenderOpts
defaultRenderOpts

-- | Render a 'DiffErrorNested' using a lazy 'TB.Builder', using custom 'RenderOpts'.
renderDiffErrorNestedWith :: RenderOpts -> DiffErrorNested xss -> TB.Builder
renderDiffErrorNestedWith :: forall (xss :: [[*]]). RenderOpts -> DiffErrorNested xss -> Builder
renderDiffErrorNestedWith RenderOpts
opts = RenderOpts -> Int -> RDiffErrorNested -> Builder
renderRDiffErrorNested RenderOpts
opts Int
0 (RDiffErrorNested -> Builder)
-> (DiffErrorNested xss -> RDiffErrorNested)
-> DiffErrorNested xss
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffErrorNested xss -> RDiffErrorNested
forall (a :: [[*]]). DiffErrorNested a -> RDiffErrorNested
diffErrorNestedR

-- | Render a 'ListDiffError' using a lazy 'TB.Builder'.
renderListDiffError :: ListDiffError xss -> TB.Builder
renderListDiffError :: forall xss. ListDiffError xss -> Builder
renderListDiffError = RenderOpts -> ListDiffError xss -> Builder
forall xss. RenderOpts -> ListDiffError xss -> Builder
renderListDiffErrorWith RenderOpts
defaultRenderOpts

-- | Render a 'ListDiffError' using a lazy 'TB.Builder', using custom 'RenderOpts'.
renderListDiffErrorWith :: RenderOpts -> ListDiffError xss -> TB.Builder
renderListDiffErrorWith :: forall xss. RenderOpts -> ListDiffError xss -> Builder
renderListDiffErrorWith RenderOpts
opts = RenderOpts -> Builder -> Int -> RListDiffError -> Builder
renderRListDiffError RenderOpts
opts Builder
"list" Int
0 (RListDiffError -> Builder)
-> (ListDiffError xss -> RListDiffError)
-> ListDiffError xss
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListDiffError xss -> RListDiffError
forall a. ListDiffError a -> RListDiffError
listDiffErrorR

------------------------------------------------------------
-- Intermediate representation
-- Rendering a 'DiffResult' happens in two steps: converting our strict SOP types into a much simpler
-- intermediate representation, and then laying them out in a nice way.

type RConstructorName = TB.Builder

type RFieldName = TB.Builder

data RDiffResult
  = RError RDiffError
  | REqual

data InfixSide = ILeft | IRight

data RField
  = IdxField Int
  | InfixField InfixSide
  | RecordField RFieldName

data RDiffErrorNested
  = RWrongConstructor RConstructorName RConstructorName
  | RFieldMismatch RConstructorName RField RDiffError

data RDiffError where
  RTopLevelNotEqual :: RDiffError
  RNested :: RDiffErrorNested -> RDiffError
  RDiffList :: RListDiffError -> RDiffError
  RDiffNonEmpty :: RListDiffError -> RDiffError

data RListDiffError
  = RDiffAtIndex Int RDiffError
  | RWrongLengths Int Int

diffResultR :: DiffResult a -> RDiffResult
diffResultR :: forall a. DiffResult a -> RDiffResult
diffResultR = \case
  DiffResult a
Equal -> RDiffResult
REqual
  Error DiffError a
err -> RDiffError -> RDiffResult
RError (RDiffError -> RDiffResult) -> RDiffError -> RDiffResult
forall a b. (a -> b) -> a -> b
$ DiffError a -> RDiffError
forall a. DiffError a -> RDiffError
diffErrorR DiffError a
err

diffErrorR :: DiffError a -> RDiffError
diffErrorR :: forall a. DiffError a -> RDiffError
diffErrorR = \case
  DiffError a
TopLevelNotEqual -> RDiffError
RTopLevelNotEqual
  Nested DiffErrorNested (Code a)
nested -> RDiffErrorNested -> RDiffError
RNested (RDiffErrorNested -> RDiffError) -> RDiffErrorNested -> RDiffError
forall a b. (a -> b) -> a -> b
$ DiffErrorNested (Code a) -> RDiffErrorNested
forall (a :: [[*]]). DiffErrorNested a -> RDiffErrorNested
diffErrorNestedR DiffErrorNested (Code a)
nested
  DiffList ListDiffError a1
list -> RListDiffError -> RDiffError
RDiffList (RListDiffError -> RDiffError) -> RListDiffError -> RDiffError
forall a b. (a -> b) -> a -> b
$ ListDiffError a1 -> RListDiffError
forall a. ListDiffError a -> RListDiffError
listDiffErrorR ListDiffError a1
list
  DiffNonEmpty ListDiffError a1
list -> RListDiffError -> RDiffError
RDiffNonEmpty (RListDiffError -> RDiffError) -> RListDiffError -> RDiffError
forall a b. (a -> b) -> a -> b
$ ListDiffError a1 -> RListDiffError
forall a. ListDiffError a -> RListDiffError
listDiffErrorR ListDiffError a1
list

diffErrorNestedR :: DiffErrorNested a -> RDiffErrorNested
diffErrorNestedR :: forall (a :: [[*]]). DiffErrorNested a -> RDiffErrorNested
diffErrorNestedR = \case
  WrongConstructor NS ConstructorInfo a
l NS ConstructorInfo a
r ->
    let cName :: NS ConstructorInfo xs -> Builder
cName = NS (K Builder) xs -> Builder
forall {k} a (xs :: [k]). NS (K a) xs -> a
collapse_NS (NS (K Builder) xs -> Builder)
-> (NS ConstructorInfo xs -> NS (K Builder) xs)
-> NS ConstructorInfo xs
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (a :: [*]). ConstructorInfo a -> K Builder a)
-> NS ConstructorInfo xs -> NS (K Builder) xs
forall {k} (f :: k -> *) (g :: k -> *) (xs :: [k]).
(forall (a :: k). f a -> g a) -> NS f xs -> NS g xs
liftANS (Builder -> K Builder a
forall k a (b :: k). a -> K a b
K (Builder -> K Builder a)
-> (ConstructorInfo a -> Builder)
-> ConstructorInfo a
-> K Builder a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo a -> Builder
forall (xs :: [*]). ConstructorInfo xs -> Builder
constructorNameR)
    in  Builder -> Builder -> RDiffErrorNested
RWrongConstructor (NS ConstructorInfo a -> Builder
forall {xs :: [[*]]}. NS ConstructorInfo xs -> Builder
cName NS ConstructorInfo a
l) (NS ConstructorInfo a -> Builder
forall {xs :: [[*]]}. NS ConstructorInfo xs -> Builder
cName NS ConstructorInfo a
r)
  FieldMismatch (DiffAtField NS (ConstructorInfo :*: NS DiffError) a
ns) ->
    let (Builder
cName, RField
fieldLoc, RDiffError
err) =
          NS (K (Builder, RField, RDiffError)) a
-> (Builder, RField, RDiffError)
forall {k} a (xs :: [k]). NS (K a) xs -> a
collapse_NS (NS (K (Builder, RField, RDiffError)) a
 -> (Builder, RField, RDiffError))
-> NS (K (Builder, RField, RDiffError)) a
-> (Builder, RField, RDiffError)
forall a b. (a -> b) -> a -> b
$
            (forall (a :: [*]).
 (:*:) ConstructorInfo (NS DiffError) a
 -> K (Builder, RField, RDiffError) a)
-> NS (ConstructorInfo :*: NS DiffError) a
-> NS (K (Builder, RField, RDiffError)) a
forall {k} (f :: k -> *) (g :: k -> *) (xs :: [k]).
(forall (a :: k). f a -> g a) -> NS f xs -> NS g xs
liftANS (\(ConstructorInfo a
cInfo :*: NS DiffError a
nsErr) -> (Builder, RField, RDiffError) -> K (Builder, RField, RDiffError) a
forall k a (b :: k). a -> K a b
K (ConstructorInfo a
-> NS DiffError a -> (Builder, RField, RDiffError)
forall (xs :: [*]).
ConstructorInfo xs
-> NS DiffError xs -> (Builder, RField, RDiffError)
unpackAtLocErr ConstructorInfo a
cInfo NS DiffError a
nsErr)) NS (ConstructorInfo :*: NS DiffError) a
ns
    in  Builder -> RField -> RDiffError -> RDiffErrorNested
RFieldMismatch Builder
cName RField
fieldLoc RDiffError
err

constructorNameR :: ConstructorInfo xs -> RConstructorName
constructorNameR :: forall (xs :: [*]). ConstructorInfo xs -> Builder
constructorNameR = \case
  Constructor String
name -> String -> Builder
TB.fromString String
name
  Infix String
name Associativity
_ Int
_ -> Builder
"(" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"
  Record String
name NP FieldInfo xs
_ -> String -> Builder
TB.fromString String
name

unpackAtLocErr :: forall xs. ConstructorInfo xs -> NS DiffError xs -> (RConstructorName, RField, RDiffError)
unpackAtLocErr :: forall (xs :: [*]).
ConstructorInfo xs
-> NS DiffError xs -> (Builder, RField, RDiffError)
unpackAtLocErr ConstructorInfo xs
cInfo NS DiffError xs
nsErr =
  let err :: RDiffError
err = NS (K RDiffError) xs -> RDiffError
forall {k} a (xs :: [k]). NS (K a) xs -> a
collapse_NS (NS (K RDiffError) xs -> RDiffError)
-> NS (K RDiffError) xs -> RDiffError
forall a b. (a -> b) -> a -> b
$ (forall a. DiffError a -> K RDiffError a)
-> NS DiffError xs -> NS (K RDiffError) xs
forall {k} (f :: k -> *) (g :: k -> *) (xs :: [k]).
(forall (a :: k). f a -> g a) -> NS f xs -> NS g xs
liftANS (RDiffError -> K RDiffError a
forall k a (b :: k). a -> K a b
K (RDiffError -> K RDiffError a)
-> (DiffError a -> RDiffError) -> DiffError a -> K RDiffError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffError a -> RDiffError
forall a. DiffError a -> RDiffError
diffErrorR) NS DiffError xs
nsErr
  in  case ConstructorInfo xs
cInfo of
        Constructor String
name -> (String -> Builder
TB.fromString String
name, Int -> RField
IdxField (Int -> RField) -> Int -> RField
forall a b. (a -> b) -> a -> b
$ NS DiffError xs -> Int
forall {k} (f :: k -> *) (xs :: [k]). NS f xs -> Int
index_NS NS DiffError xs
nsErr, RDiffError
err)
        Infix String
name Associativity
_ Int
_ ->
          let side :: InfixSide
side = case NS DiffError xs
nsErr of
                Z DiffError x
_ -> InfixSide
ILeft
                S NS DiffError xs
_ -> InfixSide
IRight
          in  (Builder
"(" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
TB.fromString String
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")", InfixSide -> RField
InfixField InfixSide
side, RDiffError
err)
        Record String
name NP FieldInfo xs
fields ->
          let fName :: Builder
fName = NS (K Builder) xs -> Builder
forall {k} a (xs :: [k]). NS (K a) xs -> a
collapse_NS (NS (K Builder) xs -> Builder) -> NS (K Builder) xs -> Builder
forall a b. (a -> b) -> a -> b
$ (forall a. FieldInfo a -> K Builder a)
-> NS FieldInfo xs -> NS (K Builder) xs
forall {k} (f :: k -> *) (g :: k -> *) (xs :: [k]).
(forall (a :: k). f a -> g a) -> NS f xs -> NS g xs
liftANS (Builder -> K Builder a
forall k a (b :: k). a -> K a b
K (Builder -> K Builder a)
-> (FieldInfo a -> Builder) -> FieldInfo a -> K Builder a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
TB.fromString (String -> Builder)
-> (FieldInfo a -> String) -> FieldInfo a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo a -> String
forall a. FieldInfo a -> String
fieldName) (NS FieldInfo xs -> NS (K Builder) xs)
-> NS FieldInfo xs -> NS (K Builder) xs
forall a b. (a -> b) -> a -> b
$ NP FieldInfo xs -> NS DiffError xs -> NS FieldInfo xs
forall {k} (f :: k -> *) (xs :: [k]) (g :: k -> *).
NP f xs -> NS g xs -> NS f xs
pickOut NP FieldInfo xs
fields NS DiffError xs
nsErr
          in  (String -> Builder
TB.fromString String
name, Builder -> RField
RecordField Builder
fName, RDiffError
err)

listDiffErrorR :: ListDiffError a -> RListDiffError
listDiffErrorR :: forall a. ListDiffError a -> RListDiffError
listDiffErrorR = \case
  DiffAtIndex Int
idx DiffError a
err -> Int -> RDiffError -> RListDiffError
RDiffAtIndex Int
idx (RDiffError -> RListDiffError) -> RDiffError -> RListDiffError
forall a b. (a -> b) -> a -> b
$ DiffError a -> RDiffError
forall a. DiffError a -> RDiffError
diffErrorR DiffError a
err
  WrongLengths Int
l Int
r -> Int -> Int -> RListDiffError
RWrongLengths Int
l Int
r

renderRDiffResultWith :: RenderOpts -> RDiffResult -> TB.Builder
renderRDiffResultWith :: RenderOpts -> RDiffResult -> Builder
renderRDiffResultWith RenderOpts
opts = \case
  RDiffResult
REqual -> Builder
"Equal"
  RError RDiffError
err -> RenderOpts -> Int -> RDiffError -> Builder
renderRDiffErrorWith RenderOpts
opts Int
0 RDiffError
err

renderRDiffErrorWith :: RenderOpts -> Int -> RDiffError -> TB.Builder
renderRDiffErrorWith :: RenderOpts -> Int -> RDiffError -> Builder
renderRDiffErrorWith RenderOpts
opts Int
ind = \case
  RDiffError
RTopLevelNotEqual -> Builder
firstIndent Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"Not equal"
  RNested RDiffErrorNested
den -> RenderOpts -> Int -> RDiffErrorNested -> Builder
renderRDiffErrorNested RenderOpts
opts Int
ind RDiffErrorNested
den
  RDiffList RListDiffError
listErr -> RenderOpts -> Builder -> Int -> RListDiffError -> Builder
renderRListDiffError RenderOpts
opts Builder
"list" Int
ind RListDiffError
listErr
  RDiffNonEmpty RListDiffError
listErr -> RenderOpts -> Builder -> Int -> RListDiffError -> Builder
renderRListDiffError RenderOpts
opts Builder
"non-empty list" Int
ind RListDiffError
listErr
  where
    firstIndent :: Builder
firstIndent = RenderOpts -> Bool -> Int -> Builder
mkIndent RenderOpts
opts Bool
True Int
ind

renderRListDiffError :: RenderOpts -> TB.Builder -> Int -> RListDiffError -> TB.Builder
renderRListDiffError :: RenderOpts -> Builder -> Int -> RListDiffError -> Builder
renderRListDiffError RenderOpts
opts Builder
lst Int
ind = \case
  RDiffAtIndex Int
idx RDiffError
err ->
    (Builder
firstIndent Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"Diff at " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
lst Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" index " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall a. Show a => a -> Builder
showR Int
idx Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" (0-indexed)\n")
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> RenderOpts -> Int -> RDiffError -> Builder
renderRDiffErrorWith RenderOpts
opts (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) RDiffError
err
  RWrongLengths Int
l Int
r ->
    (Builder
firstIndent Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"Lists are wrong lengths\n")
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Builder
otherIndent Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"Length of left list: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall a. Show a => a -> Builder
showR Int
l Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n")
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Builder
otherIndent Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"Length of right list: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall a. Show a => a -> Builder
showR Int
r)
  where
    otherIndent :: Builder
otherIndent = RenderOpts -> Bool -> Int -> Builder
mkIndent RenderOpts
opts Bool
False Int
ind
    firstIndent :: Builder
firstIndent = RenderOpts -> Bool -> Int -> Builder
mkIndent RenderOpts
opts Bool
True Int
ind

renderRDiffErrorNested :: RenderOpts -> Int -> RDiffErrorNested -> TB.Builder
renderRDiffErrorNested :: RenderOpts -> Int -> RDiffErrorNested -> Builder
renderRDiffErrorNested RenderOpts
opts Int
ind = \case
  RWrongConstructor Builder
lCons Builder
rCons ->
    (Builder
firstIndent Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"Wrong constructor\n")
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Builder
otherIndent Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"Constructor of left value: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
lCons Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n")
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Builder
otherIndent Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"Constructor of right value: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
rCons)
  RFieldMismatch Builder
cName RField
fieldLoc RDiffError
err ->
    (Builder
firstIndent Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"Both values use constructor " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cName Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" but fields don't match\n")
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Builder
otherIndent Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> RField -> Builder
renderRField RField
fieldLoc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> RenderOpts -> Int -> RDiffError -> Builder
renderRDiffErrorWith RenderOpts
opts (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) RDiffError
err)
  where
    firstIndent :: Builder
firstIndent = RenderOpts -> Bool -> Int -> Builder
mkIndent RenderOpts
opts Bool
True Int
ind
    otherIndent :: Builder
otherIndent = RenderOpts -> Bool -> Int -> Builder
mkIndent RenderOpts
opts Bool
False Int
ind

renderRField :: RField -> TB.Builder
renderRField :: RField -> Builder
renderRField = \case
  IdxField Int
n -> Builder
"In field " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall a. Show a => a -> Builder
showR Int
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" (0-indexed)"
  InfixField InfixSide
side -> case InfixSide
side of
    InfixSide
ILeft -> Builder
"In the left-hand field"
    InfixSide
IRight -> Builder
"In the right-hand field"
  RecordField Builder
fName -> Builder
"In field " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
fName

------------------------------------------------------------
-- Util

showR :: (Show a) => a -> TB.Builder
showR :: forall a. Show a => a -> Builder
showR = String -> Builder
TB.fromString (String -> Builder) -> (a -> String) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
{-# INLINE showR #-}

liftANS :: forall f g xs. (forall a. f a -> g a) -> NS f xs -> NS g xs
liftANS :: forall {k} (f :: k -> *) (g :: k -> *) (xs :: [k]).
(forall (a :: k). f a -> g a) -> NS f xs -> NS g xs
liftANS forall (a :: k). f a -> g a
f = NS f xs -> NS g xs
forall (ys :: [k]). NS f ys -> NS g ys
go
  where
    go :: forall ys. NS f ys -> NS g ys
    go :: forall (ys :: [k]). NS f ys -> NS g ys
go = \case
      Z f x
z -> g x -> NS g (x : xs)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (f x -> g x
forall (a :: k). f a -> g a
f f x
z)
      S NS f xs
s -> NS g xs -> NS g (x : xs)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS f xs -> NS g xs
forall (ys :: [k]). NS f ys -> NS g ys
go NS f xs
s)

mkIndent :: RenderOpts -> Bool -> Int -> TB.Builder
mkIndent :: RenderOpts -> Bool -> Int -> Builder
mkIndent RenderOpts {Bool
Natural
indentSize :: RenderOpts -> Natural
numberedLevels :: RenderOpts -> Bool
indentSize :: Natural
numberedLevels :: Bool
..} Bool
isFirst Int
ind =
  let spaces :: Builder
spaces = Text -> Builder
TB.fromText (Int -> Text -> Text
T.replicate (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
* Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
indentSize) Text
" ")
      number :: Builder
number = Int -> Builder
forall a. Show a => a -> Builder
showR (Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
". "
      noNumber :: Builder
noNumber = Builder
"   "

      withNumber :: Builder
withNumber = Builder
spaces Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
number
      withoutNumber :: Builder
withoutNumber = Builder
spaces Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
noNumber
  in  if Bool
numberedLevels
        then if Bool
isFirst then Builder
withNumber else Builder
withoutNumber
        else Builder
spaces