{-# OPTIONS_GHC -Wall #-}
{-# language BangPatterns #-}
{-# language DeriveGeneric #-}
{-# language DeriveFoldable #-}
{-# language DeriveFunctor #-}
{-# language DeriveTraversable #-}
{-# language NoImplicitPrelude #-}
{-# language ScopedTypeVariables #-}
module Data.Map.Delta
(
DeltaUnit(..)
, Delta(..)
, M(..)
, diff
, getSame
, getOld
, getNew
, getDelta
, getOriginal
, isSame
, isOld
, isNew
, isDelta
, toSame
, toOld
, toNew
, toDelta
, toOriginal
, mapSame
, mapOld
, mapNew
, mapSame'
, mapOld'
, mapNew'
) where
import Data.Bool (Bool(True, False))
import Data.Eq (Eq((==)))
import Data.Foldable (Foldable)
import Data.Function ((.))
import Data.Functor (Functor(fmap))
import Data.Maybe (Maybe(Just,Nothing))
import Data.Ord (Ord)
import Data.Traversable (Traversable)
import GHC.Generics (Generic, Generic1)
import GHC.Show (Show)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as DMS
import qualified Data.Map.Merge.Strict as Merge
data DeltaUnit a = DeltaUnit
{ old :: !a
, new :: !a
}
deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
data Delta a
= Delta !(DeltaUnit a)
| Same !a
| Old !a
| New !a
deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
data M = M1 | M2
diff :: (Eq a, Ord k)
=> Map k a
-> Map k a
-> Map k (Delta a)
diff !m1 !m2 =
Merge.merge
(Merge.mapMissing (\_ x -> Old x))
(Merge.mapMissing (\_ x -> New x))
(Merge.zipWithMatched (\_ v1 v2 -> if v1 == v2 then Same v1 else Delta (DeltaUnit v1 v2)))
m1
m2
{-# INLINABLE diff #-}
isSame :: Eq a => Delta a -> Bool
isSame (Same _) = True
isSame (Delta (DeltaUnit x y)) =
if x == y
then True
else False
isSame _ = False
{-# INLINABLE isSame #-}
isOld :: Delta a -> Bool
isOld (Old _ ) = True
isOld (Delta (DeltaUnit _ _)) = True
isOld _ = False
{-# INLINE isOld #-}
isNew :: Delta a -> Bool
isNew (New _ ) = True
isNew (Delta (DeltaUnit _ _)) = True
isNew _ = False
{-# INLINE isNew #-}
isDelta :: Delta a -> Bool
isDelta (Delta _) = True
isDelta _ = False
{-# INLINE isDelta #-}
getSame :: Eq a => Delta a -> Maybe a
getSame (Same a) = Just a
getSame (Delta (DeltaUnit x y)) =
if x == y
then Just x
else Nothing
getSame _ = Nothing
{-# INLINABLE getSame #-}
getOld :: Delta a -> Maybe a
getOld (Delta (DeltaUnit a _)) = Just a
getOld (Old a) = Just a
getOld _ = Nothing
{-# INLINE getOld #-}
getNew :: Delta a -> Maybe a
getNew (Delta (DeltaUnit _ a)) = Just a
getNew (New a) = Just a
getNew _ = Nothing
{-# INLINE getNew #-}
getDelta :: Delta a -> Maybe (DeltaUnit a)
getDelta (Delta d) = Just d
getDelta _ = Nothing
{-# INLINE getDelta #-}
getOriginal :: M -> Delta a -> Maybe a
getOriginal M1 (Delta (DeltaUnit x _)) = Just x
getOriginal M2 (Delta (DeltaUnit _ y)) = Just y
getOriginal _ (Same x) = Just x
getOriginal M1 (Old x) = Just x
getOriginal _ (Old _) = Nothing
getOriginal M2 (New x) = Just x
getOriginal _ (New _) = Nothing
{-# INLINE getOriginal #-}
toSame :: Eq a => Map k (Delta a)
-> Map k a
toSame = DMS.mapMaybe getSame
{-# INLINABLE toSame #-}
toOld :: Map k (Delta a)
-> Map k a
toOld = DMS.mapMaybe getOld
{-# INLINE toOld #-}
toNew :: Map k (Delta a)
-> Map k a
toNew = DMS.mapMaybe getNew
{-# INLINE toNew #-}
toDelta :: Map k (Delta a)
-> Map k (DeltaUnit a)
toDelta = DMS.mapMaybe getDelta
{-# INLINE toDelta #-}
toOriginal :: M -> Map k (Delta a) -> Map k a
toOriginal m = DMS.mapMaybe (getOriginal m)
{-# INLINE toOriginal #-}
mapSame :: Eq a => (a -> b) -> Map k (Delta a) -> Map k b
mapSame f = DMS.mapMaybe (fmap f . getSame)
{-# INLINABLE mapSame #-}
mapOld :: (a -> b) -> Map k (Delta a) -> Map k b
mapOld f = DMS.mapMaybe (fmap f . getOld)
{-# INLINE mapOld #-}
mapNew :: (a -> b) -> Map k (Delta a) -> Map k b
mapNew f = DMS.mapMaybe (fmap f . getNew)
{-# INLINE mapNew #-}
mapSame' :: Eq a => (a -> a) -> Map k (Delta a) -> Map k (Delta a)
mapSame' f = DMS.map (\x -> if isSame x then fmap f x else x)
{-# INLINABLE mapSame' #-}
mapOld' :: forall k a. (a -> a) -> Map k (Delta a) -> Map k (Delta a)
mapOld' f = DMS.map go
where
go :: Delta a -> Delta a
go (Old x) = Old (f x)
go (Delta (DeltaUnit x y)) = Delta (DeltaUnit (f x) y)
go x = x
mapNew' :: forall k a. (a -> a) -> Map k (Delta a) -> Map k (Delta a)
mapNew' f = DMS.map go
where
go :: Delta a -> Delta a
go (New x) = New (f x)
go (Delta (DeltaUnit x y)) = Delta (DeltaUnit x (f y))
go x = x