packages feed

euphoria (empty) → 0.6.0.1

raw patch · 10 files changed

+1837/−0 lines, 10 filesdep +HUnitdep +basedep +containerssetup-changed

Dependencies added: HUnit, base, containers, data-default, deepseq, elerea, enummapset-th, euphoria, hashable, test-framework, test-framework-hunit, test-framework-th, transformers, unordered-containers

Files

+ FRP/Euphoria/Abbrev.hs view
@@ -0,0 +1,17 @@+-- | Abbreviation for common types.+module FRP.Euphoria.Abbrev+( S+, E+, D+, U+, SGen+) where++import FRP.Euphoria.Event+import FRP.Euphoria.Update++type S = Signal+type E = Event+type D = Discrete+type U = Update+type SGen = SignalGen
+ FRP/Euphoria/Collection.hs view
@@ -0,0 +1,440 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecursiveDo #-}+{-# OPTIONS_GHC -Wall #-}+++-- | Collection signals with incremental updates.+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++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)++-- 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++-------------------------------------------------------------------------------+-- Converting Discrete Maps into Collections++mapToCollection+    :: (Eq k, Eq a, Ord k, MonadSignalGen m)+    => Discrete (Map k a)+    -> m (Collection k (Discrete a))+mapToCollection = genericMapToCollection++enummapToCollection+    :: (Eq k, Eq a, Enum k, MonadSignalGen m)+    => Discrete (EnumMap k a)+    -> m (Collection k (Discrete a))+enummapToCollection = genericMapToCollection++hashmapToCollection+    :: (Eq k, Eq a, Hashable k, MonadSignalGen m)+    => Discrete (HashMap k a)+    -> m (Collection k (Discrete a))+hashmapToCollection = genericMapToCollection++-- 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
+ FRP/Euphoria/Event.hs view
@@ -0,0 +1,875 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wall #-}++#if __GLASGOW_HASKELL__ <= 706+{-# LANGUAGE DoRec #-}+#else+{-# LANGUAGE RecursiveDo #-}+#endif++-- | Event/discrete layer constructed on top of Elerea.+-- The API is largely inspired by reactive-banana.+module FRP.Euphoria.Event+(+-- * Events+  Event+-- ** Creation+, externalEvent+, eachStep+, onCreation+, signalToEvent+-- ** Sampling+, apply+, eventToSignal+-- ** State accumulation+-- | With these functions, any input event occurrence will affect the output+-- immediately, without any delays.+, stepperS+, accumS+, accumSIO+, accumE+, accumEM+, scanAccumE+, scanAccumEM+-- ** Filtering and other list-like operations+, filterE+, justE+, mapMaybeE+, flattenE+, expandE+, withPrevE+, dropE+, dropWhileE+, takeE+, takeWhileE+, partitionEithersE+, leftE+, rightE+, groupByE+, groupWithInitialByE+, groupE+, groupWithInitialE+, splitOnE+, differentE+-- ** Other event operations+, delayE+, dropStepE+, mapEIO+, memoE+, joinEventSignal+, generatorE+-- * Discrete signals+, Discrete+-- ** Sampling 'Discrete's+-- $sampling_discrete++-- ** Accumulation+, stepperD+, stepperDefD+, stepperMaybeD+, justD+, accumD+-- ** Conversion into events+, eachStepD+, changesD+, preservesD+-- ** Other discrete operations+, snapshotD -- broken? crashes?+, memoD+, delayD+, generatorD+, minimizeChanges+, discreteToSignal+, freezeD+, signalToDiscrete+, keepJustsD+, keepDJustsD+-- * Signals+, module FRP.Euphoria.Signal+-- * Application operators+, Apply (..)+-- $app_discrete_maybe+, (<$?>), (<?*?>), (<-*?>), (<?*->)+, EasyApply (..)+-- * Switching+, switchD+, switchDE+, switchDS+, generatorD'+, SignalSet (..)+-- * Evaluation control+, forceD+, forceE+, rnfD+, rnfE+-- * Debugging+-- | Side-effecting trace functions+, traceSignalMaybe+, traceSignalT+, traceEventT+, traceDiscreteT+-- * Testing+, signalFromList+, eventFromList+, networkToList+) where++import Control.Arrow ((&&&))+import Control.Applicative+import Control.DeepSeq+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+import Data.Maybe+import Data.Typeable+import Debug.Trace+import FRP.Euphoria.Signal+import FRP.Elerea.Simple (externalMulti, effectful1, until, stateful)+import Prelude hiding (until)++-- | @Event a@ represents a stream of events whose occurrences carry+-- a value of @a@. The event can have zero, one or more occurrences+-- in a single network step.+--+-- Two event occurrences are said to be simultaneous iff they are within+-- the same step. Simultaneous occurrences are ordered within a single+-- event stream, but not across different event streams.+newtype Event a = Event (Signal [a])+  deriving (Functor, Typeable)+-- | @Discrete a@ is much like @'Signal' a@, but the user can get notified+-- every time the value may have changed. See 'changesD'.+newtype Discrete a = Discrete (Signal (Bool, a))+  -- The first component indicates if the value may be new.+  -- If it is False, the consumer should avoid evaluating the+  -- second component whenever possible.+  -- FIXME: This trick alone cannot remove all redundant recomputations.+  -- Consider the case where a Discrete is+  -- read every iteration in a fresh SignalGen run.+  deriving (Functor, Typeable)+-- type Behavior a = Signal a++-- | Event streams can be merged together. In case of simultaneous occurrences,+-- occurrences from the left stream comes first.+instance Monoid (Event a) where+  mempty = Event $ pure []+  Event a `mappend` Event b = Event $ (++) <$> a <*> b++infixl 4 <@>, <@++-- | A generalization of @Applicative@ where the lhs and the rhs can have+-- different container types.+class (Functor f, Functor g) => Apply f g where+  (<@>) :: f (a -> b) -> g a -> g b+  (<@) :: f a -> g b -> g a++  f <@ g = const <$> f <@> g++instance Apply Signal Event where+  (<@>) = apply++-- It's difficult to implement this without causing needless recalculation:+--instance Apply Discrete Event where++-- | Create an event that can be triggered as an IO action.+externalEvent :: (MonadSignalGen g, MonadIO m, MonadIO m') => m (g (Event a), a -> m' ())+externalEvent = liftIO $ do+  (gen, trigger) <- externalMulti+  return (Event . fmap reverse <$> liftSignalGen gen, liftIO . trigger)++-- | Transform an event stream using a time-varying transformation function.+--+-- There is also an infix form '<@>'.+apply :: Signal (a -> b) -> Event a -> Event b+apply sig (Event evt) = Event $ map <$> sig <*> evt++-- | Filter an event stream.+filterE :: (a -> Bool) -> Event a -> Event a+filterE cond (Event evt) = Event $ filter cond <$> evt++-- | @stepperS initial evt@ returns a signal whose value is the last occurrence+-- of @evt@, or @initial@ if there has been none.+stepperS :: MonadSignalGen m => a -> Event a -> m (Signal a)+stepperS initial (Event evt) = transferS initial upd evt+  where+    upd [] old = old+    upd occs _ = last occs++-- | @eachStep sig@ is an event that occurs every step, having the same+-- value as @sig@.+eachStep :: Signal a -> Event a+eachStep = Event . fmap (:[])++-- | 'Discrete' version of eachStep.+eachStepD :: MonadSignalGen m => Discrete a -> m (Event a)+eachStepD d = do+  sig <- discreteToSignal d+  return $ eachStep sig++-- | The basic construct to build a stateful signal. @accumS initial evt@+-- returns a signal whose value is originally @initial@. For each occurrence+-- of @evt@ the value of the signal gets updated using the function.+--+-- Example:+--+--   If we have an event stream of numbers, (nums :: Event Int), then+--   we can make a signal that remembers the sum of the numbers seen+--   so far, as follows:+--+-- > accumS 0 $ (+) <$> nums+accumS :: MonadSignalGen m => a -> Event (a -> a) -> m (Signal a)+accumS initial (Event evt) = transferS initial upd evt+  where+    upd occs old = foldl' (flip ($)) old occs++-- | @accumS@ with side-effecting updates.+accumSIO :: (MonadSignalGen m) => a -> Event (a -> IO a) -> m (Signal a)+accumSIO initial (Event evt) = mfix $ \self -> do+  prev <- delayS initial self+  liftSignalGen $ effectful1 id $ update <$> prev <*> evt+  where+    update prev upds = foldl' (>>=) (return prev) upds++-- | @accumE initial evt@ maintains an internal state just like @accumS@.+-- It returns an event which occurs every time an update happens.+-- The resulting event, once created, will have the same number of+-- occurrences as @evt@ each step.+accumE :: (MonadSignalGen m) => a -> Event (a -> a) -> m (Event a)+accumE initial (Event evt) = fmap Event $ do+  (_, occs) <- mfix $ \ ~(self, _) -> do+    prev <- delayS initial self+    vs <- memoS $ scanl (flip ($)) <$> prev <*> evt+    return (last <$> vs, tail <$> vs)+  return occs++-- | A useful special case of 'accumE'.+scanAccumE :: MonadSignalGen m => s -> Event (s -> (s, a)) -> m (Event a)+scanAccumE initial ev = (snd <$>) <$> accumE (initial, undefined) (f <$> ev)+  where+    f fn (s, _) = fn s++-- | Monadic version of @accumE@.+accumEM :: (MonadSignalGen m) => s -> Event (s -> SignalGen s) -> m (Event s)+accumEM initial (Event evt) = fmap Event $ do+  rec+    prevState <- delayS initial (fst <$> state_out)+    state_out <- generatorS $ stateGen <$> prevState <*> evt+  memoS $ snd <$> state_out+  where+    stateGen prev occs = foldr app end occs prev []+    app occ next val history = do+      val' <- occ val+      next val' (val':history)+    end val history = return (val, reverse history)++-- | A useful special case of @accumEM@.+scanAccumEM :: MonadSignalGen m => s -> Event (s -> SignalGen (s, a)) -> m (Event a)+scanAccumEM initial ev = (snd <$>) <$> accumEM (initial, undefined) (f <$> ev)+  where+    f fn (s, _) = fn s++-- | Drops all events in this network step+dropStepE :: MonadSignalGen m => Event a -> m (Event a)+dropStepE ev = do+    initial <- delayS True (pure False)+    memoE $ justE $ discardIf <$> initial <@> ev+    where+        discardIf True _ = Nothing+        discardIf False x = Just x++-- | Converts an event stream of lists into a stream of their elements.+-- All elements of a list become simultaneous occurrences.+flattenE :: Event [a] -> Event a+flattenE (Event evt) = Event $ concat <$> evt++-- | Expand simultaneous events (if any)+expandE :: Event a -> Event [a]+expandE (Event evt) = Event $ f <$> evt+    where+        f [] = []+        f xs = [xs]++-- | Like 'mapM' over events.+mapEIO :: MonadSignalGen m => (t -> IO a) -> Event t -> m (Event a)+mapEIO mkAction (Event evt) = Event <$> liftSignalGen (effectful1 (mapM mkAction) evt)++-- | Memoization of events. See the doc for 'FRP.Elerea.Simple.memo'.+memoE :: MonadSignalGen m => Event a -> m (Event a)+memoE (Event evt) = Event <$> memoS evt++-- | An event whose occurrences come from different event stream+-- each step.+joinEventSignal :: Signal (Event a) -> Event a+joinEventSignal sig = Event $ do+  Event occs <- sig+  occs++-- | Remove occurrences that are 'Nothing'.+justE :: Event (Maybe a) -> Event a+justE (Event evt) = Event $ catMaybes <$> evt++-- | Like 'mapMaybe' over events.+mapMaybeE :: (a -> Maybe b) -> Event a -> Event b+mapMaybeE f evt = justE $ f <$> evt++-- | @onCreation x@ creates an event that occurs only once,+-- immediately on creation.+onCreation :: MonadSignalGen m => a -> m (Event a)+onCreation x = Event <$> delayS [x] (return [])++-- | @delayE evt@ creates an event whose occurrences are+-- same as the occurrences of @evt@ in the previous step.+delayE :: MonadSignalGen m => Event a -> m (Event a)+delayE (Event x) = Event <$> delayS [] x++-- | @withPrevE initial evt@ is an Event which occurs every time+-- @evt@ occurs. Each occurrence carries a pair, whose first element+-- is the value of the current occurrence of @evt@, and whose second+-- element is the value of the previous occurrence of @evt@, or+-- @initial@ if there has been none.+withPrevE :: MonadSignalGen m => a -> Event a -> m (Event (a, a))+withPrevE initial evt = accumE (initial, undefined) $ toUpd <$> evt+  where+    toUpd val (new, _old) = (val, new)++-- | @generatorE evt@ creates a subnetwork every time @evt@ occurs.+generatorE :: MonadSignalGen m => Event (SignalGen a) -> m (Event a)+generatorE (Event evt) = Event <$> generatorS (sequence <$> evt)++-- | @dropE n evt@ returns an event, which behaves similarly to+-- @evt@ except that its first @n@ occurrences are dropped.+dropE :: MonadSignalGen m => Int -> Event a -> m (Event a)+dropE n (Event evt) = Event . fmap fst <$> transferS ([], n) upd evt+    where+        upd occs (_, k)+            | k <= 0 = (occs, 0)+            | otherwise = let+                !k' = k - length occs+                in (drop k occs, k')++-- | @dropWhileE p evt@ returns an event, which behaves similarly to+-- @evt@ except that all its occurrences before the first one+-- that satisfies @p@ are dropped.+dropWhileE :: MonadSignalGen m => (a -> Bool) -> Event a -> m (Event a)+dropWhileE p (Event evt) = Event . fmap fst <$> transferS ([], False) upd evt+  where+    upd occs (_, True) = (occs, True)+    upd occs (_, False) = case span p occs of+      (_, []) -> ([], False)+      (_, rest) -> (rest, True)++-- | Take the first n occurrences of the event and discard the rest.+-- It drops the reference to the original event after+-- the first n occurrences are seen.+takeE :: MonadSignalGen m => Int -> Event a -> m (Event a)+takeE n evt = generalPrefixE (primTakeE n) evt++primTakeE :: MonadSignalGen m => Int -> Signal [a] -> m (Signal (Bool, [a]))+primTakeE n evt = fmap fst <$> transferS ((True, []), n) upd evt+    where+        upd occs (_, k) = ((k > 0, take k occs), k')+            where+                !k' = k - length occs++-- | Take the first occurrences satisfying the predicate and discard the rest.+-- It drops the reference to the original event after+-- the first non-satisfying occurrence is seen.+takeWhileE :: MonadSignalGen m => (a -> Bool) -> Event a -> m (Event a)+takeWhileE p evt = generalPrefixE (primTakeWhileE p) evt++primTakeWhileE :: MonadSignalGen m => (a -> Bool) -> Signal [a] -> m (Signal (Bool, [a]))+primTakeWhileE p evt = memoS $ f <$> evt+    where+        f occs = case span p occs of+          (_, []) -> (True, occs)+          (end, _) -> (False, end)++generalPrefixE+  :: MonadSignalGen m+  => (Signal [a] -> m (Signal (Bool, [a])))+  -> Event a+  -> m (Event a)+generalPrefixE prefixTaker (Event evt) = do+    rec+        done <- liftSignalGen $ until $ not . fst <$> active_occs+        prevDone <- delayS False done+        eventSource <- transferS evt upd prevDone+        active_occs <- prefixTaker (join eventSource)+    Event <$> memoS (snd <$> active_occs)+    where+        upd done prev = ifelse done (pure []) prev++        {-# NOINLINE ifelse #-}+        ifelse b x y = if b then x else y++        -- Here we hide an if expression from GHC's optimizer.+        -- If GHC finds this conditional, its "state hack"+        -- transforation turns the definition into:+        --+        -- upd done prev s = if done then [] else prev s+        --+        -- which is a disaster, because now (upd False prev)+        -- doesn't reduce to prev. This means each iteration+        -- the signal gets bigger and more expensive to evaluate.++-- | Split a stream of 'Either's into two, based on tags. This needs to be+-- in SignalGen in order to memoise the intermediate result.+partitionEithersE :: MonadSignalGen m => Event (Either a b) -> m (Event a, Event b)+partitionEithersE (Event eithersS) = (Event . fmap fst &&& Event . fmap snd)+  <$> memoS (partitionEithers <$> eithersS)++-- | Keep occurrences which are Left.+leftE :: Event (Either e a) -> Event e+leftE (Event eithersS) = Event (lefts <$> eithersS)++-- | Keep occurrences which are Right.+rightE :: Event (Either e a) -> Event a+rightE (Event eithersS) = Event (rights <$> eithersS)++-- | @groupByE eqv evt@ creates a stream of event streams, each corresponding+-- to a span of consecutive occurrences of equivalent elements in the original+-- stream. Equivalence is tested using @eqv@.+groupByE :: MonadSignalGen m => (a -> a -> Bool) -> Event a -> m (Event (Event a))+groupByE eqv sourceEvt = fmap snd <$> groupWithInitialByE eqv sourceEvt++-- | @groupWithInitialByE eqv evt@ creates a stream of event streams, each corresponding+-- to a span of consecutive occurrences of equivalent elements in the original+-- stream. Equivalence is tested using @eqv@. In addition, each outer event+-- occurrence contains the first occurrence of its inner event.+groupWithInitialByE :: MonadSignalGen m => (a -> a -> Bool) -> Event a -> m (Event (a, Event a))+groupWithInitialByE eqv sourceEvt = do+    networkE <- justE <$> scanAccumE Nothing (makeNetwork <$> sourceEvt)+    generatorE networkE+    where+        makeNetwork val currentVal+            | maybe False (eqv val) currentVal = (currentVal, Nothing)+            | otherwise = (Just val, Just $ (,) val <$> network val)+        network val = takeWhileE (eqv val) =<< dropWhileE (not . eqv val) sourceEvt++-- | Same as @'groupByE' (==)@+groupE :: (Eq a, MonadSignalGen m) => Event a -> m (Event (Event a))+groupE = groupByE (==)++-- | Same as @groupWithInitialByE (==)@+groupWithInitialE :: (Eq a, MonadSignalGen m) => Event a -> m (Event (a, Event a))+groupWithInitialE = groupWithInitialByE (==)++-- | For each Event () received, emit all 'a' in a list since the last+-- Event () was received. In the case of simultaneous 'a' and '()' in+-- a step, the 'a' are included in the emitted list.+splitOnE :: MonadSignalGen m => Event () -> Event a -> m (Event [a])+splitOnE completeE aE = do+    let inE = (Right <$> aE) `mappend` (Left <$> completeE)+    let f (Left ()) accAs = ([], Just (reverse accAs))+        f (Right a) accAs = (a : accAs, Nothing)+    memoE =<< justE <$> scanAccumE [] (f <$> inE)++-- | @eventToSignal evt@ is a signal whose value is the list of current+-- occurrences of @evt@.+eventToSignal :: Event a -> Signal [a]+eventToSignal (Event x) = x++-- | The inverse of 'eventToSignal'.+signalToEvent :: Signal [a] -> Event a+signalToEvent = Event++-- $sampling_discrete+-- 'Signal's can be sampled using 'apply' or equivalently '<@>'.+-- However, currently there are no corresponding functions for 'Discrete'+-- due to implementation difficulty. To sample a 'Discrete', you need to+-- first convert it into a 'Signal' using 'discreteToSignal'.++-- | @changesD dis@ is an event that occurs when the value of @dis@ may+-- have changed. It never occurs more than once a step.+changesD :: Discrete a -> Event a+changesD (Discrete dis) = Event $ conv <$> dis+  where+    conv (new, x) = if new then [x] else []++-- | Like 'changesD', but uses the current value in the Discrete even if+-- it is not new.+preservesD :: MonadSignalGen m => Discrete a -> m (Event a)+preservesD dis = do+    ev <- onCreation ()+    sig <- discreteToSignal dis+    memoE $ (const <$> sig <@> ev) `mappend` changesD dis++-- | @snapshotD dis@ returns the current value of @dis@.+snapshotD :: MonadSignalGen m => Discrete a -> m a+-- Seems to cause problems with the network. Is the underlying+-- 'snapshot' actually safe?+snapshotD (Discrete a) = snd <$> snapshotS a++-- | Like 'stepperS', but creates a 'Discrete'.+stepperD :: MonadSignalGen m => a -> Event a -> m (Discrete a)+stepperD initial (Event evt) = Discrete <$> transferS (False, initial) upd evt+  where+    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)++-- | Given an initial value, filter out the Nothings.+justD :: MonadSignalGen m => a -> Discrete (Maybe a) -> m (Discrete a)+justD initial mD = do+    mE <- preservesD mD+    stepperD initial (justE mE)++-- | Like @accumS@, but creates a 'Discrete'.+accumD :: MonadSignalGen m => a -> Event (a -> a) -> m (Discrete a)+accumD initial (Event evt) = Discrete <$> transferS (False, initial) upd evt+  where+    upd [] (_, old) = (False, old)+    upd upds (_, old) = (True, new)+      where !new = foldl' (flip ($)) old upds++-- | Filter events to only those which are different than the previous event.+differentE :: (Eq a, MonadSignalGen m) => Event a -> m (Event a)+differentE ev = (justE . (f <$>)) <$> withPrevE Nothing (Just <$> ev)+  where+    f :: (Eq a) => (Maybe a, Maybe a) -> Maybe a+    f (new, old) = if new /= old then new else old++instance Applicative Discrete where+  pure x = Discrete $ pure (False, x)+  Discrete f <*> Discrete a = Discrete $ app <$> f <*> a+    where+      app (newFun, fun) (newArg, arg) = (new, fun arg)+        where !new = newFun || newArg++instance Monad Discrete where+  return x = Discrete $ return (False, x)+  Discrete x >>= f = Discrete $ do+    (newX, v) <- x+    let Discrete y = f v+    (newY, r) <- y+    let !new = newX || newY+    return (new, r)++-- | Memoization of discretes. See the doc for 'FRP.Elerea.Simple.memo'.+memoD :: MonadSignalGen m => Discrete a -> m (Discrete a)+memoD (Discrete dis) = Discrete <$> memoS dis++-- | Like 'delayS'.+delayD :: MonadSignalGen m => a -> Discrete a -> m (Discrete a)+delayD initial (Discrete subsequent) = Discrete <$> delayS (True, initial) subsequent++-- | Like 'generatorS'. A subnetwork is only created when the value of the+-- discrete may have changed.+generatorD :: MonadSignalGen m => Discrete (SignalGen a) -> m (Discrete a)+generatorD (Discrete sig) = do+    first <- delayS True $ pure False+    listResult <- generatorS $ networkOnChanges <$> first <*> sig+    stepperD undefined (Event listResult)+    where+        networkOnChanges first (new, gen)+            | first || new = (:[]) <$> gen+            | otherwise = return []++-- | Executes a dynamic 'SignalGen' in a convenient way.+--+-- > generatorD' dis = generatorD dis >>= switchD+generatorD' :: (MonadSignalGen m, SignalSet s) => Discrete (SignalGen s) -> m s+generatorD' dis = generatorD dis >>= switchD++-- | @minimizeChanges dis@ creates a Discrete whose value is same as @dis@.+-- The resulting discrete is considered changed only if it is really changed.+minimizeChanges :: (MonadSignalGen m, Eq a) => Discrete a -> m (Discrete a)+minimizeChanges (Discrete dis) = Discrete . fmap fromJust <$> transferS Nothing upd dis+  where+    upd (False, _) (Just (_, cache)) = Just (False, cache)+    upd (True, val) (Just (_, cache))+      | val == cache = Just (False, cache)+    upd (new, val) _ = Just (new, val)++recordDiscrete :: MonadSignalGen m => Discrete a -> m (Discrete a)+recordDiscrete (Discrete dis) = Discrete . fmap fromJust <$> transferS Nothing upd dis+  where+    upd (False, _) (Just (_, cache)) = Just (False, cache)+    upd new_val _ = Just new_val++-- | Converts a 'Discrete' to an equivalent 'Signal'.+discreteToSignal :: MonadSignalGen m => Discrete a -> m (Signal a)+discreteToSignal dis = discreteToSignalNoMemo <$> recordDiscrete dis++-- | @switchD dis@ creates some signal-like thing whose value is+-- same as the thing @dis@ currently contains.+switchD :: (SignalSet s, MonadSignalGen m) => Discrete s -> m s+switchD dis = recordDiscrete dis >>= basicSwitchD >>= memoizeSignalSet++-- | @switchDS@ selects current @Signal a@ of a 'Discrete'.+--+-- See @switchD@ for a more general function.+switchDS :: MonadSignalGen m => Discrete (Signal a) -> m (Signal a)+switchDS = switchD++-- | @switchDE@ selects the current 'Event' stream contained in a 'Discrete'+--+-- See @switchD@ for a more general function.+switchDE :: MonadSignalGen m => Discrete (Event a) -> m (Event a)+switchDE = switchD++-- | @freezeD fixEvent dis@ returns a discrete whose value is same as+-- @dis@ before @fixEvent@ is activated first. Its value gets fixed once+-- an occurrence of @fixEvent@ is seen.+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++-- | Convert a 'Signal' to an equivalent 'Discrete'. The resulting discrete+-- is always considered to \'possibly have changed\'.+signalToDiscrete :: Signal a -> Discrete a+signalToDiscrete x = Discrete $ (,) True <$> x++traceSignalMaybe :: String -> (a -> Maybe String) -> Signal a -> Signal a+traceSignalMaybe loc f sig = do+  v <- sig+  case f v of+    Nothing -> pure v+    Just str -> trace (loc ++ ": " ++ str) $ pure v++traceSignalT :: (Show b) => String -> (a -> b) -> Signal a -> Signal a+traceSignalT loc f = traceSignalMaybe loc (Just . show . f)++traceEventT :: (Show b) => String -> (a -> b) -> Event a -> Event a+traceEventT loc f (Event sig) = Event $ traceSignalMaybe loc msg sig+  where+    msg [] = Nothing+    msg occs = Just $ show (map f occs)++traceDiscreteT :: (Show b) => String -> (a -> b) -> Discrete a -> Discrete a+traceDiscreteT loc f (Discrete sig) = Discrete $ traceSignalMaybe loc msg sig+  where+    msg (True, val) = Just $ show (f val)+    msg (False, _) = Nothing++keepJustsD :: MonadSignalGen m => Discrete (Maybe (Maybe a))+           -> m (Discrete (Maybe a))+keepJustsD tm = do+    emm <- preservesD tm+    stepperD Nothing (justE emm)++keepDJustsD :: MonadSignalGen m => Discrete (Maybe (Discrete a))+            -> m (Discrete (Maybe a))+keepDJustsD dmd =+    fmap (fmap Just) . justE <$> preservesD dmd+    >>= stepperD (return Nothing) >>= switchD++-- $app_discrete_maybe+-- Convenience combinators for working with \''Discrete' a\' and \''Discrete'+-- (Maybe a)\' in applicative style. You can choose the right one by+-- representing what's on the left and right side of the operator with+-- the following rules:+--+-- * \'-' is for Discrete a+--+-- * \'?' is for Discrete (Maybe a)+--+infixl 4 <$?>, <?*?>, <-*?>, <?*->+(<$?>) :: (a -> b) -> Discrete (Maybe a) -> Discrete (Maybe b)+f <$?> valmD = fmap f <$> valmD++(<?*?>) :: Discrete (Maybe (a -> b)) -> Discrete (Maybe a) -> Discrete (Maybe b)+fmD <?*?> valmD = do+    fm <- fmD+    valm <- valmD+    return (fm <*> valm)++(<-*?>) :: Discrete (a -> b) -> Discrete (Maybe a) -> Discrete (Maybe b)+f <-*?> valmD = (fmap <$> f) <*> valmD++(<?*->) :: Discrete (Maybe (a -> b)) -> Discrete a -> Discrete (Maybe b)+fmD <?*-> valD = do+    fm <- fmD+    case fm of+        Just f -> Just . f <$> valD+        Nothing -> return Nothing++infixl 4 <~~>+-- | When using applicative style and mixing @('Discrete' a)@ and+-- @('Discrete' ('Maybe' a))@, EasyApply's \<~~> will attempt to choose the+-- right combinator. This is an experimental idea, and may be more+-- trouble than it's worth in practice.+--+-- GHC will fail to find instances under various circumstances, such+-- as when when anonymous functions are applied to tuples, so you will+-- have to fall back to using explicit combinators.+class EasyApply a b c | a b -> c where+  (<~~>) :: a -> b -> c++instance EasyApply (a -> b) (Discrete a) (Discrete b) where+    (<~~>) = (<$>)+instance EasyApply (Discrete (a -> b)) (Discrete a) (Discrete b) where+    (<~~>) = (<*>)+instance EasyApply (a -> b) (Discrete (Maybe a)) (Discrete (Maybe b)) where+    (<~~>) = (<$?>)+instance EasyApply (Discrete (Maybe (a -> b))) (Discrete (Maybe a)) (Discrete (Maybe b)) where+    (<~~>) = (<?*?>)+instance EasyApply (Discrete (a -> b)) (Discrete (Maybe a)) (Discrete (Maybe b)) where+    (<~~>) = (<-*?>)+instance EasyApply (Discrete (Maybe (a -> b))) (Discrete a) (Discrete (Maybe b)) where+    (<~~>) = (<?*->)++instance EasyApply (Signal (a -> b)) (Event a) (Event b) where+    (<~~>) = apply++-- Some instances which may be less common+instance EasyApply (Maybe (a -> b)) (Discrete a) (Discrete (Maybe b)) where+    Just f <~~> valD = Just . f <$> valD+    Nothing <~~> _ = return Nothing++-- Add more as necessary. TODO the application of some more brainpower+-- should be able to get all possible instances using type-level+-- programming, I think.++-- Evaluation control++-- | Forces the value in a Discrete.+forceD :: MonadSignalGen m => Discrete a -> m (Discrete a)+forceD aD = generatorD $ (\x -> x `seq` return x) <$> aD++-- | Like forceD, but for Event.+forceE :: MonadSignalGen m => Event a -> m (Event a)+forceE aE = generatorE $ (\x -> x `seq` return x) <$> aE++-- | Completely evaluates the value in a Discrete.+rnfD :: (NFData a, MonadSignalGen m) => Discrete a -> m (Discrete a)+rnfD = forceD . fmap force++-- | Like rnfD, but for Event.+rnfE :: (NFData a, MonadSignalGen m) => Event a -> m (Event a)+rnfE = forceE . fmap force++#if !MIN_VERSION_deepseq(1,2,0)+force :: NFData a => a -> a+force x = x `deepseq` x+#endif+++--------------------------------------------------------------------------------+-- SignalSet++-- | A class of signal-like types.+class SignalSet a where+    -- | Create a dynamically switched @a@. The returned value doesn't need+    -- to be properly memoized. The user should call `switchD` instead.+    basicSwitchD :: MonadSignalGen m => Discrete a -> m a+    -- | Memoize a signal set.+    memoizeSignalSet :: MonadSignalGen m => a -> m a++instance SignalSet (Signal a) where+    basicSwitchD dis = return $ join $ discreteToSignalNoMemo dis+    memoizeSignalSet = memoS++instance SignalSet (Event a) where+    basicSwitchD dis = return $ joinEventSignal $ discreteToSignalNoMemo dis+    memoizeSignalSet = memoE++instance SignalSet (Discrete a) where+    basicSwitchD dis = return $ join dis+    memoizeSignalSet = memoD++instance (SignalSet a, SignalSet b) => SignalSet (a, b) where+    basicSwitchD dis = (,)+        <$> (basicSwitchD $ fst <$> dis)+        <*> (basicSwitchD $ snd <$> dis)+    memoizeSignalSet (x, y) = (,) <$> memoizeSignalSet x <*> memoizeSignalSet y++instance (SignalSet a, SignalSet b, SignalSet c) => SignalSet (a, b, c) where+    basicSwitchD dis = (,,)+        <$> (basicSwitchD $ e30 <$> dis)+        <*> (basicSwitchD $ e31 <$> dis)+        <*> (basicSwitchD $ e32 <$> dis)+        where+            e30 (a, _, _) = a+            e31 (_, a, _) = a+            e32 (_, _, a) = a+    memoizeSignalSet (x, y, z) =+        (,,) <$> memoizeSignalSet x <*> memoizeSignalSet y <*> memoizeSignalSet z++instance (SignalSet a, SignalSet b, SignalSet c, SignalSet d) =>+        SignalSet (a, b, c, d) where+    basicSwitchD dis = (,,,)+        <$> (basicSwitchD $ e40 <$> dis)+        <*> (basicSwitchD $ e41 <$> dis)+        <*> (basicSwitchD $ e42 <$> dis)+        <*> (basicSwitchD $ e43 <$> dis)+        where+            e40 (a, _, _, _) = a+            e41 (_, a, _, _) = a+            e42 (_, _, a, _) = a+            e43 (_, _, _, a) = a+    memoizeSignalSet (x0, x1, x2, x3) = (,,,)+      <$> memoizeSignalSet x0+      <*> memoizeSignalSet x1+      <*> memoizeSignalSet x2+      <*> memoizeSignalSet x3++instance (SignalSet a, SignalSet b, SignalSet c, SignalSet d, SignalSet e) =>+        SignalSet (a, b, c, d, e) where+    basicSwitchD dis = (,,,,)+        <$> (basicSwitchD $ e50 <$> dis)+        <*> (basicSwitchD $ e51 <$> dis)+        <*> (basicSwitchD $ e52 <$> dis)+        <*> (basicSwitchD $ e53 <$> dis)+        <*> (basicSwitchD $ e54 <$> dis)+        where+            e50 (a, _, _, _, _) = a+            e51 (_, a, _, _, _) = a+            e52 (_, _, a, _, _) = a+            e53 (_, _, _, a, _) = a+            e54 (_, _, _, _, a) = a+    memoizeSignalSet (x0, x1, x2, x3, x4) = (,,,,)+      <$> memoizeSignalSet x0+      <*> memoizeSignalSet x1+      <*> memoizeSignalSet x2+      <*> memoizeSignalSet x3+      <*> memoizeSignalSet x4++-- | discreteToSignal outside the SignalGen monad.+-- A careless use leads to repeated computation.+discreteToSignalNoMemo :: Discrete a -> Signal a+discreteToSignalNoMemo (Discrete x) = snd <$> x++--------------------------------------------------------------------------------+-- Testing++signalFromList :: [a] -> SignalGen (Signal a)+signalFromList list = fmap hd <$> stateful list tl+    where+        hd [] = error "signalFromList: list exhausted"+        hd (x:_) = x++        tl [] = error "signalFromList: list exhausted"+        tl (_:xs) = xs++eventFromList :: [[a]] -> SignalGen (Event a)+eventFromList list = Event <$> signalFromList (list ++ repeat [])++networkToList :: Int -> SignalGen (Signal a) -> IO [a]+networkToList n network = do+    sample <- start network+    replicateM n sample++-- vim: ts=2 sts=2
+ FRP/Euphoria/Internal/Maplike.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}++-- 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(..)+    ) where++import Data.Hashable (Hashable)+import qualified Data.Map            as Map+import qualified Data.HashMap.Strict as HMS+import qualified Data.EnumMap.Lazy   as EML++-- | 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+    intersection :: c k v -> c k v -> c k v+    difference   :: c k v -> c k v -> c k v+    empty        :: c k v+    lookup       :: k -> c k v -> Maybe v+    singleton    :: k -> v -> c k v+    singleton k v = insert k v empty+    insert :: k -> v -> c k v -> c k v+    insert k v m = singleton k v `union` m+    delete :: k -> c k v -> c k v+    delete k m =  m `difference` singleton k (error "bug")+    toList :: c k v -> [(k, v)]++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 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 (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
+ FRP/Euphoria/Signal.hs view
@@ -0,0 +1,105 @@+{-# OPTIONS_GHC -Wall #-}+-- | Re-exported and renamed definitions from FRP.Elerea.Simple.+module FRP.Euphoria.Signal+    (+    -- * Re-exports+      Signal+    , SignalGen+    , execute+    , external+    , start+    -- * MonadSignalGen+    , MonadSignalGen(..)+    -- * Renamed functions+    , delayS+    , generatorS+    , snapshotS+    , memoS+    , transferS+    ) where++import FRP.Elerea.Simple+import Control.Monad.Fix+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer.Lazy as Lazy+import Control.Monad.Trans.State.Lazy as Lazy+import Control.Monad.Trans.RWS.Lazy as Lazy+import Control.Monad.Trans.Writer.Strict as Strict+import Control.Monad.Trans.State.Strict as Strict+import Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Except++import Control.Monad.Trans.Class (lift)++class MonadFix m => MonadSignalGen m where+    liftSignalGen :: SignalGen a -> m a++instance MonadSignalGen SignalGen where+    liftSignalGen = id++instance MonadSignalGen m => MonadSignalGen (IdentityT m) where+    liftSignalGen = lift . liftSignalGen++instance MonadSignalGen m => MonadSignalGen (MaybeT m) where+    liftSignalGen = lift . liftSignalGen++instance MonadSignalGen m => MonadSignalGen (ReaderT r m) where+    liftSignalGen = lift . liftSignalGen++instance (MonadSignalGen m, Monoid w) => MonadSignalGen (Lazy.WriterT w m) where+    liftSignalGen = lift . liftSignalGen++instance MonadSignalGen m => MonadSignalGen (Lazy.StateT s m) where+    liftSignalGen = lift . liftSignalGen++instance (MonadSignalGen m, Monoid w) => MonadSignalGen (Lazy.RWST r w s m) where+    liftSignalGen = lift . liftSignalGen++instance (MonadSignalGen m, Monoid w) => MonadSignalGen (Strict.WriterT w m) where+    liftSignalGen = lift . liftSignalGen++instance MonadSignalGen m => MonadSignalGen (Strict.StateT s m) where+    liftSignalGen = lift . liftSignalGen++instance (MonadSignalGen m, Monoid w) => MonadSignalGen (Strict.RWST r w s m) where+    liftSignalGen = lift . liftSignalGen++instance MonadSignalGen m => MonadSignalGen (ExceptT e m) where+    liftSignalGen = lift . liftSignalGen++-- | Same as 'FRP.Elerea.Simple.delay'+--+-- @delayS sig@ returns a 'Signal' whose value is equal to+-- the value of @sig@ in the previous step. This function+-- does not introduce a direct dependency; for example it+-- is ok if @sig@ depends on the resulting signal of the+-- call.+delayS :: MonadSignalGen m => a -> Signal a -> m (Signal a)+delayS a s = liftSignalGen (delay a s)++-- | Same as 'FRP.Elerea.Simple.generator'+--+-- @generatorS net@ runs the 'SignalGen' action specified+-- by @net@ each step. @generatorS@ returns a signal that+-- contains the value returned by the action in this step.+generatorS :: MonadSignalGen m => Signal (SignalGen a) -> m (Signal a)+generatorS = liftSignalGen . generator++-- | Same as 'FRP.Elerea.Simple.snapshot'+--+-- @snapshotS sig@ returns the current value of @sig@.+snapshotS :: MonadSignalGen m => Signal a -> m a+snapshotS = liftSignalGen . snapshot++-- | Same as 'FRP.Elerea.Simple.memo'+--+-- @memoS sig@ returns a memoized version of @sig@. The returned+-- signal can be used any number of times without the risk of+-- duplicated computation.+memoS :: MonadSignalGen m => Signal a -> m (Signal a)+memoS = liftSignalGen . memo++transferS :: MonadSignalGen m => a -> (t -> a -> a)-> Signal t -> m (Signal a)+transferS a k = liftSignalGen . transfer a k
+ FRP/Euphoria/Update.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wall #-}++-- | Signals for incremental updates.+module FRP.Euphoria.Update+    ( Update(..)+    , updateUseAll+    , updateUseLast+    , updateUseAllIO+    , stepperUpdate+    , discreteToUpdate+    , mappendUpdateIO+    , startUpdateNetwork+    , startUpdateNetworkWithValue++    , IOMonoid(..)+    ) where++import Control.Applicative+import Control.Monad+import Data.IORef+import Data.Maybe+import Data.Monoid+import Data.Unique+import Unsafe.Coerce++import FRP.Euphoria.Event++-- | @Update a@ represents a stream of events, just like an 'Event'.+-- Unlike an 'Event', you cannot observe individual event ocurrences;+-- you first specify a time interval, and you will receive data+-- made by combining together all occurrences in that interval.+-- The type @a@ represents those combined data.+--+-- A typical usage is to update external objects in batch.+-- For example, suppose you have @(data :: 'Discrete' 'String')@ which+-- you want to display on a GUI window. The simplest way to do+-- this would be to use 'changesD' to obtain a event stream of+-- all changes to @data@, then use fmap to construct a stream of update actions+-- of type @'Event' (IO ())@, which will be executed one by one.+-- However, this becomes wasteful if @data@ changes more frequently+-- than you want to update the window, for example you only update the+-- window once in a few network steps. This is because all but the last+-- update operation will be immediately overwritten and have no effect.+--+-- A better way here is to create an @Update (IO ())@ which gives+-- no more than 1 operation when sampled, corresponding to the last change+-- of the underlying data. To do this you first apply 'updateUseLast'+-- to the event stream of changes, then use fmap to construct an+-- @Update (IO ())@.+--+-- Note: there is no way to construct a 'Signal', 'Event', or 'Discrete'+-- that depends on an 'Update'. The only way to extract information+-- from an 'Update' is 'startUpdateNetwork'.+--+-- Note: in the current implementation, if you use an 'Update' twice,+-- an unbounded amount of computation can be duplicated. Please+-- avoid doing so.+data Update a = forall s. (Monoid s) => Update (s -> a) (Event s)++instance Functor Update where+    f `fmap` Update final evt = Update (f . final) evt++instance Applicative Update where+    pure x = Update (const x) (mempty :: Event ())+    Update f_final f_evt <*> Update a_final a_evt = Update+        (\(f_s, a_s) -> f_final f_s (a_final a_s))+        ((left <$> f_evt) `mappend` (right <$> a_evt))+        where+            left f = (f, mempty)+            right a = (mempty, a)++instance (Monoid a) => Monoid (Update a) where+    mempty = Update (\() -> mempty) mempty+    Update f x `mappend` Update g y = Update+        (\(s0, s1) -> f s0 `mappend` g s1)+        ((left <$> x) `mappend` (right <$> y))+        where+            left val = (val, mempty)+            right val = (mempty, val)++-- | Convert an 'Event' to an 'Update' by combining the occurrences,+-- i.e. without doing any shortcut.+updateUseAll :: (Monoid a) => Event a -> Update a+updateUseAll evt = Update id evt++-- | Create an 'Update' that ignores all but the latest occurrences.+updateUseLast :: Event a -> Update (Maybe a)+updateUseLast evt = Update getLast (Last . Just <$> evt)++-- is it useful?+stepperUpdate :: a -> Event a -> Update a+stepperUpdate initial aE = fromMaybe initial <$> updateUseLast aE++-- | > discreteToUpdate d = fmap updateUseLast (preservesD d)+discreteToUpdate :: MonadSignalGen m => Discrete a -> m (Update (Maybe a))+discreteToUpdate aD = updateUseLast <$> preservesD aD++-- | Do the same thing as 'updateUseAll' but use (>>) in place of mappend.+updateUseAllIO :: Monoid a => Event (IO a) -> Update (IO a)+updateUseAllIO ioE = unIOMonoid <$> updateUseAll (IOMonoid <$> ioE)++-- | Do the same thing as 'mappend' but use (>>) in place of mappend.+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 #-}++-- | Do the same thing as 'mappendUpdateIO' but specialized to 'IO ()'+mappendUpdateIOUnit :: Update (IO ()) -> Update (IO ()) -> Update (IO ())+mappendUpdateIOUnit = liftA2 (>>)++instance (Monoid a) => SignalSet (Update a) where+    basicSwitchD dis = do+        updatesE <- preservesD dis+        dynUpdatesE <- mapEIO mkDynUpdates updatesE+        dynUpdatesD <- stepperD undefined dynUpdatesE+        dynE <- switchD dynUpdatesD+        initial <- liftSignalGen $ execute newDynUpdateState+        return $ Update (applyDynUpdates initial) dynE+        where+            applyDynUpdates initial (Dual (Endo f)) = case f initial of+                DUS toFinal _ acc accFinal -> accFinal `mappend` toFinal acc+    memoizeSignalSet = return -- There is no effective way to memoize it.++mkDynUpdates :: (Monoid a) => Update a -> IO (Event (DynUpdate a))+mkDynUpdates _upd@(Update toFinal evt) = do+    u <- newUnique+    return $ toUpdate u <$> evt+    where+        toUpdate u x = Dual $ Endo $ \(DUS currentToFinal current accCurrent accFinal) ->+            if current /= u+                then-- The current underlying is different from _upd.+                    -- So we finalize the current accumulator and+                    -- set _upd as the current underlying.+                    DUS toFinal u x (mappend accFinal (currentToFinal accCurrent))+                else-- The current underlying is already the same as _upd.+                    -- This means accCurrent is of the same type as x.+                    -- We add x to the current accumulator.+                    DUS currentToFinal current (mappend accCurrent x') accFinal+            where+                x' = unsafeCoerce x++newDynUpdateState :: (Monoid a) => IO (DynUpdateState a)+newDynUpdateState = do+    u <- newUnique+    return $! DUS (const mempty) u () mempty++type DynUpdate a = Dual (Endo (DynUpdateState a))+data DynUpdateState a =+    forall s{-current underlying monoid-}. (Monoid s) => DUS+        (s -> a) -- how to turn the current monoid into the final type+        !Unique -- unique id for the current underlying Update+        !s -- accumulated current monoid+        !a -- accumulated final result++newtype IOMonoid a = IOMonoid {unIOMonoid :: IO a}++instance (Monoid a) => Monoid (IOMonoid a) where+    mempty = IOMonoid (return mempty)+    IOMonoid x `mappend` IOMonoid y =+        IOMonoid $ do+            x' <- x+            y' <- y+            return (x' `mappend` y')++data Changes a = forall s. (Monoid s) => Changes (s -> a) s++-- | Execute a network whose output is represented with an 'Update'.+-- It returns 2 actions, a sampling action and a stepping action.+-- The stepping action executes one cycle of the network, updating+-- its internal state. The sampling action first steps the network,+-- then observes the final 'Update' value. It returns the+-- combined value corresponding to the interval between now and the+-- last time the sampling action was executed.+startUpdateNetwork+    :: SignalGen (Update a)+    -> IO (IO a, IO ())+startUpdateNetwork network = do+    (sample, step) <- startUpdateNetworkWithValue network'+    return (fst <$> sample, step)+    where+        network' = flip (,) (pure ()) <$> network++-- | Execute a network that has both a continuous output and an+-- accumulated updates.+startUpdateNetworkWithValue :: SignalGen (Update a, Signal b) -> IO (IO (a, b), IO b)+startUpdateNetworkWithValue network = do+    changesRef <- newIORef Nothing+    valueRef <- newIORef undefined+    -- IORef (Maybe Changes)+    sample <- start $ do+        (update, signal) <- network+        case update of+            Update final updateE -> return $+                (>>) <$> updateChanges <*> updateVal+                where+                    updateChanges = updateRef changesRef final <$> eventToSignal updateE+                    updateVal = writeIORef valueRef <$> signal+    return (join sample >> readBoth valueRef changesRef, join sample >> readIORef valueRef)+    where+        updateRef changesRef final occs = do+            changes <- readIORef changesRef+            writeIORef changesRef $! Just $! case changes of+                Nothing -> Changes final newChanges+                Just (Changes _ oldChanges) ->+                    let !allChanges = unsafeCoerce oldChanges `mappend` newChanges+                        -- FIXME: I believe it's possible to avoid unsafeCoerce here (akio)+                    in Changes final allChanges+            where !newChanges = mconcat occs++        readBoth valueRef changesRef =+            (,) <$> takeChanges changesRef+                <*> readIORef valueRef++        takeChanges changesRef = do+            changes <- readIORef changesRef+            case changes of+                Nothing -> error "FRP.Elerea.Extras.Update: bug: no changes"+                Just (Changes final oldChanges) -> do+                    writeIORef changesRef Nothing+                    return $! final oldChanges
+ LICENSE view
@@ -0,0 +1,1 @@+The files are in the public domain.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ euphoria.cabal view
@@ -0,0 +1,99 @@+-- Initial euphoria.cabal generated by cabal init. For further documentation,+-- see http://haskell.org/cabal/users-guide/++name:                euphoria+version:             0.6.0.1+synopsis:            Dynamic network FRP with events and continuous values+description:++ Euphoria is FRP with practicality.+ .+ FRP is a good way to model computations which need run for an extended+ period of time, react to incoming events, and continually produce+ output. Simulations, games, and GUIs are all good candidates for FRP.+ .+ In Euphoria, networks (dataflow graphs) are dynamic. Networks are+ first-class values which can be passed around inside of other+ networks, and they can be connected together at any time. This+ flexibility allows complicated, real-world problems to be modeled with+ FRP.+ .+ Though Euphoria is flexible and high-level, it makes some concessions+ for performance and the underlying implementation.+ .+ Euphoria works in discrete steps. You will construct the body of your+ program as an FRP network. To get results, you must perform an IO+ action to step the network. After stepping, your network will have+ produced some result, such as a string, which you can print to the+ screen. A network can also produce IO actions as an output. Step the+ network as many times as necessary to continue running your program.+ .+ A simulation, game, or GUI will probably loop while stepping until the+ user terminates the program.+ .+ Euphoria is mostly concerned with three types: Signal, Event, and+ Discrete.+ .+ Signal represents a continuous value that changes with each+ step of the network. Discrete is like Signal, but it is possible to+ determine if its value has not changed, and avoid unnecessary+ computation. As long as a Signal or Discrete exists, it will contain a+ value. Event represents something that exists for only one moment in+ time, such as a packet received over a socket, or a mouse click.+ .+ Signals and Discretes are instances of Monad and Applicative. Events+ are instances of Monoid.+ .+ SignalGen is the outer monad, where networks are constructed.+ SignalGen is an instance of Monad and Applicative. SignalGens inside+ of Signals, Discretes, or Events can be used to attach new networks to+ the existing network on the fly.+ .+ Signals, Discretes and Events may contain other Signals, Discretes or+ Events. Euphoria encourages the use of dynamic network construction+ using these higher-order FRP types, and they can be attached or+ detached from the network with ease. Euphoria relies on garbage+ collection and weak pointers to prune the network when parts of it are+ no longer needed.+ .+ Euphoria is built on top of the Elerea library by Patai Gergely.++license:             PublicDomain+license-file:        LICENSE+author:              Takano Akio, Andrew Richards, Liyang HU+maintainer:          aljee@hyper.cx <Takano Akio>+-- copyright:+category:            FRP+build-type:          Simple+cabal-version:       >=1.8+homepage:            http://github.com/tsurucapital/euphoria++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+  -- other-modules:+  build-depends:       HUnit+                     , base >= 4.7 && < 4.9+                     , elerea >= 2.7+                     , data-default+                     , enummapset-th >= 0.6+                     , deepseq+                     , hashable >= 1.2+                     , containers >= 0.5.5+                     , unordered-containers >= 0.2.5+                     , transformers >= 0.4.1++test-suite tests+  type:           exitcode-stdio-1.0+  main-is:        Tests.hs+  hs-source-dirs: tests+  ghc-options:    -Wall+  build-depends:  HUnit+                , base+                , euphoria+                , test-framework+                , test-framework-hunit+                , test-framework-th
+ tests/Tests.hs view
@@ -0,0 +1,14 @@+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+    ]