module FRP.Euphoria.Internal.GenericCollection
( CollectionUpdate (..)
, Collection
, simpleCollection
, accumCollection
, collectionToUpdates
, emptyCollection
, collectionFromList
, collectionFromDiscreteList
, makeCollection
, mapToCollection
, watchCollection
, followCollectionKey
, collectionToDiscreteList
, openCollection
, mapCollection
, mapCollectionWithKey
, filterCollection
, filterCollectionWithKey
, justCollection
, mapCollectionM
, sequenceCollection
) where
import Prelude hiding (lookup)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>), (<$), pure)
import Data.Foldable (Foldable)
import Data.Monoid (mappend, mempty)
import Data.Traversable (Traversable, sequenceA)
#endif
import Control.Monad (join)
import Control.DeepSeq
import qualified Data.List as List
import Data.Maybe (mapMaybe)
import Data.Proxy (Proxy(..))
import FRP.Euphoria.Event
import qualified FRP.Euphoria.Internal.Maplike as M
import GHC.Generics
data CollectionUpdate k a
= AddItem k a
| RemoveItem k
deriving (Functor, Eq, Show, Foldable, Traversable, Generic)
instance (NFData k, NFData v) => NFData (CollectionUpdate k v)
newtype Collection k a = Collection {
unCollection :: Discrete ([(k, a)], Event (CollectionUpdate k a))
}
instance SignalSet (Collection k a) where
basicSwitchD dis0 = do
dis <- memoD dis0
listD <- memoD $ join (fmap fst . unCollection <$> dis)
listS <- discreteToSignal listD
prevListS <- delayS [] listS
chE <- dropStepE $ changesD dis
(_, initialUpdatesE) <- openCollection =<< snapshotD dis
updatesE <- generatorD' =<< stepperD (return initialUpdatesE)
(updates <$> prevListS <*> listS <@> chE)
makeCollection listD updatesE
where
updates prevList list (Collection newCol) = do
rebuild <- flattenE <$> onCreation (map remove prevList ++ map add list)
(_, newUpdates) <- snapshotD newCol
memoE $ rebuild `mappend` newUpdates
remove (k, _) = RemoveItem k
add (k, v) = AddItem k v
memoizeSignalSet (Collection dis)= Collection <$> memoD dis
mapCollection :: MonadSignalGen m => (a -> b) -> Collection k a -> m (Collection k b)
mapCollection = mapCollectionWithKey . const
mapCollectionM
:: (M.Maplike c k, MonadSignalGen m)
=> Proxy (c k) -> (a -> SignalGen b) -> Collection k a -> m (Collection k b)
mapCollectionM p fn coll = do
updatesE0 <- collectionToUpdates coll
updatesE1 <- generatorE $ traverse fn <$> updatesE0
updatesE2 <- memoE updatesE1
accumCollection p updatesE2
mapCollectionWithKey
:: MonadSignalGen m
=> (k -> a -> b) -> Collection k a -> m (Collection k b)
mapCollectionWithKey f aC = do
updateE <- snd <$> openCollection aC
newCurD <- memoD $ fmap (fmap ft . fst) $ unCollection aC
newUpdateE <- memoE $ fmap fcu updateE
makeCollection newCurD newUpdateE
where
ft (k, x) = (k, f k x)
fcu (AddItem k x) = AddItem k (f k x)
fcu (RemoveItem k) = RemoveItem k
filterCollection
:: (M.Maplike c k, MonadSignalGen m)
=> Proxy (c k) -> (a -> Bool) -> Collection k a -> m (Collection k a)
filterCollection p =
filterCollectionWithKey p . const
filterCollectionWithKey
:: (M.Maplike c k, MonadSignalGen m)
=> Proxy (c k) -> (k -> a -> Bool) -> Collection k a -> m (Collection k a)
filterCollectionWithKey p f aC =
justCollection p =<< mapCollectionWithKey f' aC
where
f' k v
| f k v = Just v
| otherwise = Nothing
justCollection
:: forall m c k a. (M.Maplike c k, MonadSignalGen m)
=> Proxy (c k) -> Collection k (Maybe a) -> m (Collection k a)
justCollection p c = do
upds <- collectionToUpdates c
let f :: CollectionUpdate k (Maybe a) -> c k () -> (c k (), Maybe (CollectionUpdate k a))
f (AddItem k Nothing) m = (M.insert k () m, Nothing)
f (AddItem k (Just a)) m = (m, Just (AddItem k a))
f (RemoveItem k) m = case M.lookup k m of
Just () -> (M.delete k m, Nothing)
Nothing -> (m, Just (RemoveItem k))
upds' <- scanAccumE M.empty (f <$> upds)
accumCollection p =<< memoE (justE upds')
collectionToUpdates
:: forall m k a. MonadSignalGen m
=> Collection k a
-> m (Event (CollectionUpdate k a))
collectionToUpdates aC = do
(cur,updateE) <- openCollection aC
initE <- onCreation (map (uncurry AddItem) cur)
initE' <- memoE $ flattenE initE
return (updateE `mappend` initE')
sequenceCollection
:: (M.Maplike c k, MonadSignalGen m)
=> Proxy (c k) -> Collection k (SignalGen a)
-> m (Collection k a)
sequenceCollection p coll =
mapCollectionM p id coll
simpleCollection
:: (M.Maplike c k, Enum k, MonadSignalGen m)
=> Proxy (c k)
-> k
-> Event (a, Event ())
-> m (Collection k a)
simpleCollection p initialK evs =
simpleCollectionUpdates p initialK evs >>= accumCollection p
simpleCollectionUpdates
:: forall m c k a. (M.Maplike c k, Enum k, MonadSignalGen m)
=> Proxy (c k)
-> k
-> Event (a, Event ())
-> m (Event (CollectionUpdate k a))
simpleCollectionUpdates _ initialK evs = do
let addKey (a, ev) k = (succ k, (k, a, ev))
newEvents <- scanAccumE initialK (addKey <$> evs)
let addItem (k, _a, ev) = M.insert k ev
rec
removalEvent' <- delayE removalEvent
removalEvents <- accumD (M.empty :: c k (Event ()))
((addItem <$> newEvents) `mappend` (M.delete <$> removalEvent'))
removalEvent <- switchD $ M.foldrWithKey
(\k ev ev' -> (k <$ ev) `mappend` ev') mempty <$> removalEvents
let updateAddItem :: (k, a, Event ()) -> CollectionUpdate k a
updateAddItem (k, a, _) = AddItem k a
memoE $ (updateAddItem <$> newEvents) `mappend` (RemoveItem <$> removalEvent)
accumCollection
:: forall m c k a. (M.Maplike c k, MonadSignalGen m)
=> Proxy (c k)
-> Event (CollectionUpdate k a)
-> m (Collection k a)
accumCollection _ ev = do
let toMapOp :: CollectionUpdate k a -> c k a -> c k a
toMapOp (AddItem k a) = M.insert k a
toMapOp (RemoveItem k) = M.delete k
mapping <- accumD M.empty (toMapOp <$> ev)
listD <- memoD $ M.toList <$> mapping
makeCollection listD ev
makeCollection
:: MonadSignalGen m
=> Discrete [(k, a)]
-> Event (CollectionUpdate k a)
-> m (Collection k a)
makeCollection listD updE = Collection <$> generatorD (gen <$> listD)
where
gen list = do
updE' <- dropStepE updE
return (list, updE')
watchCollection :: (Show k, Show a, MonadSignalGen m)
=> Collection k a -> m (Event (IO ()))
watchCollection (Collection coll) = do
ev1 <- takeE 1 =<< preservesD coll
now <- onCreation ()
let f (items, ev) = ((putStrLn . showUpdate) <$> ev) `mappend`
(mapM_ (putStrLn . showExisting) items <$ now)
showUpdate (AddItem k a) = "Add: " ++ show k ++ ", " ++ show a
showUpdate (RemoveItem k) = "Remove: " ++ show k
showExisting (k, a) = "Existing: " ++ show k ++ ", " ++ show a
switchD =<< stepperD mempty (f <$> ev1)
emptyCollection :: Collection k a
emptyCollection = collectionFromList []
collectionFromList :: [(k, a)] -> Collection k a
collectionFromList kvs = Collection $ pure (kvs, mempty)
collectionFromDiscreteList
:: forall m c k a. (M.Maplike c k, Enum k, Eq a, MonadSignalGen m)
=> Proxy (c k)
-> k
-> Discrete [a]
-> m (Collection k a)
collectionFromDiscreteList p initialK valsD = do
valsE <- preservesD valsD
evs <- scanAccumE (initialK, M.empty :: c k a) (stepListCollState <$> valsE)
accumCollection p (flattenE evs)
stepListCollState
:: (M.Maplike c k, Enum k, Eq a)
=> [a]
-> (k, c k a)
-> ((k, c k a), [CollectionUpdate k a])
stepListCollState xs (initialK, existingMap) =
((k', newMap'), removeUpdates ++ addUpdates)
where
keyvals = M.toList existingMap
newItems = xs List.\\ map snd keyvals
removedKeys = map fst $ List.deleteFirstsBy
(\(_, x) (_, y) -> x == y)
keyvals
(map (\x -> (initialK, x)) xs)
(newMap, removeUpdates) = foldl
(\(em, upds) k -> (M.delete k em, upds ++ [RemoveItem k]))
(existingMap, []) removedKeys
(k', newMap', addUpdates) = foldl
(\(k, em, upds) x -> (succ k, M.insert k x em, upds ++ [AddItem k x]))
(initialK, newMap, []) newItems
data MapCollEvent k a
= MCNew k a
| MCChange k a
| MCRemove k
mapToCollection
:: forall c m k a. (Eq k, Eq a, M.Maplike c k, MonadSignalGen m)
=> Discrete (c k a)
-> m (Collection k (Discrete a))
mapToCollection mapD = do
m0 <- delayD M.empty mapD
let diffsD = diffMaps <$> m0 <*> mapD
diffsE <- flattenE <$> preservesD diffsD
dispatchCollEvent (Proxy :: Proxy (c k)) diffsE
diffMaps
:: (Eq a, M.Maplike c k)
=> c k a
-> c k a
-> [MapCollEvent k a]
diffMaps prevmap newmap = concat
[ map (uncurry MCNew ) newStuff
, map (MCRemove . fst ) removedStuff
, map (uncurry MCChange) changedStuff
]
where
newStuff = M.toList $ newmap `M.difference` prevmap
removedStuff = M.toList $ prevmap `M.difference` newmap
keptStuff = M.toList $ newmap `M.intersection` prevmap
changedStuff = mapMaybe justChanges keptStuff
justChanges (k, v1) = case M.lookup k prevmap of
Just v2 | v1 /= v2 -> Just (k, v1)
_ -> Nothing
dispatchCollEvent
:: (Eq k, M.Maplike c k, MonadSignalGen m)
=> Proxy (c k)
-> Event (MapCollEvent k a)
-> m (Collection k (Discrete a))
dispatchCollEvent p mapcollE = do
let f (MCNew k a) = Just $
AddItem k <$> discreteForKey k a mapcollE
f (MCRemove k) = Just $ return $ RemoveItem k
f (MCChange _ _) = Nothing
updateEv <- generatorE $ justE (f <$> mapcollE)
accumCollection p updateEv
discreteForKey :: (Eq k, MonadSignalGen m) => k -> a -> Event (MapCollEvent k a) -> m (Discrete a)
discreteForKey targetKey v0 mapcollE =
stepperD v0 $ justE $ relevantValue <$> mapcollE
where
relevantValue collEvent = case collEvent of
MCChange k v | k == targetKey -> Just v
_ -> Nothing
followCollectionKey :: forall m k a. (Eq k, MonadSignalGen m)
=> k
-> Collection k a
-> m (Discrete (Maybe a))
followCollectionKey k (Collection coll) = do
collAsNow <- takeE 1 =<< preservesD coll
:: m (Event ([(k, a)], Event (CollectionUpdate k a)))
let existing :: Event (CollectionUpdate k a)
existing = flattenE $ initialAdds . fst <$> collAsNow
further :: Event (Event (CollectionUpdate k a))
further = snd <$> collAsNow
further' <- switchD =<< stepperD mempty further
:: m (Event (CollectionUpdate k a))
accumMatchingItem (== k) (existing `mappend` further')
initialAdds :: [(k, a)] -> [CollectionUpdate k a]
initialAdds = map (uncurry AddItem)
accumMatchingItem :: forall m k a. MonadSignalGen m =>
(k -> Bool)
-> Event (CollectionUpdate k a)
-> m (Discrete (Maybe a))
accumMatchingItem f updateE =
stepperD Nothing $ justE (g <$> updateE)
where
g :: CollectionUpdate k a -> Maybe (Maybe a)
g (AddItem k a) | f k = Just (Just a)
| otherwise = Nothing
g (RemoveItem k) | f k = Just Nothing
| otherwise = Nothing
collectionToDiscreteList :: Collection k a -> Discrete [(k, a)]
collectionToDiscreteList = fmap fst . unCollection
openCollection :: MonadSignalGen m => Collection k a -> m ([(k,a)], Event (CollectionUpdate k a))
openCollection = snapshotD . unCollection