Extensible diff types

generic-diff.cabal

@@ -74,6 +74,8 @@ library
       Generics.Diff
       Generics.Diff.Instances
       Generics.Diff.Render
+      Generics.Diff.Special
+      Generics.Diff.Special.List
   other-modules:
       Generics.Diff.Class
       Generics.Diff.Type

src/Generics/Diff.hs

@@ -127,12 +127,11 @@ uses the @Right@ constructor"! And of course, once we have one step of recursion
 
 The 'Diff' class encapsulates the above behaviour with 'diff'. It's very strongly recommended that you don't
 implement 'diff' yourself, but use the default implementation using 'Generics.SOP.Generic', which is just 'gdiff'.
-In the rare case you might want to implement 'diff' yourself, there are two other functions you might want to use.
+In case you might want to implement 'diff' yourself, there are three other functions you might want to use.
 
 - 'eqDiff' simply delegates the entire process to '(==)', and will only ever give 'Equal' or 'TopLevelNotEqual'. This is
 no more useful than 'Eq', and should only be used for primitive types (e.g. all numeric types like 'Char' and 'Int')
-use 'eqDiff', since they don't really have ADTs or recursion. This is the only implementation that doesn't require an
-instance of 'Generics.SOP.Generic'.
+use 'eqDiff', since they don't really have ADTs or recursion.
 
 - 'gdiffTopLevel' does the above process, but without recursion. In other words each pair of fields is compared using
 '(==)'. This is definitely better than 'Eq', by one "level". One situation when this might be useful is when your
@@ -160,6 +159,9 @@ instance 'Diff' Request where
   'diff' = 'gdiffTopLevel'
 @
 
+- 'diffWithSpecial' lets us handle edge cases for funky types with unusual 'Eq' instances or preserved
+invariants. See "Generics.Diff.Special".
+
 For completeness, we also provide one more implementation function: 'gdiffWith' lets you provide a set of
 'Differ's (comparison functions) to use for each pair of fields (one per cell of the grid).
 I'm not sure in what situation you'd want this, but there you go.

src/Generics/Diff/Class.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE EmptyCase #-}
-{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-orphans #-}
 
 module Generics.Diff.Class
   ( -- * Class
@@ -10,14 +10,21 @@ module Generics.Diff.Class
   , gdiffTopLevel
   , gdiffWith
   , eqDiff
+  , diffWithSpecial
+  , gspecialDiffNested
+
+    -- * Special case: lists
   , diffListWith
   )
 where
 
 import Data.SOP
 import Data.SOP.NP
+import qualified GHC.Generics as G
+import Generics.Diff.Render
 import Generics.Diff.Type
-import Generics.SOP
+import Generics.SOP as SOP
+import Generics.SOP.GGP as SOP
 
 {- | A type with an instance of 'Diff' permits a more nuanced comparison than 'Eq' or 'Ord'.
 If two values are not equal, 'diff' will tell you exactly where they differ ("in this contructor,
@@ -27,6 +34,10 @@ we can "descend" through) depends on the implementation of the instance.
 For user-defined types, it's strongly recommended you derive your 'Diff' instance using 'Generic' from
 @generics-sop@. If those types refer to other types, those will need 'Diff' instances too. For example:
 
+However, in some cases we'll want to use a custom type for representing diffs of user-defined or
+third-party types. For example, if we have non-derived `Eq` instances, invariants etc. In that case,
+see "Generics.Diff.Special".
+
 @
 {\-# LANGUAGE DerivingStrategies #-\}
 {\-# LANGUAGE DeriveGeneric #-\}
@@ -124,20 +135,30 @@ class Diff a where
   -- | Compare two lists of values. This mostly exists so that we can define a custom instance for 'String',
   -- in a similar vein to 'showList'.
   diffList :: [a] -> [a] -> DiffResult [a]
-  diffList = diffListWith DiffList diff
+  diffList = diffWithSpecial
+
+-- | When we have an instance of 'SpecialDiff', we can implement 'diff' using 'DiffSpecial'.
+diffWithSpecial :: (SpecialDiff a) => a -> a -> DiffResult a
+diffWithSpecial l r = maybe Equal (Error . DiffSpecial) $ specialDiff l r
+
+instance (Diff a) => SpecialDiff [a] where
+  type SpecialDiffError [a] = ListDiffError a
+  specialDiff = diffListWith diff
+  renderSpecialDiffError = listDiffErrorDoc "list"
 
-{- | Used to implement 'diffList'. Given two lists, a way to 'diff' the elements of the list, and a way
-to convert a 'ListDiffError' to a 'DiffError' (e.g. 'DiffList'), return a 'DiffResult' of a list-like type.
+{- | Given two lists and a way to 'diff' the elements of the list,
+return a 'ListDiffError'. Used to implement 'specialDiff' for list-like types.
+See "Generics.Diff.Special" for an example.
 -}
-diffListWith :: (ListDiffError a -> DiffError b) -> (a -> a -> DiffResult a) -> [a] -> [a] -> DiffResult b
-diffListWith f d = go 0
+diffListWith :: (a -> a -> DiffResult a) -> [a] -> [a] -> Maybe (ListDiffError a)
+diffListWith d = go 0
   where
-    go _ [] [] = Equal
-    go n [] ys = Error $ f $ WrongLengths n (n + length ys)
-    go n xs [] = Error $ f $ WrongLengths (n + length xs) n
+    go _ [] [] = Nothing
+    go n [] ys = Just $ WrongLengths n (n + length ys)
+    go n xs [] = Just $ WrongLengths (n + length xs) n
     go n (x : xs) (y : ys) = case d x y of
       Equal -> go (n + 1) xs ys
-      Error err -> Error $ f $ DiffAtIndex n err
+      Error err -> Just $ DiffAtIndex n err
 
 {- | The most basic 'Differ' possible. If the two values are equal, return 'Equal';
 otherwise, return 'TopLevelNotEqual'.
@@ -192,6 +213,45 @@ gdiffWithPure ::
   DiffResult a
 gdiffWithPure ds = gdiffWith $ cpure_POP (Proxy @c) ds
 
+{- | Helper function to implement 'specialDiff' for an instance of "GHC.Generic", with
+@SpecialDiffError a = DiffErrorNested xss@.
+
+For example, say we want to implement 'SpecialDiff' (and then 'Diff') for @Tree@ from @containers@.
+We'd ideally like to use a 'SOP.Generic' instance, but we don't have one. Nevertheless we can fake one,
+using 'G.Generic' from "GHC.Generics".
+
+@
+data Tree a = Node
+  { rootLabel :: a
+  , subForest :: [Tree a]
+  }
+  deriving ('G.Generic')
+
+instance ('Diff' a) => 'SpecialDiff' (Tree a) where
+  type 'SpecialDiffError' (Tree a) = 'DiffErrorNested' ('GCode' (Tree a))
+  'specialDiff' = 'gspecialDiffNested'
+
+  'renderSpecialDiffError' = 'diffErrorNestedDoc'
+
+instance ('Diff' a) => 'Diff' (Tree a) where
+  diff = 'diffWithSpecial'
+@
+-}
+gspecialDiffNested ::
+  forall a.
+  ( G.Generic a
+  , GFrom a
+  , GDatatypeInfo a
+  , All2 Diff (GCode a)
+  ) =>
+  a ->
+  a ->
+  Maybe (DiffErrorNested (GCode a))
+gspecialDiffNested l r = gdiff' constructors differs (unSOP $ gfrom l) (unSOP $ gfrom r)
+  where
+    differs = unPOP $ hcpure (Proxy @Diff) (Differ diff)
+    constructors = constructorInfo $ gdatatypeInfo $ Proxy @a
+
 ------------------------------------------------------------
 -- Auxiliary functions
 

src/Generics/Diff/Instances.hs

@@ -41,6 +41,7 @@
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TLB
 import Data.Type.Coercion
+import Generics.Diff.Special.List ()
 #if MIN_VERSION_base(4,16,0)
 import Data.Type.Ord
 #endif
@@ -249,7 +250,7 @@
   diff = diffList
 
 instance (Diff a) => Diff (NE.NonEmpty a) where
-  diff l r = diffListWith DiffNonEmpty diff (NE.toList l) (NE.toList r)
+  diff = diffWithSpecial
 
 -- combinators - typically we'll use gdiff
 
@@ -285,7 +286,7 @@
 instance (Diff a, Diff b) => Diff (S.Arg a b)
 
 #if !MIN_VERSION_base(4,16,0)
 instance (Diff a) => Diff (S.Option a)
 #endif
 
 {- FOURMOLU_ENABLE -}

src/Generics/Diff/Render.hs

@@ -22,14 +22,14 @@ module Generics.Diff.Render
   , renderDiffErrorWith
   , renderDiffErrorNested
   , renderDiffErrorNestedWith
-  , renderListDiffError
-  , renderListDiffErrorWith
 
     -- * Intermediate representation
   , Doc (..)
   , diffErrorDoc
   , renderDoc
-  , showR
+  , listDiffErrorDoc
+  , diffErrorNestedDoc
+  , showB
   , linesDoc
   , makeDoc
   )
@@ -42,19 +42,6 @@ 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
-  { indentSize :: Natural
-  -- ^ How many spaces to indent each new "level" of comparison.
-  , numberedLevels :: Bool
-  -- ^ Whether or not to include level numbers in the output.
-  }
-  deriving (Show)
 
 -- | Sensible rendering defaults. No numbers, 2-space indentation.
 defaultRenderOpts :: RenderOpts
@@ -97,32 +84,11 @@ renderDiffErrorNested = renderDiffErrorNestedWith defaultRenderOpts
 renderDiffErrorNestedWith :: RenderOpts -> DiffErrorNested xss -> TB.Builder
 renderDiffErrorNestedWith opts = renderDoc opts 0 . diffErrorNestedDoc
 
--- | Render a 'ListDiffError' using a lazy 'TB.Builder'.
-renderListDiffError :: ListDiffError xss -> TB.Builder
-renderListDiffError = renderListDiffErrorWith defaultRenderOpts
-
--- | Render a 'ListDiffError' using a lazy 'TB.Builder', using custom 'RenderOpts'.
-renderListDiffErrorWith :: RenderOpts -> ListDiffError xss -> TB.Builder
-renderListDiffErrorWith opts = renderDoc opts 0 . listDiffErrorDoc "list"
-
 ------------------------------------------------------------
 -- Doc 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.
 
-{- | An intermediate representation for diff output.
-
-We constrain output to follow a very simple pattern:
-
-- 'docLines' is a non-empty series of preliminary lines describing the error.
-- 'docSubDoc' is an optional 'Doc' representing a nested error, e.g. in 'FieldMismatch'.
--}
-data Doc = Doc
-  { docLines :: NonEmpty TB.Builder
-  , docSubDoc :: Maybe Doc
-  }
-  deriving (Show)
-
 -- | Create a 'Doc' with a non-empty list of lines and a nested error.
 makeDoc :: NonEmpty TB.Builder -> DiffError a -> Doc
 makeDoc ls err = Doc ls (Just $ diffErrorDoc err)
@@ -137,25 +103,45 @@ diffResultDoc = \case
   Error err -> diffErrorDoc err
 
 -- | Convert a 'DiffError' to a 'Doc'.
-diffErrorDoc :: DiffError a -> Doc
+diffErrorDoc :: forall a. DiffError a -> Doc
 diffErrorDoc = \case
   TopLevelNotEqual -> linesDoc (pure "Not equal")
   Nested err -> diffErrorNestedDoc err
-  DiffList listErr -> listDiffErrorDoc "list" listErr
-  DiffNonEmpty listErr -> listDiffErrorDoc "non-empty list" listErr
+  DiffSpecial err -> renderSpecialDiffError @a err
+
+{- | Convert a 'ListDiffError' to a 'Doc'.
+
+The first argument gives us a name for the type of list, for clearer output.
+For example:
+
+@
+ghci> 'TL.putStrLn' . 'TB.toLazyText' . 'renderDoc' 'defaultRenderOpts' 0 . 'listDiffErrorDoc' "list" $ 'DiffAtIndex' 3 'TopLevelNotEqual'
+Diff at list index 3 (0-indexed)
+  Not equal
 
+ghci> TL.putStrLn . TB.toLazyText . renderDoc defaultRenderOpts 0 . listDiffErrorDoc "non-empty list" $ WrongLengths 3 5
+non-empty lists are wrong lengths
+Length of left list: 3
+Length of right list: 5
+@
+-}
 listDiffErrorDoc :: TB.Builder -> ListDiffError a -> Doc
 listDiffErrorDoc lst = \case
   DiffAtIndex idx err ->
-    let lns = pure $ "Diff at " <> lst <> " index " <> showR idx <> " (0-indexed)"
+    let lns = pure $ "Diff at " <> lst <> " index " <> showB idx <> " (0-indexed)"
     in  makeDoc lns err
   WrongLengths l r ->
     linesDoc $
-      "Lists are wrong lengths"
-        :| [ "Length of left list: " <> showR l
-           , "Length of right list: " <> showR r
+      (lst <> "s are wrong lengths")
+        :| [ "Length of left list: " <> showB l
+           , "Length of right list: " <> showB r
            ]
 
+{- | Convert a 'DiffErrorNested' to a 'Doc'.
+
+This is exported in the case that we want to implement an instance of 'Generics.Diff.Diff' for an existing type (e.g.
+from a 3rd-party library) that does not have a 'SOP.Generic' instance.
+-}
 diffErrorNestedDoc :: DiffErrorNested xss -> Doc
 diffErrorNestedDoc = \case
   WrongConstructor l r ->
@@ -227,7 +213,7 @@ unpackAtLocErr cInfo nsErr =
 
 renderRField :: RField -> TB.Builder
 renderRField = \case
-  IdxField n -> "In field " <> showR n <> " (0-indexed)"
+  IdxField n -> "In field " <> showB n <> " (0-indexed)"
   InfixField side -> case side of
     ILeft -> "In the left-hand field"
     IRight -> "In the right-hand field"
@@ -241,9 +227,9 @@ unlinesB (b : bs) = b <> TB.singleton '\n' <> unlinesB bs
 unlinesB [] = mempty
 
 -- | 'show' a value as a 'TB.Builder'.
-showR :: (Show a) => a -> TB.Builder
-showR = TB.fromString . show
-{-# INLINE showR #-}
+showB :: (Show a) => a -> TB.Builder
+showB = TB.fromString . show
+{-# INLINE showB #-}
 
 liftANS :: forall f g xs. (forall a. f a -> g a) -> NS f xs -> NS g xs
 liftANS f = go
@@ -256,7 +242,7 @@ liftANS f = go
 mkIndent :: RenderOpts -> Bool -> Int -> TB.Builder
 mkIndent RenderOpts {..} isFirst ind =
   let spaces = TB.fromText (T.replicate (ind * fromIntegral indentSize) " ")
-      number = showR (ind + 1) <> ". "
+      number = showB (ind + 1) <> ". "
       noNumber = "   "
 
       withNumber = spaces <> number