{- |
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 CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | TODO: package as a library? is this useful elsewhere?
module StructDiff where
import Control.Applicative (liftA2)
import Data.Align.Key (AlignWithKey (..))
import Data.Foldable (Foldable, fold, traverse_)
import Data.Key (Key)
import Data.List (intercalate)
import Data.Map (Map)
import Data.Monoid (Monoid (..), (<>))
import Data.Singletons.Bool (SBool (..), SBoolI (..), eqToRefl)
import Data.These (These (..))
import Data.Type.Equality
import Generics.SOP
-- | 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)]
alignDiff
:: (Show (Key f), Show a, Diff a, AlignWithKey f, Foldable f)
=> f a -> f a -> DiffResult
alignDiff x y = fold $ alignWithKey (\k -> prefixResult (show k) . f) x y
where
f (These a b) = diff a b
f (This a) = DiffResult [DiffThunk [] (show a) ""]
f (That b) = DiffResult [DiffThunk [] "" (show b)]
instance Diff Char where diff = eqDiff
instance Diff Bool
instance Diff a => Diff (Maybe a)
instance Diff Int where diff = eqDiff
instance (Diff a, Diff b) => Diff (Either a b)
instance (Diff a, Diff b) => Diff (a, b) where
diff (a, b) (a', b') =
prefixResult "_1" (diff a a') <>
prefixResult "_2" (diff b b')
instance (Diff a, Diff b, Diff c) => Diff (a, b, c) where
diff (a, b, c) (a', b', c') =
prefixResult "_1" (diff a a') <>
prefixResult "_2" (diff b b') <>
prefixResult "_3" (diff c c')
instance (SBoolI (a == Char), Show a, Diff a) => Diff [a] where
diff = case sbool :: SBool (a == Char) of
STrue -> case eqToRefl :: a :~: Char of
Refl -> eqDiff
SFalse -> alignDiff
instance (Ord k, Show k, Diff v, Show v) => Diff (Map k v) where diff = alignDiff
-------------------------------------------------------------------------------
-- 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
#if __GLASGOW_HASKELL__ < 800
constructorNameOf _ _ = error "Should never happen"
#endif
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) -- TODO: add .1 .2 etc.
fieldNames (Infix name _ _) = K ("-(" ++ name ++ ")") :* K ("(" ++ name ++ ")-") :* Nil
fieldNames (Record _ fis) = hmap (\(FieldInfo fieldName) -> K fieldName) fis