{-# LANGUAGE DerivingVia #-}
{-# OPTIONS_GHC -Wno-orphans #-}

{- | A worked example of implementing 'SpecialDiff' (and thereby 'Diff') for 'Tree.Tree's.

As with other 3rd-party types, there are different approaches we can take here. We'll show 2 of them:

- using 'gspecialDiffNested';
- using 'SpecialDiff' and a custom diff type.
-}
module Generics.Diff.Special.Tree where

import Control.Applicative
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Text.Lazy.Builder as TB
import qualified Data.Tree as Tree
import Generics.Diff
import Generics.Diff.Render
import Generics.Diff.Special
import Generics.SOP.GGP

------------------------------------------------------------
-- Using gspecialDiffNested

-- | Generically-derived instance.
instance (Diff a) => SpecialDiff (Tree.Tree a) where
  type SpecialDiffError (Tree.Tree a) = DiffErrorNested (GCode (Tree.Tree a))
  specialDiff :: Tree a -> Tree a -> Maybe (SpecialDiffError (Tree a))
specialDiff = Tree a -> Tree a -> Maybe (DiffErrorNested (GCode (Tree a)))
Tree a -> Tree a -> Maybe (SpecialDiffError (Tree a))
forall a.
(Generic a, GFrom a, GDatatypeInfo a, All2 Diff (GCode a)) =>
a -> a -> Maybe (DiffErrorNested (GCode a))
gspecialDiffNested
  renderSpecialDiffError :: SpecialDiffError (Tree a) -> Doc
renderSpecialDiffError = DiffErrorNested '[ '[a, [Tree a]]] -> Doc
SpecialDiffError (Tree a) -> Doc
forall (xss :: [[*]]). DiffErrorNested xss -> Doc
diffErrorNestedDoc

instance (Diff a) => Diff (Tree.Tree a) where
  diff :: Tree a -> Tree a -> DiffResult (Tree a)
diff = Tree a -> Tree a -> DiffResult (Tree a)
forall a. SpecialDiff a => a -> a -> DiffResult a
diffWithSpecial

------------------------------------------------------------
-- Using SpecialDiff

{- | A newtype wrapper around 'Tree.Tree' to demonstrate one alternate way we could hand-write
a 'SpecialDiff' instance.
-}
newtype CustomTree a = CustomTree (Tree.Tree a)
  deriving (Int -> CustomTree a -> ShowS
[CustomTree a] -> ShowS
CustomTree a -> String
(Int -> CustomTree a -> ShowS)
-> (CustomTree a -> String)
-> ([CustomTree a] -> ShowS)
-> Show (CustomTree a)
forall a. Show a => Int -> CustomTree a -> ShowS
forall a. Show a => [CustomTree a] -> ShowS
forall a. Show a => CustomTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> CustomTree a -> ShowS
showsPrec :: Int -> CustomTree a -> ShowS
$cshow :: forall a. Show a => CustomTree a -> String
show :: CustomTree a -> String
$cshowList :: forall a. Show a => [CustomTree a] -> ShowS
showList :: [CustomTree a] -> ShowS
Show) via (Tree.Tree a)

-- | Where are we in the tree? Each element of the list says which child node we step to next.
newtype TreePath = TreePath [Int]
  deriving (Int -> TreePath -> ShowS
[TreePath] -> ShowS
TreePath -> String
(Int -> TreePath -> ShowS)
-> (TreePath -> String) -> ([TreePath] -> ShowS) -> Show TreePath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TreePath -> ShowS
showsPrec :: Int -> TreePath -> ShowS
$cshow :: TreePath -> String
show :: TreePath -> String
$cshowList :: [TreePath] -> ShowS
showList :: [TreePath] -> ShowS
Show, TreePath -> TreePath -> Bool
(TreePath -> TreePath -> Bool)
-> (TreePath -> TreePath -> Bool) -> Eq TreePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TreePath -> TreePath -> Bool
== :: TreePath -> TreePath -> Bool
$c/= :: TreePath -> TreePath -> Bool
/= :: TreePath -> TreePath -> Bool
Eq) via [Int]

-- | A custom error type for 'CustomTree'.
data CustomTreeDiffError a
  = DiffAtNode TreePath (DiffError a)
  | WrongLengthsOfChildren TreePath Int Int
  deriving (Int -> CustomTreeDiffError a -> ShowS
[CustomTreeDiffError a] -> ShowS
CustomTreeDiffError a -> String
(Int -> CustomTreeDiffError a -> ShowS)
-> (CustomTreeDiffError a -> String)
-> ([CustomTreeDiffError a] -> ShowS)
-> Show (CustomTreeDiffError a)
forall a. Int -> CustomTreeDiffError a -> ShowS
forall a. [CustomTreeDiffError a] -> ShowS
forall a. CustomTreeDiffError a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> CustomTreeDiffError a -> ShowS
showsPrec :: Int -> CustomTreeDiffError a -> ShowS
$cshow :: forall a. CustomTreeDiffError a -> String
show :: CustomTreeDiffError a -> String
$cshowList :: forall a. [CustomTreeDiffError a] -> ShowS
showList :: [CustomTreeDiffError a] -> ShowS
Show, CustomTreeDiffError a -> CustomTreeDiffError a -> Bool
(CustomTreeDiffError a -> CustomTreeDiffError a -> Bool)
-> (CustomTreeDiffError a -> CustomTreeDiffError a -> Bool)
-> Eq (CustomTreeDiffError a)
forall a. CustomTreeDiffError a -> CustomTreeDiffError a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. CustomTreeDiffError a -> CustomTreeDiffError a -> Bool
== :: CustomTreeDiffError a -> CustomTreeDiffError a -> Bool
$c/= :: forall a. CustomTreeDiffError a -> CustomTreeDiffError a -> Bool
/= :: CustomTreeDiffError a -> CustomTreeDiffError a -> Bool
Eq)

-- | Render a tree path as a 'TB.Builder'
renderTreePath :: TreePath -> TB.Builder
renderTreePath :: TreePath -> Builder
renderTreePath (TreePath []) = Builder
"<root>"
renderTreePath (TreePath (Int
x : [Int]
xs)) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Builder
forall a. Show a => a -> Builder
showB Int
x Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Builder
"->" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall a. Show a => a -> Builder
showB Int
y | Int
y <- [Int]
xs]

instance (Diff a) => SpecialDiff (CustomTree a) where
  type SpecialDiffError (CustomTree a) = CustomTreeDiffError a

  renderSpecialDiffError :: SpecialDiffError (CustomTree a) -> Doc
renderSpecialDiffError = \case
    DiffAtNode TreePath
path DiffError a
err ->
      let ls :: NonEmpty Builder
ls = Builder -> NonEmpty Builder
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> NonEmpty Builder) -> Builder -> NonEmpty Builder
forall a b. (a -> b) -> a -> b
$ Builder
"Diff between nodes at path " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TreePath -> Builder
renderTreePath TreePath
path
      in  NonEmpty Builder -> DiffError a -> Doc
forall a. NonEmpty Builder -> DiffError a -> Doc
makeDoc NonEmpty Builder
ls DiffError a
err
    WrongLengthsOfChildren TreePath
path Int
l Int
r ->
      let ls :: NonEmpty Builder
ls =
            (Builder
"Child lists at path " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TreePath -> Builder
renderTreePath TreePath
path Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" are wrong lengths")
              Builder -> [Builder] -> NonEmpty Builder
forall a. a -> [a] -> NonEmpty a
:| [ Builder
"Length of left child list: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall a. Show a => a -> Builder
showB Int
l
                 , Builder
"Length of right child list: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall a. Show a => a -> Builder
showB Int
r
                 ]
      in  NonEmpty Builder -> Doc
linesDoc NonEmpty Builder
ls

  specialDiff :: CustomTree a
-> CustomTree a -> Maybe (SpecialDiffError (CustomTree a))
specialDiff (CustomTree Tree a
l) (CustomTree Tree a
r) = [Int] -> Tree a -> Tree a -> Maybe (CustomTreeDiffError a)
forall {a}.
Diff a =>
[Int] -> Tree a -> Tree a -> Maybe (CustomTreeDiffError a)
go [] Tree a
l Tree a
r
    where
      go :: [Int] -> Tree a -> Tree a -> Maybe (CustomTreeDiffError a)
go [Int]
curPath (Tree.Node a
n1 [Tree a]
f1) (Tree.Node a
n2 [Tree a]
f2) =
        case a -> a -> DiffResult a
forall a. Diff a => a -> a -> DiffResult a
diff a
n1 a
n2 of
          Error DiffError a
err -> CustomTreeDiffError a -> Maybe (CustomTreeDiffError a)
forall a. a -> Maybe a
Just (CustomTreeDiffError a -> Maybe (CustomTreeDiffError a))
-> CustomTreeDiffError a -> Maybe (CustomTreeDiffError a)
forall a b. (a -> b) -> a -> b
$ TreePath -> DiffError a -> CustomTreeDiffError a
forall a. TreePath -> DiffError a -> CustomTreeDiffError a
DiffAtNode TreePath
curTreePath DiffError a
err
          DiffResult a
Equal ->
            let go' :: Int -> Tree a -> Tree a -> Maybe (CustomTreeDiffError a)
go' Int
n = [Int] -> Tree a -> Tree a -> Maybe (CustomTreeDiffError a)
go (Int
n Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
curPath)
                goChildren :: Int -> [Tree a] -> [Tree a] -> Maybe (CustomTreeDiffError a)
goChildren Int
_ [] [] = Maybe (CustomTreeDiffError a)
forall a. Maybe a
Nothing
                goChildren Int
n [] [Tree a]
ys = CustomTreeDiffError a -> Maybe (CustomTreeDiffError a)
forall a. a -> Maybe a
Just (CustomTreeDiffError a -> Maybe (CustomTreeDiffError a))
-> CustomTreeDiffError a -> Maybe (CustomTreeDiffError a)
forall a b. (a -> b) -> a -> b
$ TreePath -> Int -> Int -> CustomTreeDiffError a
forall a. TreePath -> Int -> Int -> CustomTreeDiffError a
WrongLengthsOfChildren TreePath
curTreePath Int
n (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Tree a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tree a]
ys)
                goChildren Int
n [Tree a]
xs [] = CustomTreeDiffError a -> Maybe (CustomTreeDiffError a)
forall a. a -> Maybe a
Just (CustomTreeDiffError a -> Maybe (CustomTreeDiffError a))
-> CustomTreeDiffError a -> Maybe (CustomTreeDiffError a)
forall a b. (a -> b) -> a -> b
$ TreePath -> Int -> Int -> CustomTreeDiffError a
forall a. TreePath -> Int -> Int -> CustomTreeDiffError a
WrongLengthsOfChildren TreePath
curTreePath (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Tree a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tree a]
xs) Int
n
                goChildren Int
n (Tree a
x : [Tree a]
xs) (Tree a
y : [Tree a]
ys) = Int -> Tree a -> Tree a -> Maybe (CustomTreeDiffError a)
go' Int
n Tree a
x Tree a
y Maybe (CustomTreeDiffError a)
-> Maybe (CustomTreeDiffError a) -> Maybe (CustomTreeDiffError a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> [Tree a] -> [Tree a] -> Maybe (CustomTreeDiffError a)
goChildren (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Tree a]
xs [Tree a]
ys
            in  Int -> [Tree a] -> [Tree a] -> Maybe (CustomTreeDiffError a)
goChildren Int
0 [Tree a]
f1 [Tree a]
f2
        where
          curTreePath :: TreePath
curTreePath = [Int] -> TreePath
TreePath ([Int] -> TreePath) -> [Int] -> TreePath
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
curPath

instance (Diff a) => Diff (CustomTree a) where
  diff :: CustomTree a -> CustomTree a -> DiffResult (CustomTree a)
diff = CustomTree a -> CustomTree a -> DiffResult (CustomTree a)
forall a. SpecialDiff a => a -> a -> DiffResult a
diffWithSpecial