{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module Data.Record.Anon.Internal.Core.Diff (
Diff(..)
, empty
, get
, set
, insert
, apply
#if DEBUG
, toString
#endif
) where
import Data.IntMap (IntMap)
import Data.Kind
import Data.List.NonEmpty (NonEmpty(..), (<|))
import Data.SOP.BasicFunctors
import GHC.Exts (Any)
import qualified Data.IntMap.Strict as IntMap
#if DEBUG
import Debug.RecoverRTTI (AnythingToString(..))
import Data.Record.Generic.Rep.Internal (noInlineUnsafeCo)
#endif
import qualified Data.List.NonEmpty as NE
import Data.Record.Anon.Internal.Core.Canonical (Canonical(..))
import Data.Record.Anon.Internal.Core.FieldName (FieldName)
import Data.Record.Anon.Internal.Util.SmallHashMap (SmallHashMap)
import qualified Data.Record.Anon.Internal.Core.Canonical as Canon
import qualified Data.Record.Anon.Internal.Util.SmallHashMap as HashMap
data Diff (f :: k -> Type) = Diff {
forall k (f :: k -> *). Diff f -> IntMap (f Any)
diffUpd :: !(IntMap (f Any))
, forall k (f :: k -> *). Diff f -> [FieldName]
diffIns :: [FieldName]
, forall k (f :: k -> *).
Diff f -> SmallHashMap FieldName (NonEmpty (f Any))
diffNew :: !(SmallHashMap FieldName (NonEmpty (f Any)))
}
type role Diff representational
deriving instance Show a => Show (Diff (K a))
empty :: Diff f
empty :: forall {k} (f :: k -> *). Diff f
empty = Diff {
diffUpd :: IntMap (f Any)
diffUpd = forall a. IntMap a
IntMap.empty
, diffIns :: [FieldName]
diffIns = []
, diffNew :: SmallHashMap FieldName (NonEmpty (f Any))
diffNew = forall k a. SmallHashMap k a
HashMap.empty
}
get :: (Int, FieldName) -> Diff f -> Canonical f -> f Any
get :: forall {k} (f :: k -> *).
(Int, FieldName) -> Diff f -> Canonical f -> f Any
get (Int
i, FieldName
f) Diff{[FieldName]
IntMap (f Any)
SmallHashMap FieldName (NonEmpty (f Any))
diffNew :: SmallHashMap FieldName (NonEmpty (f Any))
diffIns :: [FieldName]
diffUpd :: IntMap (f Any)
diffNew :: forall k (f :: k -> *).
Diff f -> SmallHashMap FieldName (NonEmpty (f Any))
diffIns :: forall k (f :: k -> *). Diff f -> [FieldName]
diffUpd :: forall k (f :: k -> *). Diff f -> IntMap (f Any)
..} Canonical f
c =
case forall k a. (Hashable k, Ord k) => k -> SmallHashMap k a -> Maybe a
HashMap.lookup FieldName
f SmallHashMap FieldName (NonEmpty (f Any))
diffNew of
Just NonEmpty (f Any)
xs -> forall a. NonEmpty a -> a
NE.head NonEmpty (f Any)
xs
Maybe (NonEmpty (f Any))
Nothing -> case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i IntMap (f Any)
diffUpd of
Just f Any
x -> f Any
x
Maybe (f Any)
Nothing -> forall {k} (f :: k -> *). Canonical f -> Int -> f Any
Canon.getAtIndex Canonical f
c Int
i
set :: forall f. (Int, FieldName) -> f Any -> Diff f -> Diff f
set :: forall {k} (f :: k -> *).
(Int, FieldName) -> f Any -> Diff f -> Diff f
set (Int
i, FieldName
f) f Any
x d :: Diff f
d@Diff{[FieldName]
IntMap (f Any)
SmallHashMap FieldName (NonEmpty (f Any))
diffNew :: SmallHashMap FieldName (NonEmpty (f Any))
diffIns :: [FieldName]
diffUpd :: IntMap (f Any)
diffNew :: forall k (f :: k -> *).
Diff f -> SmallHashMap FieldName (NonEmpty (f Any))
diffIns :: forall k (f :: k -> *). Diff f -> [FieldName]
diffUpd :: forall k (f :: k -> *). Diff f -> IntMap (f Any)
..} =
case forall k a b.
(Hashable k, Ord k) =>
k
-> (a -> (b, Maybe a))
-> SmallHashMap k a
-> Maybe (b, SmallHashMap k a)
HashMap.alterExisting FieldName
f NonEmpty (f Any) -> ((), Maybe (NonEmpty (f Any)))
updateInserted SmallHashMap FieldName (NonEmpty (f Any))
diffNew of
Just ((), SmallHashMap FieldName (NonEmpty (f Any))
diffNew') -> Diff f
d { diffNew :: SmallHashMap FieldName (NonEmpty (f Any))
diffNew = SmallHashMap FieldName (NonEmpty (f Any))
diffNew' }
Maybe ((), SmallHashMap FieldName (NonEmpty (f Any)))
Nothing -> Diff f
d { diffUpd :: IntMap (f Any)
diffUpd = forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
i f Any
x IntMap (f Any)
diffUpd }
where
updateInserted :: NonEmpty (f Any) -> ((), Maybe (NonEmpty (f Any)))
updateInserted :: NonEmpty (f Any) -> ((), Maybe (NonEmpty (f Any)))
updateInserted (f Any
_ :| [f Any]
prev) = ((), forall a. a -> Maybe a
Just (f Any
x forall a. a -> [a] -> NonEmpty a
:| [f Any]
prev))
insert :: forall f. FieldName -> f Any -> Diff f -> Diff f
insert :: forall {k} (f :: k -> *). FieldName -> f Any -> Diff f -> Diff f
insert FieldName
f f Any
x d :: Diff f
d@Diff{[FieldName]
IntMap (f Any)
SmallHashMap FieldName (NonEmpty (f Any))
diffNew :: SmallHashMap FieldName (NonEmpty (f Any))
diffIns :: [FieldName]
diffUpd :: IntMap (f Any)
diffNew :: forall k (f :: k -> *).
Diff f -> SmallHashMap FieldName (NonEmpty (f Any))
diffIns :: forall k (f :: k -> *). Diff f -> [FieldName]
diffUpd :: forall k (f :: k -> *). Diff f -> IntMap (f Any)
..} = Diff f
d {
diffIns :: [FieldName]
diffIns = FieldName
f forall a. a -> [a] -> [a]
: [FieldName]
diffIns
, diffNew :: SmallHashMap FieldName (NonEmpty (f Any))
diffNew = forall k a.
(Hashable k, Ord k) =>
(Maybe a -> Maybe a) -> k -> SmallHashMap k a -> SmallHashMap k a
HashMap.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (NonEmpty (f Any)) -> NonEmpty (f Any)
insertField) FieldName
f SmallHashMap FieldName (NonEmpty (f Any))
diffNew
}
where
insertField :: Maybe (NonEmpty (f Any)) -> NonEmpty (f Any)
insertField :: Maybe (NonEmpty (f Any)) -> NonEmpty (f Any)
insertField Maybe (NonEmpty (f Any))
Nothing = f Any
x forall a. a -> [a] -> NonEmpty a
:| []
insertField (Just NonEmpty (f Any)
prev) = f Any
x forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (f Any)
prev
allNewFields :: Diff f -> [f Any]
allNewFields :: forall {k} (f :: k -> *). Diff f -> [f Any]
allNewFields = \Diff{[FieldName]
IntMap (f Any)
SmallHashMap FieldName (NonEmpty (f Any))
diffNew :: SmallHashMap FieldName (NonEmpty (f Any))
diffIns :: [FieldName]
diffUpd :: IntMap (f Any)
diffNew :: forall k (f :: k -> *).
Diff f -> SmallHashMap FieldName (NonEmpty (f Any))
diffIns :: forall k (f :: k -> *). Diff f -> [FieldName]
diffUpd :: forall k (f :: k -> *). Diff f -> IntMap (f Any)
..} -> forall {k} (f :: k -> *).
SmallHashMap FieldName (NonEmpty (f Any)) -> [FieldName] -> [f Any]
go SmallHashMap FieldName (NonEmpty (f Any))
diffNew [FieldName]
diffIns
where
go :: SmallHashMap FieldName (NonEmpty (f Any)) -> [FieldName] -> [f Any]
go :: forall {k} (f :: k -> *).
SmallHashMap FieldName (NonEmpty (f Any)) -> [FieldName] -> [f Any]
go SmallHashMap FieldName (NonEmpty (f Any))
_ [] = []
go SmallHashMap FieldName (NonEmpty (f Any))
vs (FieldName
x:[FieldName]
xs) = case forall k a b.
(Hashable k, Ord k) =>
k
-> (a -> (b, Maybe a))
-> SmallHashMap k a
-> Maybe (b, SmallHashMap k a)
HashMap.alterExisting FieldName
x forall a. NonEmpty a -> (a, Maybe (NonEmpty a))
NE.uncons SmallHashMap FieldName (NonEmpty (f Any))
vs of
Maybe (f Any, SmallHashMap FieldName (NonEmpty (f Any)))
Nothing -> forall a. HasCallStack => String -> a
error String
"allNewFields: invariant violation"
Just (f Any
v, SmallHashMap FieldName (NonEmpty (f Any))
vs') -> f Any
v forall a. a -> [a] -> [a]
: forall {k} (f :: k -> *).
SmallHashMap FieldName (NonEmpty (f Any)) -> [FieldName] -> [f Any]
go SmallHashMap FieldName (NonEmpty (f Any))
vs' [FieldName]
xs
apply :: forall f. Diff f -> Canonical f -> Canonical f
apply :: forall {k} (f :: k -> *). Diff f -> Canonical f -> Canonical f
apply Diff f
d =
forall {k} (f :: k -> *). [f Any] -> Canonical f -> Canonical f
Canon.insert (forall {k} (f :: k -> *). Diff f -> [f Any]
allNewFields Diff f
d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *).
[(Int, f Any)] -> Canonical f -> Canonical f
Canon.setAtIndex (forall a. IntMap a -> [(Int, a)]
IntMap.toList (forall k (f :: k -> *). Diff f -> IntMap (f Any)
diffUpd Diff f
d))
#if DEBUG
toString :: forall k (f :: k -> Type). Diff f -> String
toString = show . mapDiff (K . AnythingToString . co)
where
mapDiff :: (forall x. f x -> g x) -> Diff f -> Diff g
mapDiff f Diff{..} = Diff{
diffUpd = fmap f diffUpd
, diffIns = diffIns
, diffNew = fmap (fmap f) diffNew
}
co :: f x -> f Any
co = noInlineUnsafeCo
#endif