Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {- |
- 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" "food"
- (:)- (:)- (:)- :
- - []
- + :
- -}
- -------------------------------------------------------------------------------
- -- 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
- -}
- Bar exDone :
- - False
- + True
- -}
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement