Skip to content

Instantly share code, notes, and snippets.

@phadej

phadej/SopDiff.hs

Last active Jul 24, 2016
Embed
What would you like to do?
{- |
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
-}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.