{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
module Hedgehog.Internal.Show (
    Name
  , Value(..)
  , ValueDiff(..)
  , LineDiff(..)

  , mkValue
  , showPretty

  , valueDiff
  , lineDiff
  , toLineDiff

  , renderValue
  , renderValueDiff
  , renderLineDiff

  , takeLeft
  , takeRight
  ) where

import           Data.Bifunctor (second)

import           Text.Show.Pretty (Value(..), Name, reify, valToStr, ppShow)


data ValueDiff =
    ValueCon Name [ValueDiff]
  | ValueRec Name [(Name, ValueDiff)]
  | ValueTuple [ValueDiff]
  | ValueList [ValueDiff]
  | ValueSame Value
  | ValueDiff Value Value
    deriving (ValueDiff -> ValueDiff -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValueDiff -> ValueDiff -> Bool
$c/= :: ValueDiff -> ValueDiff -> Bool
== :: ValueDiff -> ValueDiff -> Bool
$c== :: ValueDiff -> ValueDiff -> Bool
Eq, Int -> ValueDiff -> ShowS
[ValueDiff] -> ShowS
ValueDiff -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [ValueDiff] -> ShowS
$cshowList :: [ValueDiff] -> ShowS
show :: ValueDiff -> Name
$cshow :: ValueDiff -> Name
showsPrec :: Int -> ValueDiff -> ShowS
$cshowsPrec :: Int -> ValueDiff -> ShowS
Show)

data LineDiff =
    LineSame String
  | LineRemoved String
  | LineAdded String
    deriving (LineDiff -> LineDiff -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LineDiff -> LineDiff -> Bool
$c/= :: LineDiff -> LineDiff -> Bool
== :: LineDiff -> LineDiff -> Bool
$c== :: LineDiff -> LineDiff -> Bool
Eq, Int -> LineDiff -> ShowS
[LineDiff] -> ShowS
LineDiff -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [LineDiff] -> ShowS
$cshowList :: [LineDiff] -> ShowS
show :: LineDiff -> Name
$cshow :: LineDiff -> Name
showsPrec :: Int -> LineDiff -> ShowS
$cshowsPrec :: Int -> LineDiff -> ShowS
Show)

data DocDiff =
    DocSame Int String
  | DocRemoved Int String
  | DocAdded Int String
  | DocOpen Int String
  | DocItem Int String [DocDiff]
  | DocClose Int String
    deriving (DocDiff -> DocDiff -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DocDiff -> DocDiff -> Bool
$c/= :: DocDiff -> DocDiff -> Bool
== :: DocDiff -> DocDiff -> Bool
$c== :: DocDiff -> DocDiff -> Bool
Eq, Int -> DocDiff -> ShowS
[DocDiff] -> ShowS
DocDiff -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [DocDiff] -> ShowS
$cshowList :: [DocDiff] -> ShowS
show :: DocDiff -> Name
$cshow :: DocDiff -> Name
showsPrec :: Int -> DocDiff -> ShowS
$cshowsPrec :: Int -> DocDiff -> ShowS
Show)

renderValue :: Value -> String
renderValue :: Value -> Name
renderValue =
  Value -> Name
valToStr

renderValueDiff :: ValueDiff -> String
renderValueDiff :: ValueDiff -> Name
renderValueDiff =
  [Name] -> Name
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LineDiff -> Name
renderLineDiff forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ValueDiff -> [LineDiff]
toLineDiff

renderLineDiff :: LineDiff -> String
renderLineDiff :: LineDiff -> Name
renderLineDiff = \case
  LineSame Name
x ->
    Name
"  " forall a. [a] -> [a] -> [a]
++ Name
x
  LineRemoved Name
x ->
    Name
"- " forall a. [a] -> [a] -> [a]
++ Name
x
  LineAdded Name
x ->
    Name
"+ " forall a. [a] -> [a] -> [a]
++ Name
x

mkValue :: Show a => a -> Maybe Value
mkValue :: forall a. Show a => a -> Maybe Value
mkValue =
  forall a. Show a => a -> Maybe Value
reify

showPretty :: Show a => a -> String
showPretty :: forall a. Show a => a -> Name
showPretty =
  forall a. Show a => a -> Name
ppShow

lineDiff :: Value -> Value -> [LineDiff]
lineDiff :: Value -> Value -> [LineDiff]
lineDiff Value
x Value
y =
  ValueDiff -> [LineDiff]
toLineDiff forall a b. (a -> b) -> a -> b
$ Value -> Value -> ValueDiff
valueDiff Value
x Value
y

toLineDiff :: ValueDiff -> [LineDiff]
toLineDiff :: ValueDiff -> [LineDiff]
toLineDiff =
  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Name -> DocDiff -> [LineDiff]
mkLineDiff Int
0 Name
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  [DocDiff] -> [DocDiff]
collapseOpen forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  [DocDiff] -> [DocDiff]
dropLeadingSep forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ValueDiff -> [DocDiff]
mkDocDiff Int
0

valueDiff :: Value -> Value -> ValueDiff
valueDiff :: Value -> Value -> ValueDiff
valueDiff Value
x Value
y =
  if Value
x forall a. Eq a => a -> a -> Bool
== Value
y then
    Value -> ValueDiff
ValueSame Value
x
  else
    case (Value
x, Value
y) of
      (Con Name
nx [Value]
xs, Con Name
ny [Value]
ys)
        | Name
nx forall a. Eq a => a -> a -> Bool
== Name
ny
        , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
xs forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
ys
        ->
          Name -> [ValueDiff] -> ValueDiff
ValueCon Name
nx (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Value -> Value -> ValueDiff
valueDiff [Value]
xs [Value]
ys)

      (Rec Name
nx [(Name, Value)]
nxs, Rec Name
ny [(Name, Value)]
nys)
        | Name
nx forall a. Eq a => a -> a -> Bool
== Name
ny
        , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(Name, Value)]
nxs forall a. Eq a => a -> a -> Bool
== forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(Name, Value)]
nys
        , [Name]
ns <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(Name, Value)]
nxs
        , [Value]
xs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd [(Name, Value)]
nxs
        , [Value]
ys <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd [(Name, Value)]
nys
        ->
          Name -> [(Name, ValueDiff)] -> ValueDiff
ValueRec Name
nx (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
ns (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Value -> Value -> ValueDiff
valueDiff [Value]
xs [Value]
ys))

      (Tuple [Value]
xs, Tuple [Value]
ys)
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
xs forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
ys
        ->
          [ValueDiff] -> ValueDiff
ValueTuple (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Value -> Value -> ValueDiff
valueDiff [Value]
xs [Value]
ys)

      (List [Value]
xs, List [Value]
ys)
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
xs forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
ys
        ->
          [ValueDiff] -> ValueDiff
ValueList (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Value -> Value -> ValueDiff
valueDiff [Value]
xs [Value]
ys)

      (Value, Value)
_ ->
        Value -> Value -> ValueDiff
ValueDiff Value
x Value
y

takeLeft :: ValueDiff -> Value
takeLeft :: ValueDiff -> Value
takeLeft = \case
  ValueCon Name
n [ValueDiff]
xs ->
    Name -> [Value] -> Value
Con Name
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ValueDiff -> Value
takeLeft [ValueDiff]
xs)
  ValueRec Name
n [(Name, ValueDiff)]
nxs ->
    Name -> [(Name, Value)] -> Value
Rec Name
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ValueDiff -> Value
takeLeft) [(Name, ValueDiff)]
nxs)
  ValueTuple [ValueDiff]
xs ->
    [Value] -> Value
Tuple (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ValueDiff -> Value
takeLeft [ValueDiff]
xs)
  ValueList [ValueDiff]
xs ->
    [Value] -> Value
List (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ValueDiff -> Value
takeLeft [ValueDiff]
xs)
  ValueSame Value
x ->
    Value
x
  ValueDiff Value
x Value
_ ->
    Value
x

takeRight :: ValueDiff -> Value
takeRight :: ValueDiff -> Value
takeRight = \case
  ValueCon Name
n [ValueDiff]
xs ->
    Name -> [Value] -> Value
Con Name
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ValueDiff -> Value
takeRight [ValueDiff]
xs)
  ValueRec Name
n [(Name, ValueDiff)]
nxs ->
    Name -> [(Name, Value)] -> Value
Rec Name
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ValueDiff -> Value
takeRight) [(Name, ValueDiff)]
nxs)
  ValueTuple [ValueDiff]
xs ->
    [Value] -> Value
Tuple (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ValueDiff -> Value
takeRight [ValueDiff]
xs)
  ValueList [ValueDiff]
xs ->
    [Value] -> Value
List (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ValueDiff -> Value
takeRight [ValueDiff]
xs)
  ValueSame Value
x ->
    Value
x
  ValueDiff Value
_ Value
x ->
    Value
x

mkLineDiff :: Int -> String -> DocDiff -> [LineDiff]
mkLineDiff :: Int -> Name -> DocDiff -> [LineDiff]
mkLineDiff Int
indent0 Name
prefix0 DocDiff
diff =
  let
    mkLinePrefix :: Int -> Name
mkLinePrefix Int
indent =
      Int -> Name
spaces Int
indent0 forall a. [a] -> [a] -> [a]
++ Name
prefix0 forall a. [a] -> [a] -> [a]
++ Int -> Name
spaces Int
indent

    mkLineIndent :: Int -> Int
mkLineIndent Int
indent =
      Int
indent0 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length Name
prefix0 forall a. Num a => a -> a -> a
+ Int
indent
  in
    case DocDiff
diff of
      DocSame Int
indent Name
x ->
        [Name -> LineDiff
LineSame forall a b. (a -> b) -> a -> b
$ Int -> Name
mkLinePrefix Int
indent forall a. [a] -> [a] -> [a]
++ Name
x]

      DocRemoved Int
indent Name
x ->
        [Name -> LineDiff
LineRemoved forall a b. (a -> b) -> a -> b
$ Int -> Name
mkLinePrefix Int
indent forall a. [a] -> [a] -> [a]
++ Name
x]

      DocAdded Int
indent Name
x ->
        [Name -> LineDiff
LineAdded forall a b. (a -> b) -> a -> b
$ Int -> Name
mkLinePrefix Int
indent forall a. [a] -> [a] -> [a]
++ Name
x]

      DocOpen Int
indent Name
x ->
        [Name -> LineDiff
LineSame forall a b. (a -> b) -> a -> b
$ Int -> Name
mkLinePrefix Int
indent forall a. [a] -> [a] -> [a]
++ Name
x]

      DocItem Int
_ Name
_ [] ->
        []

      DocItem Int
indent Name
prefix (x :: DocDiff
x@DocRemoved{} : y :: DocDiff
y@DocAdded{} : [DocDiff]
xs) ->
        Int -> Name -> DocDiff -> [LineDiff]
mkLineDiff (Int -> Int
mkLineIndent Int
indent) Name
prefix DocDiff
x forall a. [a] -> [a] -> [a]
++
        Int -> Name -> DocDiff -> [LineDiff]
mkLineDiff (Int -> Int
mkLineIndent Int
indent) Name
prefix DocDiff
y forall a. [a] -> [a] -> [a]
++
        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Name -> DocDiff -> [LineDiff]
mkLineDiff (Int -> Int
mkLineIndent (Int
indent forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length Name
prefix)) Name
"") [DocDiff]
xs

      DocItem Int
indent Name
prefix (DocDiff
x : [DocDiff]
xs) ->
        Int -> Name -> DocDiff -> [LineDiff]
mkLineDiff (Int -> Int
mkLineIndent Int
indent) Name
prefix DocDiff
x forall a. [a] -> [a] -> [a]
++
        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Name -> DocDiff -> [LineDiff]
mkLineDiff (Int -> Int
mkLineIndent (Int
indent forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length Name
prefix)) Name
"") [DocDiff]
xs

      DocClose Int
indent Name
x ->
        [Name -> LineDiff
LineSame forall a b. (a -> b) -> a -> b
$ Int -> Name
spaces (Int -> Int
mkLineIndent Int
indent) forall a. [a] -> [a] -> [a]
++ Name
x]

spaces :: Int -> String
spaces :: Int -> Name
spaces Int
indent =
  forall a. Int -> a -> [a]
replicate Int
indent Char
' '

collapseOpen :: [DocDiff] -> [DocDiff]
collapseOpen :: [DocDiff] -> [DocDiff]
collapseOpen = \case
  DocSame Int
indent Name
line : DocOpen Int
_ Name
bra : [DocDiff]
xs ->
    Int -> Name -> DocDiff
DocSame Int
indent (Name
line forall a. [a] -> [a] -> [a]
++ Name
" " forall a. [a] -> [a] -> [a]
++ Name
bra) forall a. a -> [a] -> [a]
: [DocDiff] -> [DocDiff]
collapseOpen [DocDiff]
xs
  DocItem Int
indent Name
prefix [DocDiff]
xs : [DocDiff]
ys ->
    Int -> Name -> [DocDiff] -> DocDiff
DocItem Int
indent Name
prefix ([DocDiff] -> [DocDiff]
collapseOpen [DocDiff]
xs) forall a. a -> [a] -> [a]
: [DocDiff] -> [DocDiff]
collapseOpen [DocDiff]
ys
  DocDiff
x : [DocDiff]
xs ->
    DocDiff
x forall a. a -> [a] -> [a]
: [DocDiff] -> [DocDiff]
collapseOpen [DocDiff]
xs
  [] ->
    []

dropLeadingSep :: [DocDiff] -> [DocDiff]
dropLeadingSep :: [DocDiff] -> [DocDiff]
dropLeadingSep = \case
  DocOpen Int
oindent Name
bra : DocItem Int
indent Name
prefix [DocDiff]
xs : [DocDiff]
ys ->
    Int -> Name -> DocDiff
DocOpen Int
oindent Name
bra forall a. a -> [a] -> [a]
: Int -> Name -> [DocDiff] -> DocDiff
DocItem (Int
indent forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length Name
prefix) Name
"" ([DocDiff] -> [DocDiff]
dropLeadingSep [DocDiff]
xs) forall a. a -> [a] -> [a]
: [DocDiff] -> [DocDiff]
dropLeadingSep [DocDiff]
ys
  DocItem Int
indent Name
prefix [DocDiff]
xs : [DocDiff]
ys ->
    Int -> Name -> [DocDiff] -> DocDiff
DocItem Int
indent Name
prefix ([DocDiff] -> [DocDiff]
dropLeadingSep [DocDiff]
xs) forall a. a -> [a] -> [a]
: [DocDiff] -> [DocDiff]
dropLeadingSep [DocDiff]
ys
  DocDiff
x : [DocDiff]
xs ->
    DocDiff
x forall a. a -> [a] -> [a]
: [DocDiff] -> [DocDiff]
dropLeadingSep [DocDiff]
xs
  [] ->
    []

mkDocDiff :: Int -> ValueDiff -> [DocDiff]
mkDocDiff :: Int -> ValueDiff -> [DocDiff]
mkDocDiff Int
indent = \case
  ValueSame Value
x ->
    Int -> Name -> [DocDiff]
same Int
indent (Value -> Name
renderValue Value
x)

  ValueDiff
diff
    | Value
x <- ValueDiff -> Value
takeLeft ValueDiff
diff
    , Value
y <- ValueDiff -> Value
takeRight ValueDiff
diff
    , Value -> Bool
oneLiner Value
x
    , Value -> Bool
oneLiner Value
y
    ->
      Int -> Name -> [DocDiff]
removed Int
indent (Value -> Name
renderValue Value
x) forall a. [a] -> [a] -> [a]
++
      Int -> Name -> [DocDiff]
added Int
indent (Value -> Name
renderValue Value
y)

  ValueCon Name
n [ValueDiff]
xs ->
    Int -> Name -> [DocDiff]
same Int
indent Name
n forall a. [a] -> [a] -> [a]
++
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> ValueDiff -> [DocDiff]
mkDocDiff (Int
indent forall a. Num a => a -> a -> a
+ Int
2)) [ValueDiff]
xs

  ValueRec Name
n [(Name, ValueDiff)]
nxs ->
    Int -> Name -> [DocDiff]
same Int
indent Name
n forall a. [a] -> [a] -> [a]
++
    [Int -> Name -> DocDiff
DocOpen Int
indent Name
"{"] forall a. [a] -> [a] -> [a]
++
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Name
name, ValueDiff
x) -> Int -> Name -> [DocDiff] -> DocDiff
DocItem (Int
indent forall a. Num a => a -> a -> a
+ Int
2) Name
", " (Int -> Name -> [DocDiff]
same Int
0 (Name
name forall a. [a] -> [a] -> [a]
++ Name
" =") forall a. [a] -> [a] -> [a]
++ Int -> ValueDiff -> [DocDiff]
mkDocDiff Int
2 ValueDiff
x)) [(Name, ValueDiff)]
nxs forall a. [a] -> [a] -> [a]
++
    [Int -> Name -> DocDiff
DocClose (Int
indent forall a. Num a => a -> a -> a
+ Int
2) Name
"}"]

  ValueTuple [ValueDiff]
xs ->
    [Int -> Name -> DocDiff
DocOpen Int
indent Name
"("] forall a. [a] -> [a] -> [a]
++
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Name -> [DocDiff] -> DocDiff
DocItem Int
indent Name
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ValueDiff -> [DocDiff]
mkDocDiff Int
0) [ValueDiff]
xs forall a. [a] -> [a] -> [a]
++
    [Int -> Name -> DocDiff
DocClose Int
indent Name
")"]

  ValueList [ValueDiff]
xs ->
    [Int -> Name -> DocDiff
DocOpen Int
indent Name
"["] forall a. [a] -> [a] -> [a]
++
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Name -> [DocDiff] -> DocDiff
DocItem Int
indent Name
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ValueDiff -> [DocDiff]
mkDocDiff Int
0) [ValueDiff]
xs forall a. [a] -> [a] -> [a]
++
    [Int -> Name -> DocDiff
DocClose Int
indent Name
"]"]

  ValueDiff Value
x Value
y ->
    Int -> Name -> [DocDiff]
removed Int
indent (Value -> Name
renderValue Value
x) forall a. [a] -> [a] -> [a]
++
    Int -> Name -> [DocDiff]
added Int
indent (Value -> Name
renderValue Value
y)

oneLiner :: Value -> Bool
oneLiner :: Value -> Bool
oneLiner Value
x =
  case Name -> [Name]
lines (Value -> Name
renderValue Value
x) of
    Name
_ : Name
_ : [Name]
_ ->
      Bool
False
    [Name]
_ ->
      Bool
True

same :: Int -> String -> [DocDiff]
same :: Int -> Name -> [DocDiff]
same Int
indent =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Name -> DocDiff
DocSame Int
indent) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Name]
lines

removed :: Int -> String -> [DocDiff]
removed :: Int -> Name -> [DocDiff]
removed Int
indent =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Name -> DocDiff
DocRemoved Int
indent) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Name]
lines

added :: Int -> String -> [DocDiff]
added :: Int -> Name -> [DocDiff]
added Int
indent =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Name -> DocDiff
DocAdded Int
indent) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Name]
lines