SopDiff.hs

{- |

At the ZuriHac 2016 I worked on the new parsec-based parser for the *.cabal files.
The obvious test case is to compare new and old parser results for all of Hackage.
Traversing the Hackage is quite trivial. The difficult part is inspecting
the result 'GenericPackageDescription's to spot the difference.

In the same event, Andres Löh showed his library @generics-sop@. Obvious choice
to quickly put something together for the repetetive task. After all you can
compare records field-wise. And if sum constructors are different, that's
enough for our case as well!

Generic programming ftw.
-}

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
module SopDiff where

import Control.Applicative (liftA2)
import Data.Foldable (traverse_)
import Data.List (intercalate)
import Generics.SOP
import Generics.SOP.TH

-- | Because @'Data.Proxy.Proxy' :: 'Data.Proxy.Proxy' a@ is so long.
data P a = P

-------------------------------------------------------------------------------
-- Structure diffs
-------------------------------------------------------------------------------

-- | Each thunk has a path, removed and added "stuff"
data DiffThunk = DiffThunk { dtPath :: [String], dtA :: String, dtB :: String }
    deriving Show

-- | Diff result is a collection of thunks
data DiffResult = DiffResult [DiffThunk]
    deriving Show

prefixThunk :: String -> DiffThunk -> DiffThunk
prefixThunk pfx (DiffThunk path a b) = DiffThunk (pfx : path) a b

prefixResult :: String -> DiffResult -> DiffResult
prefixResult name (DiffResult thunks) = DiffResult $ map (prefixThunk name) thunks

-- | Pretty print a result
prettyResultIO :: DiffResult -> IO ()
prettyResultIO (DiffResult []) = putStrLn "Equal"
prettyResultIO (DiffResult xs) = traverse_ p xs
  where
    p (DiffThunk paths a b) = do
        putStrLn $ intercalate " " paths ++ " : "
        putStrLn $ "- " ++ a
        putStrLn $ "+ " ++ b

-- | We can join diff results
instance Monoid DiffResult where
    mempty = DiffResult mempty
    mappend (DiffResult x) (DiffResult y) = DiffResult (mappend x y)

-- | And we have a class for things we can diff
class Diff a where
    diff :: a -> a -> DiffResult
    default diff
        :: (Generic a, HasDatatypeInfo a, All2 Diff (Code a))
        => a -> a -> DiffResult
    diff = gdiff

-- | And generic implementation!
gdiff :: forall a. (Generic a, HasDatatypeInfo a, All2 Diff (Code a)) => a -> a -> DiffResult
gdiff x y  = gdiffS (constructorInfo (P :: P a)) (unSOP $ from x) (unSOP $ from y)

gdiffS :: All2 Diff xss => NP ConstructorInfo xss -> NS (NP I) xss -> NS (NP I) xss -> DiffResult
gdiffS (c :* _) (Z xs) (Z ys) = mconcat $ hcollapse $ hczipWith3 (P :: P Diff) f (fieldNames c) xs ys
  where
    f :: Diff a => K FieldName a -> I a -> I a -> K DiffResult a
    f (K fieldName) x y = K . prefixResult fieldName . unI $ liftA2 diff x y
gdiffS (_ :* cs) (S xss) (S yss) = gdiffS cs xss yss
gdiffS cs xs ys = DiffResult [DiffThunk [] (constructorNameOf cs xs) (constructorNameOf cs ys)]

eqDiff :: (Eq a, Show a) => a -> a -> DiffResult
eqDiff x y
    | x == y    = DiffResult []
    | otherwise = DiffResult [DiffThunk [] (show x) (show y)]

instance Diff Char where diff = eqDiff
instance Diff Bool
instance Diff a => Diff (Maybe a)
instance Diff Int where diff = eqDiff

-- | This is terrible instance. Works for strings well enough though.
instance (Show a, Eq a) => Diff [a] where diff = eqDiff
--instance Diff a => Diff [a]
    
-------------------------------------------------------------------------------
-- SOP helpers
-------------------------------------------------------------------------------

constructorInfo :: (HasDatatypeInfo a, xss ~ Code a) => proxy a -> NP ConstructorInfo xss
constructorInfo p = case datatypeInfo p of
    ADT _ _ cs    -> cs
    Newtype _ _ c -> c :* Nil

constructorNameOf :: NP ConstructorInfo xss -> NS f xss -> ConstructorName
constructorNameOf (c :* _)  (Z _)  = constructorName c
constructorNameOf (_ :* cs) (S xs) = constructorNameOf cs xs

constructorName :: ConstructorInfo xs -> ConstructorName
constructorName (Constructor name) = name
constructorName (Infix name _ _)   = "(" ++ name ++ ")"
constructorName (Record name _)    = name

-- | This is a little lie.
fieldNames :: ConstructorInfo xs -> NP (K FieldName) xs
fieldNames (Constructor name) = hpure (K name)
fieldNames (Infix name _ _) = K ("-(" ++ name ++ ")") :* K ("(" ++ name ++ ")-") :* Nil
fieldNames (Record _ fis) = hmap (\(FieldInfo fn) -> K fn) fis

-------------------------------------------------------------------------------
-- Prelude examples
-------------------------------------------------------------------------------

{-

λ *SopDiff > prettyResultIO $ diff (Just True) (Just False)
Just : 
- True
+ False
λ *SopDiff > prettyResultIO $ diff True True
Equal
λ *SopDiff > prettyResultIO $ diff True False
 : 
- True
+ False
λ *SopDiff > prettyResultIO $ diff (Just True) (Just False)
Just : 
- True
+ False
λ *SopDiff > prettyResultIO $ diff (Just True) Nothing
 : 
- Just
+ Nothing
λ *SopDiff > prettyResultIO $ diff (Just (Just True)) (Just (Just False))
Just Just : 
- True
+ False

-}

{- The list doesn't work as well, as it cancels on the first constructor.

λ *SopDiff > prettyResultIO $ diff "foo" "food"
 : 
- "foo"
+ "food"
λ *SopDiff > prettyResultIO $ gdiff "foo" "food"
(:)- : 
- "oo"
+ "ood"

-- With commented out Diff a => Diff [a]

λ *SopDiff > prettyResultIO $ gdiff "foo" "good"
-(:) : 
- 'f'
+ 'g'
(:)- (:)- (:)- : 
- []
+ (:)

-}

-------------------------------------------------------------------------------
-- Examples
-------------------------------------------------------------------------------

data Ex
    = Foo Int
    | Bar Ex2
    deriving (Show)

data Ex2 = Ex2
    { exName :: String
    , exDone :: Bool
    }
    deriving (Show)

deriveGeneric ''Ex
deriveGeneric ''Ex2

instance Diff Ex
instance Diff Ex2

{-

λ *SopDiff > prettyResultIO $ diff (Foo 1) (Foo 1)
Equal
λ *SopDiff > prettyResultIO $ diff (Foo 1) (Bar $ Ex2 "bar" True)
 : 
- Foo
+ Bar
λ *SopDiff > prettyResultIO $ diff (Bar $ Ex2 "barr" False) (Bar $ Ex2 "bar" True)
Bar exName : 
- "barr"
+ "bar"
Bar exDone : 
- False
+ True

-}