module Erebos.Set (
    Set,

    emptySet,
    loadSet,
    storeSetAdd,

    fromSetBy,
) where

import Control.Arrow
import Control.Monad.IO.Class

import Data.Function
import Data.List
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe
import Data.Ord

import Erebos.Storage
import Erebos.Storage.Merge
import Erebos.Util

data Set a = Set [Stored (SetItem (Component a))]

data SetItem a = SetItem
    { forall a. SetItem a -> [Stored (SetItem a)]
siPrev :: [Stored (SetItem a)]
    , forall a. SetItem a -> [Stored a]
siItem :: [Stored a]
    }

instance Storable a => Storable (SetItem a) where
    store' :: SetItem a -> Store
store' SetItem a
x = (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
storeRec ((forall (c :: * -> *). StorageCompleteness c => StoreRec c)
 -> Store)
-> (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
forall a b. (a -> b) -> a -> b
$ do
        (Stored (SetItem a) -> StoreRec c)
-> [Stored (SetItem a)] -> StoreRec c
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Stored (SetItem a) -> StoreRec c
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> a -> StoreRec c
storeRef String
"PREV") ([Stored (SetItem a)] -> StoreRec c)
-> [Stored (SetItem a)] -> StoreRec c
forall a b. (a -> b) -> a -> b
$ SetItem a -> [Stored (SetItem a)]
forall a. SetItem a -> [Stored (SetItem a)]
siPrev SetItem a
x
        (Stored a -> StoreRec c) -> [Stored a] -> StoreRec c
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Stored a -> StoreRec c
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> a -> StoreRec c
storeRef String
"item") ([Stored a] -> StoreRec c) -> [Stored a] -> StoreRec c
forall a b. (a -> b) -> a -> b
$ SetItem a -> [Stored a]
forall a. SetItem a -> [Stored a]
siItem SetItem a
x

    load' :: Load (SetItem a)
load' = LoadRec (SetItem a) -> Load (SetItem a)
forall a. LoadRec a -> Load a
loadRec (LoadRec (SetItem a) -> Load (SetItem a))
-> LoadRec (SetItem a) -> Load (SetItem a)
forall a b. (a -> b) -> a -> b
$ [Stored (SetItem a)] -> [Stored a] -> SetItem a
forall a. [Stored (SetItem a)] -> [Stored a] -> SetItem a
SetItem
        ([Stored (SetItem a)] -> [Stored a] -> SetItem a)
-> LoadRec [Stored (SetItem a)]
-> LoadRec ([Stored a] -> SetItem a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> LoadRec [Stored (SetItem a)]
forall a. Storable a => String -> LoadRec [a]
loadRefs String
"PREV"
        LoadRec ([Stored a] -> SetItem a)
-> LoadRec [Stored a] -> LoadRec (SetItem a)
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec [Stored a]
forall a. Storable a => String -> LoadRec [a]
loadRefs String
"item"

instance Mergeable a => Mergeable (Set a) where
    type Component (Set a) = SetItem (Component a)
    mergeSorted :: [Stored (Component (Set a))] -> Set a
mergeSorted = [Stored (Component (Set a))] -> Set a
[Stored (SetItem (Component a))] -> Set a
forall a. [Stored (SetItem (Component a))] -> Set a
Set
    toComponents :: Set a -> [Stored (Component (Set a))]
toComponents (Set [Stored (SetItem (Component a))]
items) = [Stored (Component (Set a))]
[Stored (SetItem (Component a))]
items


emptySet :: Set a
emptySet :: forall a. Set a
emptySet = [Stored (SetItem (Component a))] -> Set a
forall a. [Stored (SetItem (Component a))] -> Set a
Set []

loadSet :: Mergeable a => Ref -> Set a
loadSet :: forall a. Mergeable a => Ref -> Set a
loadSet = [Stored (Component (Set a))] -> Set a
[Stored' Identity (SetItem (Component a))] -> Set a
forall a. Mergeable a => [Stored (Component a)] -> a
mergeSorted ([Stored' Identity (SetItem (Component a))] -> Set a)
-> (Ref -> [Stored' Identity (SetItem (Component a))])
-> Ref
-> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stored' Identity (SetItem (Component a))
-> [Stored' Identity (SetItem (Component a))]
-> [Stored' Identity (SetItem (Component a))]
forall a. a -> [a] -> [a]
:[]) (Stored' Identity (SetItem (Component a))
 -> [Stored' Identity (SetItem (Component a))])
-> (Ref -> Stored' Identity (SetItem (Component a)))
-> Ref
-> [Stored' Identity (SetItem (Component a))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref -> Stored' Identity (SetItem (Component a))
forall a. Storable a => Ref -> Stored a
wrappedLoad

storeSetAdd :: (Mergeable a, MonadIO m) => Storage -> a -> Set a -> m (Set a)
storeSetAdd :: forall a (m :: * -> *).
(Mergeable a, MonadIO m) =>
Storage -> a -> Set a -> m (Set a)
storeSetAdd Storage
st a
x (Set [Stored (SetItem (Component a))]
prev) = [Stored (SetItem (Component a))] -> Set a
forall a. [Stored (SetItem (Component a))] -> Set a
Set ([Stored (SetItem (Component a))] -> Set a)
-> (Stored (SetItem (Component a))
    -> [Stored (SetItem (Component a))])
-> Stored (SetItem (Component a))
-> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stored (SetItem (Component a))
-> [Stored (SetItem (Component a))]
-> [Stored (SetItem (Component a))]
forall a. a -> [a] -> [a]
:[]) (Stored (SetItem (Component a)) -> Set a)
-> m (Stored (SetItem (Component a))) -> m (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Storage
-> SetItem (Component a) -> m (Stored (SetItem (Component a)))
forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Storage -> a -> m (Stored a)
wrappedStore Storage
st SetItem
    { siPrev :: [Stored (SetItem (Component a))]
siPrev = [Stored (SetItem (Component a))]
prev
    , siItem :: [Stored (Component a)]
siItem = a -> [Stored (Component a)]
forall a. Mergeable a => a -> [Stored (Component a)]
toComponents a
x
    }


fromSetBy :: forall a. Mergeable a => (a -> a -> Ordering) -> Set a -> [a]
fromSetBy :: forall a. Mergeable a => (a -> a -> Ordering) -> Set a -> [a]
fromSetBy a -> a -> Ordering
cmp (Set [Stored (SetItem (Component a))]
heads) = (a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy a -> a -> Ordering
cmp ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ ([Stored (Component a)] -> a) -> [[Stored (Component a)]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map [Stored (Component a)] -> a
forall a. Mergeable a => [Stored (Component a)] -> a
merge ([[Stored (Component a)]] -> [a])
-> [[Stored (Component a)]] -> [a]
forall a b. (a -> b) -> a -> b
$ [Stored (Component a)] -> [[Stored (Component a)]]
groupRelated [Stored (Component a)]
items
  where
    -- gather all item components in the set history
    items :: [Stored (Component a)]
    items :: [Stored (Component a)]
items = (Stored (SetItem (Component a)) -> [Stored (Component a)])
-> [Stored (SetItem (Component a))] -> [Stored (Component a)]
forall a m.
(Storable a, Monoid m) =>
(Stored a -> m) -> [Stored a] -> m
walkAncestors (SetItem (Component a) -> [Stored (Component a)]
forall a. SetItem a -> [Stored a]
siItem (SetItem (Component a) -> [Stored (Component a)])
-> (Stored (SetItem (Component a)) -> SetItem (Component a))
-> Stored (SetItem (Component a))
-> [Stored (Component a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored (SetItem (Component a)) -> SetItem (Component a)
forall a. Stored a -> a
fromStored) [Stored (SetItem (Component a))]
heads

    -- map individual roots to full root set as joined in history of individual items
    rootToRootSet :: Map RefDigest [RefDigest]
    rootToRootSet :: Map RefDigest [RefDigest]
rootToRootSet = (Map RefDigest [RefDigest]
 -> [RefDigest] -> Map RefDigest [RefDigest])
-> Map RefDigest [RefDigest]
-> [[RefDigest]]
-> Map RefDigest [RefDigest]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map RefDigest [RefDigest]
m [RefDigest]
rs -> (Map RefDigest [RefDigest]
 -> RefDigest -> Map RefDigest [RefDigest])
-> Map RefDigest [RefDigest]
-> [RefDigest]
-> Map RefDigest [RefDigest]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map RefDigest [RefDigest]
m' RefDigest
r -> ([RefDigest] -> [RefDigest] -> [RefDigest])
-> RefDigest
-> [RefDigest]
-> Map RefDigest [RefDigest]
-> Map RefDigest [RefDigest]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (\[RefDigest]
a [RefDigest]
b -> [RefDigest] -> [RefDigest]
forall a. Eq a => [a] -> [a]
uniq ([RefDigest] -> [RefDigest]) -> [RefDigest] -> [RefDigest]
forall a b. (a -> b) -> a -> b
$ [RefDigest] -> [RefDigest]
forall a. Ord a => [a] -> [a]
sort ([RefDigest] -> [RefDigest]) -> [RefDigest] -> [RefDigest]
forall a b. (a -> b) -> a -> b
$ [RefDigest]
a[RefDigest] -> [RefDigest] -> [RefDigest]
forall a. [a] -> [a] -> [a]
++[RefDigest]
b) RefDigest
r [RefDigest]
rs Map RefDigest [RefDigest]
m') Map RefDigest [RefDigest]
m [RefDigest]
rs) Map RefDigest [RefDigest]
forall k a. Map k a
M.empty ([[RefDigest]] -> Map RefDigest [RefDigest])
-> [[RefDigest]] -> Map RefDigest [RefDigest]
forall a b. (a -> b) -> a -> b
$
        (Stored (Component a) -> [RefDigest])
-> [Stored (Component a)] -> [[RefDigest]]
forall a b. (a -> b) -> [a] -> [b]
map ((Stored (Component a) -> RefDigest)
-> [Stored (Component a)] -> [RefDigest]
forall a b. (a -> b) -> [a] -> [b]
map (Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref -> RefDigest)
-> (Stored (Component a) -> Ref)
-> Stored (Component a)
-> RefDigest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored (Component a) -> Ref
forall a. Stored a -> Ref
storedRef) ([Stored (Component a)] -> [RefDigest])
-> (Stored (Component a) -> [Stored (Component a)])
-> Stored (Component a)
-> [RefDigest]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored (Component a) -> [Stored (Component a)]
forall a. Storable a => Stored a -> [Stored a]
storedRoots) [Stored (Component a)]
items

    -- get full root set for given item component
    storedRootSet :: Stored (Component a) -> [RefDigest]
    storedRootSet :: Stored (Component a) -> [RefDigest]
storedRootSet = Maybe [RefDigest] -> [RefDigest]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [RefDigest] -> [RefDigest])
-> (Stored (Component a) -> Maybe [RefDigest])
-> Stored (Component a)
-> [RefDigest]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RefDigest -> Map RefDigest [RefDigest] -> Maybe [RefDigest])
-> Map RefDigest [RefDigest] -> RefDigest -> Maybe [RefDigest]
forall a b c. (a -> b -> c) -> b -> a -> c
flip RefDigest -> Map RefDigest [RefDigest] -> Maybe [RefDigest]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map RefDigest [RefDigest]
rootToRootSet (RefDigest -> Maybe [RefDigest])
-> (Stored (Component a) -> RefDigest)
-> Stored (Component a)
-> Maybe [RefDigest]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref -> RefDigest)
-> (Stored (Component a) -> Ref)
-> Stored (Component a)
-> RefDigest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored (Component a) -> Ref
forall a. Stored a -> Ref
storedRef (Stored (Component a) -> Ref)
-> (Stored (Component a) -> Stored (Component a))
-> Stored (Component a)
-> Ref
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stored (Component a)] -> Stored (Component a)
forall a. HasCallStack => [a] -> a
head ([Stored (Component a)] -> Stored (Component a))
-> (Stored (Component a) -> [Stored (Component a)])
-> Stored (Component a)
-> Stored (Component a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored (Component a) -> [Stored (Component a)]
forall a. Storable a => Stored a -> [Stored a]
storedRoots

    -- group components of single item, i.e. components sharing some root
    groupRelated :: [Stored (Component a)] -> [[Stored (Component a)]]
    groupRelated :: [Stored (Component a)] -> [[Stored (Component a)]]
groupRelated = ([(Stored (Component a), [RefDigest])] -> [Stored (Component a)])
-> [[(Stored (Component a), [RefDigest])]]
-> [[Stored (Component a)]]
forall a b. (a -> b) -> [a] -> [b]
map (((Stored (Component a), [RefDigest]) -> Stored (Component a))
-> [(Stored (Component a), [RefDigest])] -> [Stored (Component a)]
forall a b. (a -> b) -> [a] -> [b]
map (Stored (Component a), [RefDigest]) -> Stored (Component a)
forall a b. (a, b) -> a
fst) ([[(Stored (Component a), [RefDigest])]]
 -> [[Stored (Component a)]])
-> ([Stored (Component a)]
    -> [[(Stored (Component a), [RefDigest])]])
-> [Stored (Component a)]
-> [[Stored (Component a)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Stored (Component a), [RefDigest])
 -> (Stored (Component a), [RefDigest]) -> Bool)
-> [(Stored (Component a), [RefDigest])]
-> [[(Stored (Component a), [RefDigest])]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ([RefDigest] -> [RefDigest] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([RefDigest] -> [RefDigest] -> Bool)
-> ((Stored (Component a), [RefDigest]) -> [RefDigest])
-> (Stored (Component a), [RefDigest])
-> (Stored (Component a), [RefDigest])
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Stored (Component a), [RefDigest]) -> [RefDigest]
forall a b. (a, b) -> b
snd) ([(Stored (Component a), [RefDigest])]
 -> [[(Stored (Component a), [RefDigest])]])
-> ([Stored (Component a)]
    -> [(Stored (Component a), [RefDigest])])
-> [Stored (Component a)]
-> [[(Stored (Component a), [RefDigest])]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Stored (Component a), [RefDigest])
 -> (Stored (Component a), [RefDigest]) -> Ordering)
-> [(Stored (Component a), [RefDigest])]
-> [(Stored (Component a), [RefDigest])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Stored (Component a), [RefDigest]) -> [RefDigest])
-> (Stored (Component a), [RefDigest])
-> (Stored (Component a), [RefDigest])
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Stored (Component a), [RefDigest]) -> [RefDigest]
forall a b. (a, b) -> b
snd) ([(Stored (Component a), [RefDigest])]
 -> [(Stored (Component a), [RefDigest])])
-> ([Stored (Component a)]
    -> [(Stored (Component a), [RefDigest])])
-> [Stored (Component a)]
-> [(Stored (Component a), [RefDigest])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stored (Component a) -> (Stored (Component a), [RefDigest]))
-> [Stored (Component a)] -> [(Stored (Component a), [RefDigest])]
forall a b. (a -> b) -> [a] -> [b]
map (Stored (Component a) -> Stored (Component a)
forall a. a -> a
id (Stored (Component a) -> Stored (Component a))
-> (Stored (Component a) -> [RefDigest])
-> Stored (Component a)
-> (Stored (Component a), [RefDigest])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Stored (Component a) -> [RefDigest]
storedRootSet)