diff --git a/FRP/Elerea/Simple/Compat.hs b/FRP/Elerea/Simple/Compat.hs new file mode 100644 --- /dev/null +++ b/FRP/Elerea/Simple/Compat.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} +module FRP.Elerea.Simple.Compat + ( module FRP.Elerea.Simple + , module FRP.Elerea.Simple.Compat + ) where +import FRP.Elerea.Simple + +#if !MIN_VERSION_elerea(2, 9, 0) +till :: Signal Bool -> SignalGen (Signal Bool) +till = FRP.Elerea.Simple.until +#endif diff --git a/FRP/Euphoria/Collection.hs b/FRP/Euphoria/Collection.hs --- a/FRP/Euphoria/Collection.hs +++ b/FRP/Euphoria/Collection.hs @@ -1,440 +1,35 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RecursiveDo #-} -{-# OPTIONS_GHC -Wall #-} - --- | Collection signals with incremental updates. +-- | A re-export of FRP.Euphoria.Collection.Enum for API compatability. +-- `Collection.Enum.mapToCollection` is renamed to `enummapToCollection`, +-- and `Collection.Hashable.mapToCollection` is exported as +-- `hashmapToCollection`. module FRP.Euphoria.Collection -( CollectionUpdate (..) -, Collection --- * creating collections -, simpleCollection -, accumCollection -, collectionToUpdates -, emptyCollection -, collectionFromList -, collectionFromDiscreteList -, makeCollection -, mapToCollection -, enummapToCollection -, hashmapToCollection --- * observing collections -, watchCollection -, followCollectionKey -, collectionToDiscreteList -, openCollection --- * other functions -, mapCollection -, mapCollectionWithKey -, filterCollection -, filterCollectionWithKey -, justCollection -, 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 + ( module FRP.Euphoria.EnumCollection.Lazy + , enummapToCollection + , hashmapToCollection + ) where -import Control.Monad (join) import Data.EnumMap.Lazy (EnumMap) -import qualified Data.EnumMap.Lazy as EnumMap -import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) -import Data.List hiding (insert, lookup) -import Data.Map (Map) -import Data.Maybe (mapMaybe) -import Data.Proxy (Proxy(..)) - -import FRP.Euphoria.Event -import qualified FRP.Euphoria.Internal.Maplike as M - - --- | Represents an incremental change to a collection of items. -data CollectionUpdate k a - = AddItem k a - | RemoveItem k - deriving (Functor, Eq, Show, Foldable, Traversable) - --- | An FRP interface for representing an incrementally updated --- collection of items. The items are identified by a unique key. --- Items may be added or removed from the current collection. --- --- This type is useful because it allows you to manage the incremental --- state updates to something that needs a collection of items without --- having to rebuild it completely every time the collection changes. --- Consider the type Signal [a] -- functionally, it also represents a --- collection of items that changes over time. However, there is no --- state carried between changes. If, for example, we have a GUI --- widget that lists items whose content is represented as a Signal --- [a], we would have to destroy and rebuild the widget's internal --- state every time the list contents change. But with the Collection --- type, we can add or remove from the GUI widget only the necessary --- items. This is useful both from a performance (most existing GUI --- toolkits exhibit worse performance when adding and removing all --- items with every change) and behavior standpoint, because the GUI --- toolkit can, for example, remember which items the user had --- selected between list updates. --- --- Usage of 'Collection' implies there could be some caching/state by --- the consumer of the Events, otherwise one might as well use a --- Signal [a]. -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 - --- | Like 'fmap', but the Collection and interior 'Event' stream are memoized -mapCollection :: MonadSignalGen m => (a -> b) -> Collection k a -> m (Collection k b) -mapCollection = mapCollectionWithKey . const - --- | A version of 'mapCollection' which provides access to the key -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 - -- f applied to tuples and collection updates - ft (k, x) = (k, f k x) - fcu (AddItem k x) = AddItem k (f k x) - fcu (RemoveItem k) = RemoveItem k - -filterCollection :: (Enum k, MonadSignalGen m) => (a -> Bool) -> Collection k a -> m (Collection k a) -filterCollection = filterCollectionWithKey . const - -filterCollectionWithKey :: forall m k a. (Enum k, MonadSignalGen m) => (k -> a -> Bool) -> Collection k a -> m (Collection k a) -filterCollectionWithKey f aC = mapCollectionWithKey f' aC >>= justCollection where - f' k v - | f k v = Just v - | otherwise = Nothing - -justCollection :: forall m k a. (Enum k, MonadSignalGen m) => Collection k (Maybe a) -> m (Collection k a) --- Inefficient, quick-hack implementation -justCollection c = do - upds <- collectionToUpdates c - let f :: CollectionUpdate k (Maybe a) -> EnumMap k () -> (EnumMap k (), Maybe (CollectionUpdate k a)) - f (AddItem k Nothing) m = (EnumMap.insert k () m, Nothing) - f (AddItem k (Just a)) m = (m, Just (AddItem k a)) - f (RemoveItem k) m = case EnumMap.lookup k m of - Just () -> (EnumMap.delete k m, Nothing) - Nothing -> (m, Just (RemoveItem k)) - upds' <- scanAccumE EnumMap.empty (f <$> upds) - accumCollection =<< memoE (justE upds') - --- | Create an 'Event' stream of all updates from a collection, including --- the items currently in it. -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 - :: (Enum k, MonadSignalGen m) - => Collection k (SignalGen a) - -> m (Collection k a) -sequenceCollection col = collectionToUpdates col - >>= generatorE . fmap sequenceA - >>= accumCollection - --- | A collection whose items are created by an event, and removed by --- another event. -simpleCollection :: (Enum k, MonadSignalGen m) - => k - -- ^ The initial value for the unique keys. 'succ' - -- will be used to get further keys. - -> Event (a, Event ()) - -- ^ An Event that introduces a new item and its - -- subsequent removal Event. The item will be removed - -- from the collection when the Event () fires. - -> m (Collection k a) -simpleCollection initialK evs = - simpleCollectionUpdates initialK evs >>= accumCollection - -simpleCollectionUpdates :: (Enum k, MonadSignalGen m) => 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) = EnumMap.insert k ev - rec - removalEvent' <- delayE removalEvent - removalEvents <- accumD EnumMap.empty - ((addItem <$> newEvents) `mappend` (EnumMap.delete <$> removalEvent')) - removalEvent <- switchD $ EnumMap.foldrWithKey - (\k ev ev' -> (k <$ ev) `mappend` ev') mempty <$> removalEvents - let -- updateAddItem :: (Enum k) => (k, a, Event ()) -> CollectionUpdate k a - updateAddItem (k, a, _) = AddItem k a - memoE $ (updateAddItem <$> newEvents) `mappend` (RemoveItem <$> removalEvent) - --- Adds the necessary state for holding the existing [(k, a)] and creating --- the unique Event stream for each change of the collection. -accumCollection - :: (Enum k, MonadSignalGen m) - => Event (CollectionUpdate k a) - -> m (Collection k a) -accumCollection = - genericAccumCollection (Proxy :: Proxy (EnumMap k)) - --- | Like "accumCollection", but uses any "Maplike" to maintain the --- internal state. This allows the user accumulate collections in the --- context of a wider variety of key constrints. The caller must specify --- the desired underyling "Maplike" type by providing a "Proxy". -genericAccumCollection - :: forall m c k a. (M.Maplike c k, MonadSignalGen m) - => Proxy (c k) - -> Event (CollectionUpdate k a) - -> m (Collection k a) -genericAccumCollection _ 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 - --- | The primitive interface for creating a 'Collection'. The two --- arguments must be coherent, i.e. the value of the discrete at --- time /t+1/ should be obtained by applying the updates --- at /t+1/ to the value of the discrete at /t/. This invariant --- is not checked. -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') - --- | Prints add/remove diagnostics for a Collection. Useful for debugging -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) - --- | An empty, unchanging Collection. -emptyCollection :: Collection k a -emptyCollection = collectionFromList [] - --- | A pure function to create a Collection from key-value pairs. This --- collection will never change. -collectionFromList :: [(k, a)] -> Collection k a -collectionFromList kvs = Collection $ pure (kvs, mempty) - --- | A somewhat inefficient but easy-to-use way of turning a list of --- items into a Collection. Probably should only be used for temporary --- hacks. Will perform badly with large lists. -collectionFromDiscreteList - :: (Enum k, Eq a, MonadSignalGen m) - => k - -> Discrete [a] - -> m (Collection k a) -collectionFromDiscreteList initialK valsD = do - valsE <- preservesD valsD - evs <- scanAccumE (initialK, EnumMap.empty) (stepListCollState <$> valsE) - accumCollection (flattenE evs) +import Data.Hashable (Hashable) --- This could obviously be implemented more efficiently. -stepListCollState :: (Enum k, Eq a) => [a] - -> (k, EnumMap k a) - -> ((k, EnumMap k a), [CollectionUpdate k a]) -stepListCollState xs (initialK, existingMap) = ((k', newMap'), removeUpdates ++ addUpdates) - where - keyvals = EnumMap.toList existingMap - newItems = xs \\ map snd keyvals - removedKeys = map fst $ deleteFirstsBy - (\(_, x) (_, y) -> x == y) - keyvals - (map (\x -> (initialK, x)) xs) - (newMap, removeUpdates) = foldl - (\(em, upds) k -> (EnumMap.delete k em, upds ++ [RemoveItem k])) - (existingMap, []) removedKeys - (k', newMap', addUpdates) = foldl - (\(k, em, upds) x -> (succ k, EnumMap.insert k x em, upds ++ [AddItem k x])) - (initialK, newMap, []) newItems +import FRP.Euphoria.EnumCollection.Lazy hiding (mapToCollection) -------------------------------------------------------------------------------- --- Converting Discrete Maps into Collections +import qualified FRP.Euphoria.EnumCollection.Lazy as Enum +import qualified FRP.Euphoria.HashCollection.Strict as Hashable -mapToCollection - :: (Eq k, Eq a, Ord k, MonadSignalGen m) - => Discrete (Map k a) - -> m (Collection k (Discrete a)) -mapToCollection = genericMapToCollection +import FRP.Euphoria.Event enummapToCollection :: (Eq k, Eq a, Enum k, MonadSignalGen m) => Discrete (EnumMap k a) -> m (Collection k (Discrete a)) -enummapToCollection = genericMapToCollection +enummapToCollection = Enum.mapToCollection hashmapToCollection :: (Eq k, Eq a, Hashable k, MonadSignalGen m) => Discrete (HashMap k a) -> m (Collection k (Discrete a)) -hashmapToCollection = genericMapToCollection +hashmapToCollection = Hashable.mapToCollection --- Generic implementation --------------------------- -data MapCollEvent k a - = MCNew k a - | MCChange k a - | MCRemove k - --- | Turns mapping of values into a collection of first-class FRP --- values that are updated. If items are added to the EnumMap, then --- they will be added to the Collection. Likewise, if they are removed --- from the mapping, they will be removed from the collection. Keys --- that are present in both but have new values will have their --- Discrete value updated, and keys with values that are still present --- will not have their Discrete values updated. -genericMapToCollection - :: forall c m k a. (Eq k, Eq a, M.Maplike c k, MonadSignalGen m) - => Discrete (c k a) - -> m (Collection k (Discrete a)) -genericMapToCollection mapD = do - m0 <- delayD M.empty mapD - let diffsD = diffMaps <$> m0 <*> mapD - diffsE <- flattenE <$> preservesD diffsD - dispatchCollEvent (Proxy :: Proxy (c k)) diffsE - --- | Given a pair of generic maps, compute a sequence of "MapCollEvent"s --- which would transform the first into the second. -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 mapProxy 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) - genericAccumCollection mapProxy 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 - -------------------------------------------------------------------------------- - --- | Look for a key in a collection, and give its (potentially --- nonexistant) value over time. -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') - --- Turn the existing items into AddItems for our state accumulation -initialAdds :: [(k, a)] -> [CollectionUpdate k a] -initialAdds = map (uncurry AddItem) - --- Accumulate CollectionUpdates, and keep the newest value whose key --- is True for the given function. -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 - --- | Extracts a 'Discrete' which represents the current state of --- a collection. -collectionToDiscreteList :: Collection k a -> Discrete [(k, a)] -collectionToDiscreteList = fmap fst . unCollection - --- | Extracts a snapshot of the current values in a collection with --- an 'Event' stream of further updates -openCollection :: MonadSignalGen m => Collection k a -> m ([(k,a)], Event (CollectionUpdate k a)) -openCollection = snapshotD . unCollection diff --git a/FRP/Euphoria/EnumCollection/Lazy.hs b/FRP/Euphoria/EnumCollection/Lazy.hs new file mode 100644 --- /dev/null +++ b/FRP/Euphoria/EnumCollection/Lazy.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} + +-- | FRP.Euphoria.Internal.GenericCollection, with an interface specialised for +-- "Enum" keys. +module FRP.Euphoria.EnumCollection.Lazy + ( CollectionUpdate (..) + , Collection + -- * creating collections + , simpleCollection + , accumCollection + , collectionToUpdates + , emptyCollection + , collectionFromList + , collectionFromDiscreteList + , makeCollection + , mapToCollection + -- * observing collections + , watchCollection + , followCollectionKey + , collectionToDiscreteList + , openCollection + -- * other functions + , mapCollection + , mapCollectionWithKey + , filterCollection + , filterCollectionWithKey + , justCollection + , mapCollectionM + , sequenceCollection + ) where + +import Data.EnumMap.Lazy (EnumMap) +import Data.Proxy (Proxy(..)) + +import FRP.Euphoria.Event +import qualified FRP.Euphoria.Internal.GenericCollection as Gen +import FRP.Euphoria.Internal.GenericCollection hiding (filterCollection + , filterCollectionWithKey, justCollection, sequenceCollection + , accumCollection, mapToCollection, simpleCollection + , collectionFromDiscreteList, mapCollectionM) +import FRP.Euphoria.Internal.Maplike + +filterCollection + :: (Enum k, MonadSignalGen m) + => (a -> Bool) + -> Collection k a + -> m (Collection k a) +filterCollection = + Gen.filterCollection (Proxy :: Proxy (Lazy EnumMap k)) + +filterCollectionWithKey + :: (Enum k, MonadSignalGen m) + => (k -> a -> Bool) + -> Collection k a + -> m (Collection k a) +filterCollectionWithKey = + Gen.filterCollectionWithKey (Proxy :: Proxy (Lazy EnumMap k)) + +justCollection + :: (Enum k, MonadSignalGen m) + => Collection k (Maybe a) + -> m (Collection k a) +justCollection = + Gen.justCollection (Proxy :: Proxy (Lazy EnumMap k)) + +mapCollectionM + :: (Enum k, MonadSignalGen m) + => (a -> SignalGen b) -> Collection k a -> m (Collection k b) +mapCollectionM = Gen.mapCollectionM (Proxy :: Proxy (Lazy EnumMap k)) + +sequenceCollection + :: (Enum k, MonadSignalGen m) + => Collection k (SignalGen a) + -> m (Collection k a) +sequenceCollection = + Gen.sequenceCollection (Proxy :: Proxy (Lazy EnumMap k)) + +-- Adds the necessary state for holding the existing [(k, a)] and creating +-- the unique Event stream for each change of the collection. +accumCollection + :: (Enum k, MonadSignalGen m) + => Event (CollectionUpdate k a) + -> m (Collection k a) +accumCollection = + Gen.accumCollection (Proxy :: Proxy (Lazy EnumMap k)) + +mapToCollection + :: (Eq k, Eq a, Enum k, MonadSignalGen m) + => Discrete (EnumMap k a) + -> m (Collection k (Discrete a)) +mapToCollection xsD = + Gen.mapToCollection (Lazy <$> xsD) + +simpleCollection + :: (Enum k, MonadSignalGen m) + => k + -> Event (a, Event ()) + -> m (Collection k a) +simpleCollection = + Gen.simpleCollection (Proxy :: Proxy (Lazy EnumMap k)) + +collectionFromDiscreteList + :: (Enum k, Eq a, MonadSignalGen m) + => k + -> Discrete [a] + -> m (Collection k a) +collectionFromDiscreteList = + Gen.collectionFromDiscreteList (Proxy :: Proxy (Lazy EnumMap k)) diff --git a/FRP/Euphoria/EnumCollection/Strict.hs b/FRP/Euphoria/EnumCollection/Strict.hs new file mode 100644 --- /dev/null +++ b/FRP/Euphoria/EnumCollection/Strict.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} + +-- | FRP.Euphoria.Internal.GenericCollection, with an interface specialised for +-- "Enum" keys. +module FRP.Euphoria.EnumCollection.Strict + ( CollectionUpdate (..) + , Collection + -- * creating collections + , simpleCollection + , accumCollection + , collectionToUpdates + , emptyCollection + , collectionFromList + , collectionFromDiscreteList + , makeCollection + , mapToCollection + -- * observing collections + , watchCollection + , followCollectionKey + , collectionToDiscreteList + , openCollection + -- * other functions + , mapCollection + , mapCollectionWithKey + , filterCollection + , filterCollectionWithKey + , justCollection + , mapCollectionM + , sequenceCollection + ) where + +import Data.EnumMap.Strict (EnumMap) +import Data.Proxy (Proxy(..)) + +import FRP.Euphoria.Event +import qualified FRP.Euphoria.Internal.GenericCollection as Gen +import FRP.Euphoria.Internal.GenericCollection hiding (filterCollection + , filterCollectionWithKey, justCollection, sequenceCollection + , accumCollection, mapToCollection, simpleCollection + , collectionFromDiscreteList, mapCollectionM) +import FRP.Euphoria.Internal.Maplike + +filterCollection + :: (Enum k, MonadSignalGen m) + => (a -> Bool) + -> Collection k a + -> m (Collection k a) +filterCollection = + Gen.filterCollection (Proxy :: Proxy (Strict EnumMap k)) + +filterCollectionWithKey + :: (Enum k, MonadSignalGen m) + => (k -> a -> Bool) + -> Collection k a + -> m (Collection k a) +filterCollectionWithKey = + Gen.filterCollectionWithKey (Proxy :: Proxy (Strict EnumMap k)) + +justCollection + :: (Enum k, MonadSignalGen m) + => Collection k (Maybe a) + -> m (Collection k a) +justCollection = + Gen.justCollection (Proxy :: Proxy (Strict EnumMap k)) + +mapCollectionM + :: (Enum k, MonadSignalGen m) + => (a -> SignalGen b) -> Collection k a -> m (Collection k b) +mapCollectionM = Gen.mapCollectionM (Proxy :: Proxy (Strict EnumMap k)) + +sequenceCollection + :: (Enum k, MonadSignalGen m) + => Collection k (SignalGen a) + -> m (Collection k a) +sequenceCollection = + Gen.sequenceCollection (Proxy :: Proxy (Strict EnumMap k)) + +-- Adds the necessary state for holding the existing [(k, a)] and creating +-- the unique Event stream for each change of the collection. +accumCollection + :: (Enum k, MonadSignalGen m) + => Event (CollectionUpdate k a) + -> m (Collection k a) +accumCollection = + Gen.accumCollection (Proxy :: Proxy (Strict EnumMap k)) + +mapToCollection + :: (Eq k, Eq a, Enum k, MonadSignalGen m) + => Discrete (EnumMap k a) + -> m (Collection k (Discrete a)) +mapToCollection xsD = + Gen.mapToCollection (Strict <$> xsD) + +simpleCollection + :: (Enum k, MonadSignalGen m) + => k + -> Event (a, Event ()) + -> m (Collection k a) +simpleCollection = + Gen.simpleCollection (Proxy :: Proxy (Strict EnumMap k)) + +collectionFromDiscreteList + :: (Enum k, Eq a, MonadSignalGen m) + => k + -> Discrete [a] + -> m (Collection k a) +collectionFromDiscreteList = + Gen.collectionFromDiscreteList (Proxy :: Proxy (Strict EnumMap k)) diff --git a/FRP/Euphoria/Event.hs b/FRP/Euphoria/Event.hs --- a/FRP/Euphoria/Event.hs +++ b/FRP/Euphoria/Event.hs @@ -71,7 +71,6 @@ -- ** Accumulation , stepperD -, stepperDefD , stepperMaybeD , justD , accumD @@ -126,7 +125,6 @@ import Control.Monad (join, replicateM) import Control.Monad.Fix import Control.Monad.IO.Class -import Data.Default import Data.Either (partitionEithers, lefts, rights) import Data.List (foldl') import Data.Monoid @@ -134,7 +132,7 @@ import Data.Typeable import Debug.Trace import FRP.Euphoria.Signal -import FRP.Elerea.Simple (externalMulti, effectful1, until, stateful) +import FRP.Elerea.Simple.Compat (externalMulti, effectful1, till, stateful) import Prelude hiding (until) -- | @Event a@ represents a stream of events whose occurrences carry @@ -400,7 +398,7 @@ -> m (Event a) generalPrefixE prefixTaker (Event evt) = do rec - done <- liftSignalGen $ until $ not . fst <$> active_occs + done <- liftSignalGen $ till $ not . fst <$> active_occs prevDone <- delayS False done eventSource <- transferS evt upd prevDone active_occs <- prefixTaker (join eventSource) @@ -516,14 +514,10 @@ upd [] (_, old) = (False, old) upd occs _ = (True, last occs) --- | Use a 'Default' instance to supply the initial value. -stepperDefD :: (Default a, MonadSignalGen m) => Event a -> m (Discrete a) -stepperDefD = stepperD def - -- | Use 'Nothing' to supply the initial value, and wrap the returned -- type in 'Maybe'. stepperMaybeD :: MonadSignalGen m => Event a -> m (Discrete (Maybe a)) -stepperMaybeD ev = stepperDefD (Just <$> ev) +stepperMaybeD ev = stepperD Nothing (Just <$> ev) -- | Given an initial value, filter out the Nothings. justD :: MonadSignalGen m => a -> Discrete (Maybe a) -> m (Discrete a) @@ -631,11 +625,9 @@ freezeD :: MonadSignalGen m => Event () -> Discrete a -> m (Discrete a) freezeD evt dis = do dis' <- memoD dis - now <- onCreation () sig <- discreteToSignal dis' - initialization <- takeE 1 $ const <$> sig <@> now - filteredChanges <- switchD =<< stepperD (changesD dis') (mempty <$ evt) - stepperD (error "freezeD: not initialized") $ initialization `mappend` filteredChanges + evt1 <- takeE 1 evt + switchD =<< stepperD dis' (pure <$> sig <@ evt1) -- | Convert a 'Signal' to an equivalent 'Discrete'. The resulting discrete -- is always considered to \'possibly have changed\'. diff --git a/FRP/Euphoria/HashCollection/Lazy.hs b/FRP/Euphoria/HashCollection/Lazy.hs new file mode 100644 --- /dev/null +++ b/FRP/Euphoria/HashCollection/Lazy.hs @@ -0,0 +1,109 @@ +{-# OPTIONS_GHC -Wall #-} + +-- | FRP.Euphoria.Internal.GenericCollection, with an interface specialised for +-- "Hashable" keys. +module FRP.Euphoria.HashCollection.Lazy + ( CollectionUpdate (..) + , Collection + -- * creating collections + , simpleCollection + , accumCollection + , collectionToUpdates + , emptyCollection + , collectionFromList + , collectionFromDiscreteList + , makeCollection + , mapToCollection + -- * observing collections + , watchCollection + , followCollectionKey + , collectionToDiscreteList + , openCollection + -- * other functions + , mapCollection + , mapCollectionWithKey + , filterCollection + , filterCollectionWithKey + , justCollection + , mapCollectionM + , sequenceCollection + ) where + +import Data.Hashable (Hashable) +import Data.HashMap.Lazy (HashMap) +import Data.Proxy (Proxy(..)) + +import FRP.Euphoria.Event +import qualified FRP.Euphoria.Internal.GenericCollection as Gen +import FRP.Euphoria.Internal.GenericCollection hiding (filterCollection + , filterCollectionWithKey, justCollection, sequenceCollection + , accumCollection, mapToCollection, simpleCollection + , collectionFromDiscreteList, mapCollectionM) +import FRP.Euphoria.Internal.Maplike + +filterCollection + :: (Hashable k, Eq k, MonadSignalGen m) + => (a -> Bool) + -> Collection k a + -> m (Collection k a) +filterCollection = + Gen.filterCollection (Proxy :: Proxy (Lazy HashMap k)) + +filterCollectionWithKey + :: (Hashable k, Eq k, MonadSignalGen m) + => (k -> a -> Bool) + -> Collection k a + -> m (Collection k a) +filterCollectionWithKey = + Gen.filterCollectionWithKey (Proxy :: Proxy (Lazy HashMap k)) + +justCollection + :: (Hashable k, Eq k, MonadSignalGen m) + => Collection k (Maybe a) + -> m (Collection k a) +justCollection = + Gen.justCollection (Proxy :: Proxy (Lazy HashMap k)) + +mapCollectionM + :: (Eq k, Hashable k, MonadSignalGen m) + => (a -> SignalGen b) -> Collection k a -> m (Collection k b) +mapCollectionM = Gen.mapCollectionM (Proxy :: Proxy (Lazy HashMap k)) + +sequenceCollection + :: (Hashable k, Eq k, MonadSignalGen m) + => Collection k (SignalGen a) + -> m (Collection k a) +sequenceCollection = + Gen.sequenceCollection (Proxy :: Proxy (Lazy HashMap k)) + +-- Adds the necessary state for holding the existing [(k, a)] and creating +-- the unique Event stream for each change of the collection. +accumCollection + :: (Hashable k, Eq k, MonadSignalGen m) + => Event (CollectionUpdate k a) + -> m (Collection k a) +accumCollection = + Gen.accumCollection (Proxy :: Proxy (Lazy HashMap k)) + +mapToCollection + :: (Eq k, Eq a, Hashable k, MonadSignalGen m) + => Discrete (HashMap k a) + -> m (Collection k (Discrete a)) +mapToCollection xsD = + Gen.mapToCollection (Lazy <$> xsD) + +simpleCollection + :: (Enum k, Eq k, Hashable k, MonadSignalGen m) + => k + -> Event (a, Event ()) + -> m (Collection k a) +simpleCollection = + Gen.simpleCollection (Proxy :: Proxy (Lazy HashMap k)) + +collectionFromDiscreteList + :: (Enum k, Eq k, Hashable k, Eq a, MonadSignalGen m) + => k + -> Discrete [a] + -> m (Collection k a) +collectionFromDiscreteList = + Gen.collectionFromDiscreteList (Proxy :: Proxy (Lazy HashMap k)) diff --git a/FRP/Euphoria/HashCollection/Strict.hs b/FRP/Euphoria/HashCollection/Strict.hs new file mode 100644 --- /dev/null +++ b/FRP/Euphoria/HashCollection/Strict.hs @@ -0,0 +1,109 @@ +{-# OPTIONS_GHC -Wall #-} + +-- | FRP.Euphoria.Internal.GenericCollection, with an interface specialised for +-- "Hashable" keys. +module FRP.Euphoria.HashCollection.Strict + ( CollectionUpdate (..) + , Collection + -- * creating collections + , simpleCollection + , accumCollection + , collectionToUpdates + , emptyCollection + , collectionFromList + , collectionFromDiscreteList + , makeCollection + , mapToCollection + -- * observing collections + , watchCollection + , followCollectionKey + , collectionToDiscreteList + , openCollection + -- * other functions + , mapCollection + , mapCollectionWithKey + , filterCollection + , filterCollectionWithKey + , justCollection + , mapCollectionM + , sequenceCollection + ) where + +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import Data.Proxy (Proxy(..)) + +import FRP.Euphoria.Event +import qualified FRP.Euphoria.Internal.GenericCollection as Gen +import FRP.Euphoria.Internal.GenericCollection hiding (filterCollection + , filterCollectionWithKey, justCollection, sequenceCollection + , accumCollection, mapToCollection, simpleCollection + , collectionFromDiscreteList, mapCollectionM) +import FRP.Euphoria.Internal.Maplike + +filterCollection + :: (Hashable k, Eq k, MonadSignalGen m) + => (a -> Bool) + -> Collection k a + -> m (Collection k a) +filterCollection = + Gen.filterCollection (Proxy :: Proxy (Strict HashMap k)) + +filterCollectionWithKey + :: (Hashable k, Eq k, MonadSignalGen m) + => (k -> a -> Bool) + -> Collection k a + -> m (Collection k a) +filterCollectionWithKey = + Gen.filterCollectionWithKey (Proxy :: Proxy (Strict HashMap k)) + +justCollection + :: (Hashable k, Eq k, MonadSignalGen m) + => Collection k (Maybe a) + -> m (Collection k a) +justCollection = + Gen.justCollection (Proxy :: Proxy (Strict HashMap k)) + +mapCollectionM + :: (Eq k, Hashable k, MonadSignalGen m) + => (a -> SignalGen b) -> Collection k a -> m (Collection k b) +mapCollectionM = Gen.mapCollectionM (Proxy :: Proxy (Strict HashMap k)) + +sequenceCollection + :: (Hashable k, Eq k, MonadSignalGen m) + => Collection k (SignalGen a) + -> m (Collection k a) +sequenceCollection = + Gen.sequenceCollection (Proxy :: Proxy (Strict HashMap k)) + +-- Adds the necessary state for holding the existing [(k, a)] and creating +-- the unique Event stream for each change of the collection. +accumCollection + :: (Hashable k, Eq k, MonadSignalGen m) + => Event (CollectionUpdate k a) + -> m (Collection k a) +accumCollection = + Gen.accumCollection (Proxy :: Proxy (Strict HashMap k)) + +mapToCollection + :: (Eq k, Eq a, Hashable k, MonadSignalGen m) + => Discrete (HashMap k a) + -> m (Collection k (Discrete a)) +mapToCollection xsD = + Gen.mapToCollection (Strict <$> xsD) + +simpleCollection + :: (Enum k, Eq k, Hashable k, MonadSignalGen m) + => k + -> Event (a, Event ()) + -> m (Collection k a) +simpleCollection = + Gen.simpleCollection (Proxy :: Proxy (Strict HashMap k)) + +collectionFromDiscreteList + :: (Enum k, Eq k, Hashable k, Eq a, MonadSignalGen m) + => k + -> Discrete [a] + -> m (Collection k a) +collectionFromDiscreteList = + Gen.collectionFromDiscreteList (Proxy :: Proxy (Strict HashMap k)) diff --git a/FRP/Euphoria/Internal/GenericCollection.hs b/FRP/Euphoria/Internal/GenericCollection.hs new file mode 100644 --- /dev/null +++ b/FRP/Euphoria/Internal/GenericCollection.hs @@ -0,0 +1,442 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecursiveDo #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Collection signals with incremental updates. +-- +-- The interface exposed by this module uses "Maplike" extensively. This +-- allows it to be used in the context of a wider variety of key +-- constrints, at the cost of requiring the caller to provide a "Proxy". +-- This is pretty inconvenient, so it's recommended that people use one of +-- the specialised modules: +-- +-- - FRP.Euphoria.Collection.Enum +-- - FRP.Euphoria.Collection.Hashable +-- +module FRP.Euphoria.Internal.GenericCollection + ( CollectionUpdate (..) + , Collection + -- * creating collections + , simpleCollection + , accumCollection + , collectionToUpdates + , emptyCollection + , collectionFromList + , collectionFromDiscreteList + , makeCollection + , mapToCollection + -- * observing collections + , watchCollection + , followCollectionKey + , collectionToDiscreteList + , openCollection + -- * other functions + , 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 + +-- | Represents an incremental change to a collection of items. +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) + +-- | An FRP interface for representing an incrementally updated +-- collection of items. The items are identified by a unique key. +-- Items may be added or removed from the current collection. +-- +-- This type is useful because it allows you to manage the incremental +-- state updates to something that needs a collection of items without +-- having to rebuild it completely every time the collection changes. +-- Consider the type Signal [a] -- functionally, it also represents a +-- collection of items that changes over time. However, there is no +-- state carried between changes. If, for example, we have a GUI +-- widget that lists items whose content is represented as a Signal +-- [a], we would have to destroy and rebuild the widget's internal +-- state every time the list contents change. But with the Collection +-- type, we can add or remove from the GUI widget only the necessary +-- items. This is useful both from a performance (most existing GUI +-- toolkits exhibit worse performance when adding and removing all +-- items with every change) and behavior standpoint, because the GUI +-- toolkit can, for example, remember which items the user had +-- selected between list updates. +-- +-- Usage of 'Collection' implies there could be some caching/state by +-- the consumer of the Events, otherwise one might as well use a +-- Signal [a]. +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 + +-- | Like 'fmap', but the Collection and interior 'Event' stream are memoized +mapCollection :: MonadSignalGen m => (a -> b) -> Collection k a -> m (Collection k b) +mapCollection = mapCollectionWithKey . const + +-- | @mapCollectionM p fn = mapCollection fn >=> sequenceCollection p@ +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 + +-- | A version of 'mapCollection' which provides access to the key +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 + -- f applied to tuples and collection updates + 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) +-- Inefficient, quick-hack implementation +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') + +-- | Create an 'Event' stream of all updates from a collection, including +-- the items currently in it. +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 + +-- | A collection whose items are created by an event, and removed by +-- another event. +simpleCollection + :: (M.Maplike c k, Enum k, MonadSignalGen m) + => Proxy (c k) + -> k -- ^ The initial value for the unique keys. + -- 'succ' will be used to get further keys. + -> Event (a, Event ()) -- ^ An Event that introduces a new item and + -- its subsequent removal Event. The item will + -- be removed from the collection when the + -- Event () fires. + -> 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) + +-- Adds the necessary state for holding the existing [(k, a)] and creating +-- the unique Event stream for each change of the collection. +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 + +-- | The primitive interface for creating a 'Collection'. The two +-- arguments must be coherent, i.e. the value of the discrete at +-- time /t+1/ should be obtained by applying the updates +-- at /t+1/ to the value of the discrete at /t/. This invariant +-- is not checked. +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') + +-- | Prints add/remove diagnostics for a Collection. Useful for debugging +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) + +-- | An empty, unchanging Collection. +emptyCollection :: Collection k a +emptyCollection = collectionFromList [] + +-- | A pure function to create a Collection from key-value pairs. This +-- collection will never change. +collectionFromList :: [(k, a)] -> Collection k a +collectionFromList kvs = Collection $ pure (kvs, mempty) + +-- | A somewhat inefficient but easy-to-use way of turning a list of +-- items into a Collection. Probably should only be used for temporary +-- hacks. Will perform badly with large lists. +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) + +-- This could obviously be implemented more efficiently. +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 + +------------------------------------------------------------------------------- +-- Converting Discrete Maps into Collections + +data MapCollEvent k a + = MCNew k a + | MCChange k a + | MCRemove k + +-- | Turns mapping of values into a collection of first-class FRP +-- values that are updated. If items are added to the EnumMap, then +-- they will be added to the Collection. Likewise, if they are removed +-- from the mapping, they will be removed from the collection. Keys +-- that are present in both but have new values will have their +-- Discrete value updated, and keys with values that are still present +-- will not have their Discrete values updated. +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 + +-- | Given a pair of generic maps, compute a sequence of "MapCollEvent"s +-- which would transform the first into the second. +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 + +------------------------------------------------------------------------------- + +-- | Look for a key in a collection, and give its (potentially +-- nonexistant) value over time. +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') + +-- Turn the existing items into AddItems for our state accumulation +initialAdds :: [(k, a)] -> [CollectionUpdate k a] +initialAdds = map (uncurry AddItem) + +-- Accumulate CollectionUpdates, and keep the newest value whose key +-- is True for the given function. +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 + +-- | Extracts a 'Discrete' which represents the current state of +-- a collection. +collectionToDiscreteList :: Collection k a -> Discrete [(k, a)] +collectionToDiscreteList = fmap fst . unCollection + +-- | Extracts a snapshot of the current values in a collection with +-- an 'Event' stream of further updates +openCollection :: MonadSignalGen m => Collection k a -> m ([(k,a)], Event (CollectionUpdate k a)) +openCollection = snapshotD . unCollection diff --git a/FRP/Euphoria/Internal/Maplike.hs b/FRP/Euphoria/Internal/Maplike.hs --- a/FRP/Euphoria/Internal/Maplike.hs +++ b/FRP/Euphoria/Internal/Maplike.hs @@ -1,17 +1,27 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} -- NOTE (asayers): I suppose this module doesn't really belong in -- euphoria... but I don't think it deserves its own package. module FRP.Euphoria.Internal.Maplike ( Maplike(..) + , Lazy(..) + , Strict(..) ) where +import Data.Function import Data.Hashable (Hashable) -import qualified Data.Map as Map +import qualified Data.Map.Lazy as ML +import qualified Data.Map.Strict as MS +import qualified Data.HashMap.Lazy as HML import qualified Data.HashMap.Strict as HMS import qualified Data.EnumMap.Lazy as EML +import qualified Data.EnumMap.Strict as EMS +newtype Lazy c k v = Lazy (c k v) +newtype Strict c k v = Strict (c k v) + -- | A class for types with an API similar to that of "Data.Map". class Maplike c k where union :: c k v -> c k v -> c k v @@ -26,36 +36,76 @@ delete :: k -> c k v -> c k v delete k m = m `difference` singleton k (error "bug") toList :: c k v -> [(k, v)] + foldrWithKey :: (k -> v -> a -> a) -> a -> c k v -> a -instance Ord k => Maplike Map.Map k where - union = Map.union - intersection = Map.intersection - difference = (Map.\\) - empty = Map.empty - lookup = Map.lookup - singleton = Map.singleton - insert = Map.insert - delete = Map.delete - toList = Map.toList +instance Ord k => Maplike (Lazy ML.Map) k where + union (Lazy x) (Lazy y) = Lazy $ ML.union x y + intersection (Lazy x) (Lazy y) = Lazy $ ML.intersection x y + difference (Lazy x) (Lazy y) = Lazy $ x ML.\\ y + empty = Lazy ML.empty + lookup k (Lazy x) = ML.lookup k x + singleton k v = Lazy $ ML.singleton k v + insert k v (Lazy x) = Lazy $ ML.insert k v x + delete k (Lazy x) = Lazy $ ML.delete k x + toList (Lazy x) = ML.toList x + foldrWithKey f a (Lazy x) = ML.foldrWithKey f a x -instance Enum k => Maplike EML.EnumMap k where - union = EML.union - intersection = EML.intersection - difference = (EML.\\) - empty = EML.empty - lookup = EML.lookup - singleton = EML.singleton - insert = EML.insert - delete = EML.delete - toList = EML.toList +instance Ord k => Maplike (Strict MS.Map) k where + union (Strict x) (Strict y) = Strict $ MS.union x y + intersection (Strict x) (Strict y) = Strict $ MS.intersection x y + difference (Strict x) (Strict y) = Strict $ x MS.\\ y + empty = Strict MS.empty + lookup k (Strict x) = MS.lookup k x + singleton k v = Strict $ MS.singleton k v + insert k v (Strict x) = Strict $ MS.insert k v x + delete k (Strict x) = Strict $ MS.delete k x + toList (Strict x) = MS.toList x + foldrWithKey f a (Strict x) = MS.foldrWithKey f a x -instance (Eq k, Hashable k) => Maplike HMS.HashMap k where - union = HMS.union - intersection = HMS.intersection - difference = HMS.difference - empty = HMS.empty - lookup = HMS.lookup - singleton = HMS.singleton - insert = HMS.insert - delete = HMS.delete - toList = HMS.toList +instance Enum k => Maplike (Lazy EML.EnumMap) k where + union (Lazy x) (Lazy y) = Lazy $ EML.union x y + intersection (Lazy x) (Lazy y) = Lazy $ EML.intersection x y + difference (Lazy x) (Lazy y) = Lazy $ x EML.\\ y + empty = Lazy EML.empty + lookup k (Lazy x) = EML.lookup k x + singleton k v = Lazy $ EML.singleton k v + insert k v (Lazy x) = Lazy $ EML.insert k v x + delete k (Lazy x) = Lazy $ EML.delete k x + toList (Lazy x) = EML.toList x + foldrWithKey f a (Lazy x) = EML.foldrWithKey f a x + +instance Enum k => Maplike (Strict EMS.EnumMap) k where + union (Strict x) (Strict y) = Strict $ EMS.union x y + intersection (Strict x) (Strict y) = Strict $ EMS.intersection x y + difference (Strict x) (Strict y) = Strict $ x EMS.\\ y + empty = Strict EMS.empty + lookup k (Strict x) = EMS.lookup k x + singleton k v = Strict $ EMS.singleton k v + insert k v (Strict x) = Strict $ EMS.insert k v x + delete k (Strict x) = Strict $ EMS.delete k x + toList (Strict x) = EMS.toList x + foldrWithKey f a (Strict x) = EMS.foldrWithKey f a x + +instance (Eq k, Hashable k) => Maplike (Lazy HML.HashMap) k where + union (Lazy x) (Lazy y) = Lazy $ HML.union x y + intersection (Lazy x) (Lazy y) = Lazy $ HML.intersection x y + difference (Lazy x) (Lazy y) = Lazy $ HML.difference x y + empty = Lazy HML.empty + lookup k (Lazy x) = HML.lookup k x + singleton k v = Lazy $ HML.singleton k v + insert k v (Lazy x) = Lazy $ HML.insert k v x + delete k (Lazy x) = Lazy $ HML.delete k x + toList (Lazy x) = HML.toList x + foldrWithKey f a (Lazy x) = HML.foldrWithKey f a x + +instance (Eq k, Hashable k) => Maplike (Strict HMS.HashMap) k where + union (Strict x) (Strict y) = Strict $ HMS.union x y + intersection (Strict x) (Strict y) = Strict $ HMS.intersection x y + difference (Strict x) (Strict y) = Strict $ HMS.difference x y + empty = Strict HMS.empty + lookup k (Strict x) = HMS.lookup k x + singleton k v = Strict $ HMS.singleton k v + insert k v (Strict x) = Strict $ HMS.insert k v x + delete k (Strict x) = Strict $ HMS.delete k x + toList (Strict x) = HMS.toList x + foldrWithKey f a (Strict x) = HMS.foldrWithKey f a x diff --git a/FRP/Euphoria/Update.hs b/FRP/Euphoria/Update.hs --- a/FRP/Euphoria/Update.hs +++ b/FRP/Euphoria/Update.hs @@ -106,6 +106,7 @@ mappendUpdateIO :: Monoid a => Update (IO a) -> Update (IO a) -> Update (IO a) mappendUpdateIO d1 d2 = unIOMonoid <$> ((IOMonoid <$> d1) `mappend` (IOMonoid <$> d2)) {-# RULES "mappendUpdateIO/()" mappendUpdateIO = mappendUpdateIOUnit #-} +{-# INLINE[0] mappendUpdateIO #-} -- | Do the same thing as 'mappendUpdateIO' but specialized to 'IO ()' mappendUpdateIOUnit :: Update (IO ()) -> Update (IO ()) -> Update (IO ()) diff --git a/benchmarks/FRP/Euphoria/EnumCollection/Lazy/Bench.hs b/benchmarks/FRP/Euphoria/EnumCollection/Lazy/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/FRP/Euphoria/EnumCollection/Lazy/Bench.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + +module FRP.Euphoria.EnumCollection.Lazy.Bench + ( benchmarks + ) where + +import Control.DeepSeq +import Control.Monad +import Criterion +import qualified Data.EnumMap.Lazy as EML +import Data.List +import FRP.Euphoria.Event +import FRP.Euphoria.EnumCollection.Lazy +import GHC.Generics + +benchmarks :: Benchmark +benchmarks = env mkEnv $ \ ~e -> bgroup "EnumCollection.Lazy" + [ bench "mapToCollectionSmall" $ bench_mapToCollection (smallDict e) + , bench "mapToCollectionBig" $ bench_mapToCollection (bigDict e) + , bench "accumSmall" $ bench_accum (smallUpdates e) + , bench "accumBig" $ bench_accum (bigUpdates e) + , bench "transformAccumSmall" $ bench_transformAccum (smallUpdates e) + , bench "transformAccumBig" $ bench_transformAccum (bigUpdates e) + , bench "fromListSmall" $ bench_fromList (smallList e) + , bench "fromListBig" $ bench_fromList (bigList e) + , bench "transformListSmall" $ bench_transform (smallList e) + , bench "transformListBig" $ bench_transform (bigList e) + ] + +data BenchmarkEnv = BenchmarkEnv + { smallList :: [[Int]] + , bigList :: [[Int]] + , smallUpdates :: [CollectionUpdate Int Int] + , bigUpdates :: [CollectionUpdate Int Int] + , smallDict :: EML.EnumMap Int Int + , bigDict :: EML.EnumMap Int Int + } deriving (Generic) + +instance NFData BenchmarkEnv + +mkEnv :: IO BenchmarkEnv +mkEnv = do + let smallList = map (\i -> [1..i]) [0..10] + let bigList = map (\i -> [1..i]) [0..100] + let smallUpdates = map (\i -> let (v,k) = 100 `divMod` i in AddItem k v) [1..101] + let bigUpdates = map (\i -> let (v,k) = 200 `divMod` i in AddItem k v) [1..201] + let smallDict = foldl' (\acc i -> let (v,k) = 100 `divMod` i in EML.insert k v acc) EML.empty [1..101] + let bigDict = foldl' (\acc i -> let (v,k) = 200 `divMod` i in EML.insert k v acc) EML.empty [1..201] + return BenchmarkEnv{..} + +bench_fromList :: [[Int]] -> Benchmarkable +bench_fromList list = + nfIO $ networkToList (length list) $ do + listD <- signalToDiscrete <$> signalFromList list + coll <- collectionFromDiscreteList (0 :: Int) listD + discreteToSignal $ collectionToDiscreteList coll + +bench_transform :: [[Int]] -> Benchmarkable +bench_transform list = + nfIO $ networkToList (length list) $ do + listD <- signalToDiscrete <$> signalFromList list + coll0 <- collectionFromDiscreteList (0 :: Int) listD + coll1 <- filterCollection even coll0 + coll2 <- mapCollection (\x -> if x `mod` 5 == 0 then Just x else Nothing) coll1 + coll3 <- justCollection coll2 + discreteToSignal $ collectionToDiscreteList coll3 + +bench_accum :: [CollectionUpdate Int Int] -> Benchmarkable +bench_accum updates = + nfIO $ networkToList (length updates) $ do + updatesE <- signalToEvent <$> signalFromList (map pure updates) + coll <- accumCollection updatesE + discreteToSignal $ collectionToDiscreteList coll + +bench_transformAccum :: [CollectionUpdate Int Int] -> Benchmarkable +bench_transformAccum updates = + nfIO $ networkToList (length updates) $ do + updatesE <- signalToEvent <$> signalFromList (map pure updates) + coll0 <- accumCollection updatesE + coll1 <- filterCollection even coll0 + coll2 <- mapCollection (\x -> if x `mod` 5 == 0 then Just x else Nothing) coll1 + coll3 <- justCollection coll2 + discreteToSignal $ collectionToDiscreteList coll3 + +bench_mapToCollection :: EML.EnumMap Int Int -> Benchmarkable +bench_mapToCollection dict = + nfIO $ networkToList 1 $ do + coll <- mapToCollection (pure dict) + let mangle :: Discrete [(a, Discrete b)] -> Discrete [(a, b)] + mangle = join . fmap (sequence . map sequence) + discreteToSignal $ mangle $ collectionToDiscreteList coll diff --git a/benchmarks/FRP/Euphoria/EnumCollection/Strict/Bench.hs b/benchmarks/FRP/Euphoria/EnumCollection/Strict/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/FRP/Euphoria/EnumCollection/Strict/Bench.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + +module FRP.Euphoria.EnumCollection.Strict.Bench + ( benchmarks + ) where + +import Control.DeepSeq +import Control.Monad +import Criterion +import qualified Data.EnumMap.Strict as EMS +import Data.List +import FRP.Euphoria.Event +import FRP.Euphoria.EnumCollection.Strict +import GHC.Generics + +benchmarks :: Benchmark +benchmarks = env mkEnv $ \ ~e -> bgroup "EnumCollection.Strict" + [ bench "mapToCollectionSmall" $ bench_mapToCollection (smallDict e) + , bench "mapToCollectionBig" $ bench_mapToCollection (bigDict e) + , bench "accumSmall" $ bench_accum (smallUpdates e) + , bench "accumBig" $ bench_accum (bigUpdates e) + , bench "transformAccumSmall" $ bench_transformAccum (smallUpdates e) + , bench "transformAccumBig" $ bench_transformAccum (bigUpdates e) + , bench "fromListSmall" $ bench_fromList (smallList e) + , bench "fromListBig" $ bench_fromList (bigList e) + , bench "transformListSmall" $ bench_transform (smallList e) + , bench "transformListBig" $ bench_transform (bigList e) + ] + +data BenchmarkEnv = BenchmarkEnv + { smallList :: [[Int]] + , bigList :: [[Int]] + , smallUpdates :: [CollectionUpdate Int Int] + , bigUpdates :: [CollectionUpdate Int Int] + , smallDict :: EMS.EnumMap Int Int + , bigDict :: EMS.EnumMap Int Int + } deriving (Generic) + +instance NFData BenchmarkEnv + +mkEnv :: IO BenchmarkEnv +mkEnv = do + let smallList = map (\i -> [1..i]) [0..10] + let bigList = map (\i -> [1..i]) [0..100] + let smallUpdates = map (\i -> let (v,k) = 100 `divMod` i in AddItem k v) [1..101] + let bigUpdates = map (\i -> let (v,k) = 200 `divMod` i in AddItem k v) [1..201] + let smallDict = foldl' (\acc i -> let (v,k) = 100 `divMod` i in EMS.insert k v acc) EMS.empty [1..101] + let bigDict = foldl' (\acc i -> let (v,k) = 200 `divMod` i in EMS.insert k v acc) EMS.empty [1..201] + return BenchmarkEnv{..} + +bench_fromList :: [[Int]] -> Benchmarkable +bench_fromList list = + nfIO $ networkToList (length list) $ do + listD <- signalToDiscrete <$> signalFromList list + coll <- collectionFromDiscreteList (0 :: Int) listD + discreteToSignal $ collectionToDiscreteList coll + +bench_transform :: [[Int]] -> Benchmarkable +bench_transform list = + nfIO $ networkToList (length list) $ do + listD <- signalToDiscrete <$> signalFromList list + coll0 <- collectionFromDiscreteList (0 :: Int) listD + coll1 <- filterCollection even coll0 + coll2 <- mapCollection (\x -> if x `mod` 5 == 0 then Just x else Nothing) coll1 + coll3 <- justCollection coll2 + discreteToSignal $ collectionToDiscreteList coll3 + +bench_accum :: [CollectionUpdate Int Int] -> Benchmarkable +bench_accum updates = + nfIO $ networkToList (length updates) $ do + updatesE <- signalToEvent <$> signalFromList (map pure updates) + coll <- accumCollection updatesE + discreteToSignal $ collectionToDiscreteList coll + +bench_transformAccum :: [CollectionUpdate Int Int] -> Benchmarkable +bench_transformAccum updates = + nfIO $ networkToList (length updates) $ do + updatesE <- signalToEvent <$> signalFromList (map pure updates) + coll0 <- accumCollection updatesE + coll1 <- filterCollection even coll0 + coll2 <- mapCollection (\x -> if x `mod` 5 == 0 then Just x else Nothing) coll1 + coll3 <- justCollection coll2 + discreteToSignal $ collectionToDiscreteList coll3 + +bench_mapToCollection :: EMS.EnumMap Int Int -> Benchmarkable +bench_mapToCollection dict = + nfIO $ networkToList 1 $ do + coll <- mapToCollection (pure dict) + let mangle :: Discrete [(a, Discrete b)] -> Discrete [(a, b)] + mangle = join . fmap (sequence . map sequence) + discreteToSignal $ mangle $ collectionToDiscreteList coll diff --git a/benchmarks/FRP/Euphoria/HashCollection/Lazy/Bench.hs b/benchmarks/FRP/Euphoria/HashCollection/Lazy/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/FRP/Euphoria/HashCollection/Lazy/Bench.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + +module FRP.Euphoria.HashCollection.Lazy.Bench + ( benchmarks + ) where + +import Control.DeepSeq +import Control.Monad +import Criterion +import qualified Data.HashMap.Lazy as HML +import Data.List +import FRP.Euphoria.Event +import FRP.Euphoria.HashCollection.Lazy +import GHC.Generics + +benchmarks :: Benchmark +benchmarks = env mkEnv $ \ ~e -> bgroup "HashCollection.Lazy" + [ bench "mapToCollectionSmall" $ bench_mapToCollection (smallDict e) + , bench "mapToCollectionBig" $ bench_mapToCollection (bigDict e) + , bench "accumSmall" $ bench_accum (smallUpdates e) + , bench "accumBig" $ bench_accum (bigUpdates e) + , bench "transformAccumSmall" $ bench_transformAccum (smallUpdates e) + , bench "transformAccumBig" $ bench_transformAccum (bigUpdates e) + , bench "fromListSmall" $ bench_fromList (smallList e) + , bench "fromListBig" $ bench_fromList (bigList e) + , bench "transformListSmall" $ bench_transform (smallList e) + , bench "transformListBig" $ bench_transform (bigList e) + ] + +data BenchmarkEnv = BenchmarkEnv + { smallList :: [[Int]] + , bigList :: [[Int]] + , smallUpdates :: [CollectionUpdate Int Int] + , bigUpdates :: [CollectionUpdate Int Int] + , smallDict :: HML.HashMap Int Int + , bigDict :: HML.HashMap Int Int + } deriving (Generic) + +instance NFData BenchmarkEnv + +mkEnv :: IO BenchmarkEnv +mkEnv = do + let smallList = map (\i -> [1..i]) [0..10] + let bigList = map (\i -> [1..i]) [0..100] + let smallUpdates = map (\i -> let (v,k) = 100 `divMod` i in AddItem k v) [1..101] + let bigUpdates = map (\i -> let (v,k) = 200 `divMod` i in AddItem k v) [1..201] + let smallDict = foldl' (\acc i -> let (v,k) = 100 `divMod` i in HML.insert k v acc) HML.empty [1..101] + let bigDict = foldl' (\acc i -> let (v,k) = 200 `divMod` i in HML.insert k v acc) HML.empty [1..201] + return BenchmarkEnv{..} + +bench_fromList :: [[Int]] -> Benchmarkable +bench_fromList list = + nfIO $ networkToList (length list) $ do + listD <- signalToDiscrete <$> signalFromList list + coll <- collectionFromDiscreteList (0 :: Int) listD + discreteToSignal $ collectionToDiscreteList coll + +bench_transform :: [[Int]] -> Benchmarkable +bench_transform list = + nfIO $ networkToList (length list) $ do + listD <- signalToDiscrete <$> signalFromList list + coll0 <- collectionFromDiscreteList (0 :: Int) listD + coll1 <- filterCollection even coll0 + coll2 <- mapCollection (\x -> if x `mod` 5 == 0 then Just x else Nothing) coll1 + coll3 <- justCollection coll2 + discreteToSignal $ collectionToDiscreteList coll3 + +bench_accum :: [CollectionUpdate Int Int] -> Benchmarkable +bench_accum updates = + nfIO $ networkToList (length updates) $ do + updatesE <- signalToEvent <$> signalFromList (map pure updates) + coll <- accumCollection updatesE + discreteToSignal $ collectionToDiscreteList coll + +bench_transformAccum :: [CollectionUpdate Int Int] -> Benchmarkable +bench_transformAccum updates = + nfIO $ networkToList (length updates) $ do + updatesE <- signalToEvent <$> signalFromList (map pure updates) + coll0 <- accumCollection updatesE + coll1 <- filterCollection even coll0 + coll2 <- mapCollection (\x -> if x `mod` 5 == 0 then Just x else Nothing) coll1 + coll3 <- justCollection coll2 + discreteToSignal $ collectionToDiscreteList coll3 + +bench_mapToCollection :: HML.HashMap Int Int -> Benchmarkable +bench_mapToCollection dict = + nfIO $ networkToList 1 $ do + coll <- mapToCollection (pure dict) + let mangle :: Discrete [(a, Discrete b)] -> Discrete [(a, b)] + mangle = join . fmap (sequence . map sequence) + discreteToSignal $ mangle $ collectionToDiscreteList coll diff --git a/benchmarks/FRP/Euphoria/HashCollection/Strict/Bench.hs b/benchmarks/FRP/Euphoria/HashCollection/Strict/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/FRP/Euphoria/HashCollection/Strict/Bench.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + +module FRP.Euphoria.HashCollection.Strict.Bench + ( benchmarks + ) where + +import Control.DeepSeq +import Control.Monad +import Criterion +import qualified Data.HashMap.Strict as HMS +import Data.List +import FRP.Euphoria.Event +import FRP.Euphoria.HashCollection.Strict +import GHC.Generics + +benchmarks :: Benchmark +benchmarks = env mkEnv $ \ ~e -> bgroup "HashCollection.Strict" + [ bench "mapToCollectionSmall" $ bench_mapToCollection (smallDict e) + , bench "mapToCollectionBig" $ bench_mapToCollection (bigDict e) + , bench "accumSmall" $ bench_accum (smallUpdates e) + , bench "accumBig" $ bench_accum (bigUpdates e) + , bench "transformAccumSmall" $ bench_transformAccum (smallUpdates e) + , bench "transformAccumBig" $ bench_transformAccum (bigUpdates e) + , bench "fromListSmall" $ bench_fromList (smallList e) + , bench "fromListBig" $ bench_fromList (bigList e) + , bench "transformListSmall" $ bench_transform (smallList e) + , bench "transformListBig" $ bench_transform (bigList e) + ] + +data BenchmarkEnv = BenchmarkEnv + { smallList :: [[Int]] + , bigList :: [[Int]] + , smallUpdates :: [CollectionUpdate Int Int] + , bigUpdates :: [CollectionUpdate Int Int] + , smallDict :: HMS.HashMap Int Int + , bigDict :: HMS.HashMap Int Int + } deriving (Generic) + +instance NFData BenchmarkEnv + +mkEnv :: IO BenchmarkEnv +mkEnv = do + let smallList = map (\i -> [1..i]) [0..10] + let bigList = map (\i -> [1..i]) [0..100] + let smallUpdates = map (\i -> let (v,k) = 100 `divMod` i in AddItem k v) [1..101] + let bigUpdates = map (\i -> let (v,k) = 200 `divMod` i in AddItem k v) [1..201] + let smallDict = foldl' (\acc i -> let (v,k) = 100 `divMod` i in HMS.insert k v acc) HMS.empty [1..101] + let bigDict = foldl' (\acc i -> let (v,k) = 200 `divMod` i in HMS.insert k v acc) HMS.empty [1..201] + return BenchmarkEnv{..} + +bench_fromList :: [[Int]] -> Benchmarkable +bench_fromList list = + nfIO $ networkToList (length list) $ do + listD <- signalToDiscrete <$> signalFromList list + coll <- collectionFromDiscreteList (0 :: Int) listD + discreteToSignal $ collectionToDiscreteList coll + +bench_transform :: [[Int]] -> Benchmarkable +bench_transform list = + nfIO $ networkToList (length list) $ do + listD <- signalToDiscrete <$> signalFromList list + coll0 <- collectionFromDiscreteList (0 :: Int) listD + coll1 <- filterCollection even coll0 + coll2 <- mapCollection (\x -> if x `mod` 5 == 0 then Just x else Nothing) coll1 + coll3 <- justCollection coll2 + discreteToSignal $ collectionToDiscreteList coll3 + +bench_accum :: [CollectionUpdate Int Int] -> Benchmarkable +bench_accum updates = + nfIO $ networkToList (length updates) $ do + updatesE <- signalToEvent <$> signalFromList (map pure updates) + coll <- accumCollection updatesE + discreteToSignal $ collectionToDiscreteList coll + +bench_transformAccum :: [CollectionUpdate Int Int] -> Benchmarkable +bench_transformAccum updates = + nfIO $ networkToList (length updates) $ do + updatesE <- signalToEvent <$> signalFromList (map pure updates) + coll0 <- accumCollection updatesE + coll1 <- filterCollection even coll0 + coll2 <- mapCollection (\x -> if x `mod` 5 == 0 then Just x else Nothing) coll1 + coll3 <- justCollection coll2 + discreteToSignal $ collectionToDiscreteList coll3 + +bench_mapToCollection :: HMS.HashMap Int Int -> Benchmarkable +bench_mapToCollection dict = + nfIO $ networkToList 1 $ do + coll <- mapToCollection (pure dict) + let mangle :: Discrete [(a, Discrete b)] -> Discrete [(a, b)] + mangle = join . fmap (sequence . map sequence) + discreteToSignal $ mangle $ collectionToDiscreteList coll diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,16 @@ +module Main where + +import Criterion.Main (defaultMain) + +import qualified FRP.Euphoria.EnumCollection.Lazy.Bench as ECL +import qualified FRP.Euphoria.EnumCollection.Strict.Bench as ECS +import qualified FRP.Euphoria.HashCollection.Lazy.Bench as HCL +import qualified FRP.Euphoria.HashCollection.Strict.Bench as HCS + +main :: IO () +main = defaultMain + [ ECL.benchmarks + , ECS.benchmarks + , HCL.benchmarks + , HCS.benchmarks + ] diff --git a/euphoria.cabal b/euphoria.cabal --- a/euphoria.cabal +++ b/euphoria.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: euphoria -version: 0.6.0.1 +version: 0.8.0.0 synopsis: Dynamic network FRP with events and continuous values description: @@ -67,18 +67,30 @@ build-type: Simple cabal-version: >=1.8 homepage: http://github.com/tsurucapital/euphoria +tested-with: GHC == 7.10.3 + , GHC == 8.0.1 source-repository head type: git location: git://github.com/tsurucapital/euphoria.git library - exposed-modules: FRP.Euphoria.Event, FRP.Euphoria.Signal, FRP.Euphoria.Update, FRP.Euphoria.Collection, FRP.Euphoria.Abbrev, FRP.Euphoria.Internal.Maplike + exposed-modules: FRP.Euphoria.Event + , FRP.Euphoria.Signal + , FRP.Euphoria.Update + , FRP.Euphoria.Collection + , FRP.Euphoria.EnumCollection.Lazy + , FRP.Euphoria.EnumCollection.Strict + , FRP.Euphoria.HashCollection.Lazy + , FRP.Euphoria.HashCollection.Strict + , FRP.Euphoria.Abbrev + , FRP.Euphoria.Internal.GenericCollection + , FRP.Euphoria.Internal.Maplike + other-modules: FRP.Elerea.Simple.Compat -- other-modules: build-depends: HUnit - , base >= 4.7 && < 4.9 - , elerea >= 2.7 - , data-default + , base >= 4.7 && < 4.10 + , elerea >= 2.7 && < 2.10 , enummapset-th >= 0.6 , deepseq , hashable >= 1.2 @@ -88,8 +100,12 @@ test-suite tests type: exitcode-stdio-1.0 - main-is: Tests.hs + main-is: Main.hs hs-source-dirs: tests + other-modules: FRP.Euphoria.EnumCollection.Lazy.Test + FRP.Euphoria.Event.Test + FRP.Euphoria.HashCollection.Strict.Test + FRP.Euphoria.Update.Test ghc-options: -Wall build-depends: HUnit , base @@ -97,3 +113,19 @@ , test-framework , test-framework-hunit , test-framework-th + +benchmark bench + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: benchmarks + other-modules: FRP.Euphoria.EnumCollection.Lazy.Bench + FRP.Euphoria.EnumCollection.Strict.Bench + FRP.Euphoria.HashCollection.Lazy.Bench + FRP.Euphoria.HashCollection.Strict.Bench + ghc-options: -Wall + build-depends: base + , criterion + , deepseq + , euphoria + , enummapset-th + , unordered-containers diff --git a/tests/FRP/Euphoria/EnumCollection/Lazy/Test.hs b/tests/FRP/Euphoria/EnumCollection/Lazy/Test.hs new file mode 100644 --- /dev/null +++ b/tests/FRP/Euphoria/EnumCollection/Lazy/Test.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE TemplateHaskell #-} +module FRP.Euphoria.EnumCollection.Lazy.Test + ( tests + ) where + +import Test.Framework (Test) +import Test.Framework.TH +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import FRP.Euphoria.Event +import FRP.Euphoria.EnumCollection.Lazy + +tests :: Test +tests = $(testGroupGenerator) + +case_switchCollection :: Assertion +case_switchCollection = do + result <- networkToList 5 $ do + col0 <- collectionFromDiscreteList (0::Int) =<< mkD [[10::Int], [], [10,20,30], [20,30], [30]] + col1 <- collectionFromDiscreteList 0 =<< mkD [[11], [], [11,21,31], [21,31], [31]] + col2 <- collectionFromDiscreteList 0 =<< mkD [[12], [], [12,22,32], [22,32], [32]] + colD <- stepperD col0 =<< eventFromList [[], [], [col1], [], [col2]] + col <- switchD colD + (_, updates) <- openCollection col + listS <- discreteToSignal $ collectionToDiscreteList col + return $ (,) <$> listS <*> eventToSignal updates + result @?= + [ ([(0, 10)] + , []) + , ([] + , [RemoveItem 0]) + , ([(1, 11), (2, 21), (3, 31)] + , [AddItem 1 11, AddItem 2 21, AddItem 3 31]) + , ([(2, 21), (3, 31)] + , [RemoveItem 1]) + , ([(3, 32)] + , [RemoveItem 2, RemoveItem 3, AddItem 3 32]) + ] + where + mkD list = signalToDiscrete <$> signalFromList list + +case_mapCollection :: Assertion +case_mapCollection = do + result <- networkToList 1 $ do + col <- mapCollection show $ + collectionFromList [(0 :: Int, 1 :: Int), (1, 2), (2, 3)] + discreteToSignal $ collectionToDiscreteList col + + result @?= [[(0, "1"), (1, "2"), (2, "3")]] diff --git a/tests/FRP/Euphoria/Event/Test.hs b/tests/FRP/Euphoria/Event/Test.hs new file mode 100644 --- /dev/null +++ b/tests/FRP/Euphoria/Event/Test.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} + +module FRP.Euphoria.Event.Test (tests) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +import Data.Monoid (mempty) +#endif + +import Test.Framework (Test) +import Test.Framework.TH +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import FRP.Euphoria.Event + +tests :: Test +tests = $(testGroupGenerator) + +case_takeE :: Assertion +case_takeE = do + result <- networkToList 5 $ do + evt <- eventFromList [[1], [1::Int], [2,3], [], [4]] + evt2 <- takeE 3 evt + accumS 0 $ (+) <$> evt2 + result @?= [1, 2, 4, 4, 4] + +case_takeWhileE :: Assertion +case_takeWhileE = do + result <- networkToList 5 $ do + evt <- eventFromList [[1], [1::Int], [2,3], [], [4]] + evt2 <- takeWhileE (<3) evt + accumS 0 $ (+) <$> evt2 + result @?= [1, 2, 4, 4, 4] + +case_groupE :: Assertion +case_groupE = do + result <- networkToList 5 $ do + evt <- eventFromList [[1], [1::Int], [2,3], [], [3,3,4]] + evt2 <- groupE evt + threes <- takeE 1 =<< dropE 2 evt2 + dyn <- stepperS mempty threes + return $ eventToSignal $ joinEventSignal dyn + result @?= [[], [], [3], [], [3,3]] + +case_splitOnE :: Assertion +case_splitOnE = do + result <- networkToList 5 $ do + ev1 <- eventFromList [[1::Int], [2,3,4], [], [5,6], [7,8]] + ev2 <- eventFromList [[], [()], [], [], [()]] + eventToSignal <$> splitOnE ev2 ev1 + result @?= [[], [[1,2,3,4]], [], [], [[5,6,7,8]]] + +case_freezeD :: Assertion +case_freezeD = do + result <- networkToList 5 $ do + ev <- eventFromList [[], [], [()], [], [()]] + dis <- signalToDiscrete <$> signalFromList [1..] + discreteToSignal =<< freezeD ev dis + result @?= [1, 2, 3, 3, 3 :: Int] diff --git a/tests/FRP/Euphoria/HashCollection/Strict/Test.hs b/tests/FRP/Euphoria/HashCollection/Strict/Test.hs new file mode 100644 --- /dev/null +++ b/tests/FRP/Euphoria/HashCollection/Strict/Test.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE TemplateHaskell #-} +module FRP.Euphoria.HashCollection.Strict.Test + ( tests + ) where + +import Test.Framework (Test) +import Test.Framework.TH +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import FRP.Euphoria.Event +import FRP.Euphoria.HashCollection.Strict + +tests :: Test +tests = $(testGroupGenerator) + +case_switchCollection :: Assertion +case_switchCollection = do + result <- networkToList 5 $ do + col0 <- collectionFromDiscreteList (0::Int) =<< mkD [[10::Int], [], [10,20,30], [20,30], [30]] + col1 <- collectionFromDiscreteList 0 =<< mkD [[11], [], [11,21,31], [21,31], [31]] + col2 <- collectionFromDiscreteList 0 =<< mkD [[12], [], [12,22,32], [22,32], [32]] + colD <- stepperD col0 =<< eventFromList [[], [], [col1], [], [col2]] + col <- switchD colD + (_, updates) <- openCollection col + listS <- discreteToSignal $ collectionToDiscreteList col + return $ (,) <$> listS <*> eventToSignal updates + result @?= + [ ([(0, 10)] + , []) + , ([] + , [RemoveItem 0]) + , ([(1, 11), (2, 21), (3, 31)] + , [AddItem 1 11, AddItem 2 21, AddItem 3 31]) + , ([(2, 21), (3, 31)] + , [RemoveItem 1]) + , ([(3, 32)] + , [RemoveItem 2, RemoveItem 3, AddItem 3 32]) + ] + where + mkD list = signalToDiscrete <$> signalFromList list + +case_mapCollection :: Assertion +case_mapCollection = do + result <- networkToList 1 $ do + col <- mapCollection show $ + collectionFromList [(0 :: Int, 1 :: Int), (1, 2), (2, 3)] + discreteToSignal $ collectionToDiscreteList col + + result @?= [[(0, "1"), (1, "2"), (2, "3")]] diff --git a/tests/FRP/Euphoria/Update/Test.hs b/tests/FRP/Euphoria/Update/Test.hs new file mode 100644 --- /dev/null +++ b/tests/FRP/Euphoria/Update/Test.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} + +module FRP.Euphoria.Update.Test (tests) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>), (<*>)) +import Data.Monoid (mappend) +#endif + +import Data.Maybe (fromMaybe) + +import Test.Framework (Test) +import Test.Framework.TH +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import FRP.Euphoria.Event +import FRP.Euphoria.Update + +tests :: Test +tests = $(testGroupGenerator) + +case_startUpdateNetwork :: Assertion +case_startUpdateNetwork = do + (sample, step) <- startUpdateNetwork $ do + evt <- eventFromList [["a"], ["bc","d"], [], ["e"]] + return $ updateUseAll evt + step + val0 <- sample + val1 <- sample + val2 <- sample + + [val0, val1, val2] @?= ["abcd", "", "e"] + +case_skip :: Assertion +case_skip = do + (sample, step) <- startUpdateNetwork $ + updateUseLast <$> eventFromList [[1], [2, 3], [], [4::Int]] + step + val0 <- sample + val1 <- sample + step + val2 <- sample + + val0 @?= Just 3 + val1 @?= Nothing + val2 @?= Just 4 + +case_mappendUpdate :: Assertion +case_mappendUpdate = do + (sample, step) <- startUpdateNetwork $ do + update0 <- updateUseAll <$> eventFromList [["a"], ["bc","d"], [], ["e"]] + update1 <- updateUseAll <$> eventFromList [["f"], [], ["g"], ["hij"]] + return $ update0 `mappend` update1 + step + val0 <- sample + val1 <- sample + step + val2 <- sample + + val0 @?= "abcdf" + val1 @?= "g" + val2 @?= "ehij" + +case_applicativeUpdate :: Assertion +case_applicativeUpdate = do + (sample, step) <- startUpdateNetwork $ do + update0 <- updateUseAll <$> eventFromList [["a"], ["bc","d"], [], ["e"]] + update1 <- updateUseAll <$> eventFromList [[[1]], [], [[2]], [[3,4],[5::Int]]] + return $ f <$> update0 <*> update1 + step + val0 <- sample + val1 <- sample + step + val2 <- sample + + val0 @?= [([1], "abcd")] + val1 @?= [([2], "")] + val2 @?= [([3,4,5], "e")] + where + f str num = [(num, str)] + +case_switchUD :: Assertion +case_switchUD = do + (sample, step) <- startUpdateNetwork $ do + update0 <- fmap (fromMaybe "") . updateUseLast <$> + eventFromList [["1"], ["2", "3"], ["4"], ["5"]] + update1 <- updateUseAll <$> eventFromList [["a"], ["bc","d"], [], ["e"]] + updatesD <- stepperD update0 =<< eventFromList [[], [], [], [update1]] + switchD updatesD + val0 <- sample + step + step + val1 <- sample + + val0 @?= "1" + val1 @?= "4e" diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,16 @@ +module Main where + +import Test.Framework (defaultMain) + +import qualified FRP.Euphoria.EnumCollection.Lazy.Test +import qualified FRP.Euphoria.HashCollection.Strict.Test +import qualified FRP.Euphoria.Event.Test +import qualified FRP.Euphoria.Update.Test + +main :: IO () +main = defaultMain + [ FRP.Euphoria.EnumCollection.Lazy.Test.tests + , FRP.Euphoria.HashCollection.Strict.Test.tests + , FRP.Euphoria.Event.Test.tests + , FRP.Euphoria.Update.Test.tests + ] diff --git a/tests/Tests.hs b/tests/Tests.hs deleted file mode 100644 --- a/tests/Tests.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Main where - -import Test.Framework (defaultMain) - -import Test.Collection (collectionTestGroup) -import Test.Event (eventTestGroup) -import Test.Update (updateTestGroup) - -main :: IO () -main = defaultMain - [ collectionTestGroup - , eventTestGroup - , updateTestGroup - ]