Skip to content
Browse files

initial import

  • Loading branch information...
0 parents commit 9a084de633dd54144d6a4f929df45d36550c1b90 @takano-akio takano-akio committed
Showing with 1,381 additions and 0 deletions.
  1. +17 −0 FRP/Euphoria/Abbrev.hs
  2. +247 −0 FRP/Euphoria/Collection.hs
  3. +723 −0 FRP/Euphoria/Event.hs
  4. +35 −0 FRP/Euphoria/Signal.hs
  5. +283 −0 FRP/Euphoria/Update.hs
  6. +1 −0 LICENSE
  7. +2 −0 Setup.hs
  8. +73 −0 euphoria.cabal
17 FRP/Euphoria/Abbrev.hs
@@ -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
247 FRP/Euphoria/Collection.hs
@@ -0,0 +1,247 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE DoRec, ScopedTypeVariables #-}
+
+-- | Collection signals with incremental updates.
+module FRP.Euphoria.Collection
+( CollectionUpdate (..)
+, Collection
+, simpleCollection
+, watchCollection
+, listToCollection
+, mapToCollection
+, followCollectionKey
+, collectionToDiscreteList
+) where
+
+import Control.Applicative
+import Data.EnumMap (EnumMap)
+import qualified Data.EnumMap as EnumMap
+import Data.List
+import Data.Maybe (mapMaybe)
+import Data.Monoid
+
+import FRP.Euphoria.Event
+
+
+-- | Represents an incremental change to a collection of items.
+data CollectionUpdate k a
+ = AddItem k a
+ | RemoveItem k
+
+-- | 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].
+type Collection k a = Discrete ([(k, a)], Event (CollectionUpdate k a))
+
+-- | A collection whose items are created by an event, and removed by
+-- another event.
+simpleCollection :: (Enum 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.
+ -> SignalGen (Collection k a)
+simpleCollection initialK evs =
+ simpleCollectionUpdates initialK evs >>= accumCollection
+
+simpleCollectionUpdates :: (Enum k) => k
+ -> Event (a, Event ())
+ -> SignalGen (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.foldWithKey
+ (\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)
+
+-- Turns 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)
+ => Event (CollectionUpdate k a)
+ -> SignalGen (Collection k a)
+accumCollection ev = do
+ let toMapOp (AddItem k a) = EnumMap.insert k a
+ toMapOp (RemoveItem k) = EnumMap.delete k
+ mapping <- accumD EnumMap.empty (toMapOp <$> ev)
+ let -- f :: (Enum k) => EnumMap k a -> SGen ([(k, a)], Event (CollectionUpdate k a))
+ f m = do
+ ev' <- dropStepE ev
+ return (EnumMap.toList m, ev')
+ generatorD $ f <$> mapping
+
+-- | Prints add/remove diagnostics for a Collection. Useful for debugging
+watchCollection :: (Show k, Show a)
+ => Collection k a -> SignalGen (Event (IO ()))
+watchCollection 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)
+
+-- | 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.
+listToCollection :: (Enum k, Eq a)
+ => k
+ -> Discrete [a]
+ -> SignalGen (Collection k a)
+listToCollection 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
+
+data MapCollEvent k a
+ = MCNew k a
+ | MCChange k a
+ | MCRemove k
+
+mapCollDiff :: (Enum k, Eq a) => EnumMap k a -> EnumMap k a -> [MapCollEvent k a]
+mapCollDiff prevmap newmap = newEvs ++ removeEvs ++ changeEvs
+ where
+ newStuff = newmap EnumMap.\\ prevmap
+ removedStuff = prevmap EnumMap.\\ newmap
+ keptStuff = newmap `EnumMap.intersection` prevmap
+ changedStuff = mapMaybe f (EnumMap.toList keptStuff)
+ where f (k, v1) = case EnumMap.lookup k prevmap of
+ Nothing -> Nothing
+ Just v2 | v1 /= v2 -> Just (k, v1)
+ | otherwise -> Nothing
+ makeNew (k, v) = MCNew k v
+ makeRemove (k, _) = MCRemove k
+ makeChange (k, v) = MCChange k v
+ newEvs = map makeNew (EnumMap.toList newStuff)
+ removeEvs = map makeRemove (EnumMap.toList removedStuff)
+ changeEvs = map makeChange changedStuff
+
+dispatchCollEvent :: (Enum k, Eq k, Eq a)
+ => Event (MapCollEvent k a)
+ -> SignalGen (Collection k (Discrete a))
+dispatchCollEvent mapcollE = do
+ let f (MCChange k a) = Just (k, a)
+ f _ = Nothing
+ changeEv <- memoE $ filterNothingE (f <$> mapcollE)
+ let g (MCNew k a) = Just $
+ AddItem k <$> followCollItem a k changeEv
+ g (MCRemove k) = Just $ return $ RemoveItem k
+ g (MCChange _ _) = Nothing
+ updateEv <- generatorE $ filterNothingE (g <$> mapcollE)
+ accumCollection updateEv
+
+followCollItem :: (Eq k) => a -> k
+ -> Event (k, a)
+ -> SignalGen (Discrete a)
+followCollItem val k1 ev = stepperD val (filterNothingE (f <$> ev))
+ where f (k2, v) | k1 == k2 = Just v
+ | otherwise = Nothing
+
+-- | 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 k a.
+ (Enum k, Eq k, Eq a)
+ => Discrete (EnumMap k a)
+ -> SignalGen (Collection k (Discrete a))
+mapToCollection mapD = do
+ m1 <- delayD EnumMap.empty mapD
+ let collDiffs :: Discrete [MapCollEvent k a]
+ collDiffs = mapCollDiff <$> m1 <*> mapD
+ dispatchCollEvent . flattenE =<< preservesD collDiffs
+
+-- | Look for a key in a collection, and give its (potentially
+-- nonexistant) value over time.
+followCollectionKey :: forall k a. (Eq k)
+ => k
+ -> Collection k a
+ -> SignalGen (Discrete (Maybe a))
+followCollectionKey k coll = do
+ collAsNow <- takeE 1 =<< preservesD coll
+ :: SignalGen (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
+ :: SignalGen (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 k a.
+ (k -> Bool)
+ -> Event (CollectionUpdate k a)
+ -> SignalGen (Discrete (Maybe a))
+accumMatchingItem f updateE =
+ stepperD Nothing $ filterNothingE (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
723 FRP/Euphoria/Event.hs
@@ -0,0 +1,723 @@
+{-# LANGUAGE DeriveFunctor, MultiParamTypeClasses, DeriveDataTypeable, BangPatterns, DoRec #-}
+
+-- For EasyApply
+{-# LANGUAGE FlexibleInstances, FunctionalDependencies #-}
+
+{-# OPTIONS_GHC -Wall #-}
+-- | Event/discrete layer constructed on top of Elera.
+-- The API is largely inspired by reactive-banana.
+module FRP.Euphoria.Event
+(
+-- * Events
+ Event
+-- ** Creation
+, externalEvent
+, eachSample
+, onCreation
+, signalToEvent
+-- ** Sampling
+, apply
+, eventToSignal
+-- ** State accumulation
+-- | With these functions, any input event occurrence will affect the output
+-- immediately, without any delays.
+, stepper
+, accumB
+, accumBIO
+, accumE
+, scanAccumE
+-- ** Filtering and other list-like operations
+, filterE
+, filterNothingE
+, mapMaybeE
+, flattenE
+, expandE
+, withPrev
+, dropE
+, dropWhileE
+, takeE
+, takeWhileE
+, groupByE
+, groupE
+, differentE
+-- ** Other event operations
+, delayE
+, dropStepE
+, effectfulEE
+, memoE
+, joinEventSignal
+, generatorE
+-- * Discrete signals
+, Discrete
+-- ** Accumulation
+, stepperD
+, stepperDefD
+, stepperMaybeD
+, accumD
+-- ** Conversion into events
+, eachSampleD
+, 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
+, generatorD'
+, SignalSet (..)
+-- * Debugging
+-- | Side-effecting trace functions
+, traceSignalMaybe
+, traceSignalT
+, traceEventT
+, traceDiscreteT
+-- * Testing
+, signalFromList
+, eventFromList
+, networkToList
+) where
+
+import Control.Applicative
+import Control.Monad (join, replicateM)
+import Control.Monad.Fix
+import Data.Default
+import Data.List (foldl')
+import Data.Monoid
+import Data.Maybe
+import Data.Typeable
+import Debug.Trace
+import FRP.Euphoria.Signal
+import FRP.Elerea.Simple (transfer, externalMulti, effectful1, until, stateful)
+import Prelude hiding (until)
+import Test.HUnit
+
+-- | @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 :: IO (SignalGen (Event a), a -> IO ())
+externalEvent = do
+ (gen, trigger) <- externalMulti
+ return (Event . fmap reverse <$> gen, trigger)
+
+-- | Transform an event stream using a time-varying transformation function.
+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
+
+-- | @stepper initial evt@ returns a signal whose value is the last occurrence
+-- of @evt@, or @initial@ if there has been none.
+stepper :: a -> Event a -> SignalGen (Signal a)
+stepper initial (Event evt) = transfer initial upd evt
+ where
+ upd [] old = old
+ upd occs _ = last occs
+
+-- | @eachSample sig@ is an event that occurs every step, having the same
+-- value as @sig@.
+eachSample :: Signal a -> Event a
+eachSample = Event . fmap (:[])
+
+-- | 'Discrete' version of eachSample.
+eachSampleD :: Discrete a -> SignalGen (Event a)
+eachSampleD d = do
+ sig <- discreteToSignal d
+ return $ eachSample sig
+
+-- | The basic construct to build a stateful signal. @accumB 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:
+--
+-- > accumB 0 $ (+) <$> nums
+accumB :: a -> Event (a -> a) -> SignalGen (Signal a)
+accumB initial (Event evt) = transfer initial upd evt
+ where
+ upd occs old = foldl' (flip ($)) old occs
+
+-- | @accumB@ with side-effecting updates.
+accumBIO :: a -> Event (a -> IO a) -> SignalGen (Signal a)
+accumBIO initial (Event evt) = mfix $ \self -> do
+ prev <- delayS initial self
+ effectful1 id $ update <$> prev <*> evt
+ where
+ update prev upds = foldl' (>>=) (return prev) upds
+
+-- | @accumE initial evt@ maintains an internal state just like @accumB@.
+-- 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 :: a -> Event (a -> a) -> SignalGen (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 :: s -> Event (s -> (s, a)) -> SignalGen (Event a)
+scanAccumE initial ev = (snd <$>) <$> accumE (initial, undefined) (f <$> ev)
+ where
+ f fn (s, _) = fn s
+
+-- | Drops all events in this network step
+dropStepE :: Event a -> SignalGen (Event a)
+dropStepE ev = do
+ initial <- delayS True (pure False)
+ memoE $ filterNothingE $ 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.
+effectfulEE :: (t -> IO a) -> Event t -> SignalGen (Event a)
+effectfulEE mkAction (Event evt) = Event <$> effectful1 (mapM mkAction) evt
+
+-- | Memoization of events. See the doc for 'FRP.Elerea.Simple.memo'.
+memoE :: Event a -> SignalGen (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'.
+filterNothingE :: Event (Maybe a) -> Event a
+filterNothingE (Event evt) = Event $ catMaybes <$> evt
+
+-- | Like 'mapMaybe' over events.
+mapMaybeE :: (a -> Maybe b) -> Event a -> Event b
+mapMaybeE f evt = filterNothingE $ f <$> evt
+
+-- | @onCreation x@ creates an event that occurs only once,
+-- immediately on creation.
+onCreation :: a -> SignalGen (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 :: Event a -> SignalGen (Event a)
+delayE (Event x) = Event <$> delayS [] x
+
+-- | @withPrev 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.
+withPrev :: a -> Event a -> SignalGen (Event (a, a))
+withPrev initial evt = accumE (initial, undefined) $ toUpd <$> evt
+ where
+ toUpd val (new, _old) = (val, new)
+
+-- | @generatorE evt@ creates a subnetwork every time @evt@ occurs.
+generatorE :: Event (SignalGen a) -> SignalGen (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 :: Int -> Event a -> SignalGen (Event a)
+dropE n (Event evt) = Event . fmap fst <$> transfer ([], 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 :: (a -> Bool) -> Event a -> SignalGen (Event a)
+dropWhileE p (Event evt) = Event . fmap fst <$> transfer ([], 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 :: Int -> Event a -> SignalGen (Event a)
+takeE n evt = generalPrefixE (primTakeE n) evt
+
+primTakeE :: Int -> Signal [a] -> SignalGen (Signal (Bool, [a]))
+primTakeE n evt = fmap fst <$> transfer ((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 :: (a -> Bool) -> Event a -> SignalGen (Event a)
+takeWhileE p evt = generalPrefixE (primTakeWhileE p) evt
+
+primTakeWhileE :: (a -> Bool) -> Signal [a] -> SignalGen (Signal (Bool, [a]))
+primTakeWhileE p evt = memoS $ f <$> evt
+ where
+ f occs = case span p occs of
+ (_, []) -> (True, occs)
+ (end, _) -> (False, end)
+
+generalPrefixE
+ :: (Signal [a] -> SignalGen (Signal (Bool, [a])))
+ -> Event a
+ -> SignalGen (Event a)
+generalPrefixE prefixTaker (Event evt) = do
+ rec
+ done <- until $ not . fst <$> active_occs
+ prevDone <- delayS False done
+ eventSource <- transfer evt upd prevDone
+ active_occs <- prefixTaker (join eventSource)
+ Event <$> memoS (snd <$> active_occs)
+ where
+ upd True _ = pure []
+ upd _ prev = prev
+
+-- | @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 :: (a -> a -> Bool) -> Event a -> SignalGen (Event (Event a))
+groupByE eqv sourceEvt = do
+ networkE <- filterNothingE <$> scanAccumE Nothing (makeNetwork <$> sourceEvt)
+ generatorE networkE
+ where
+ makeNetwork val currentVal
+ | maybe False (eqv val) currentVal = (currentVal, Nothing)
+ | otherwise = (Just val, Just $ network val)
+ network val = takeWhileE (eqv val) =<< dropWhileE (not . eqv val) sourceEvt
+
+-- | Same as @'groupByE' (==)@
+groupE :: (Eq a) => Event a -> SignalGen (Event (Event a))
+groupE = groupByE (==)
+
+-- | @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
+
+-- | @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 :: Discrete a -> SignalGen (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 :: Discrete a -> SignalGen a
+-- Seems to cause problems with the network. Is the underlying
+-- 'snapshot' actually safe?
+snapshotD (Discrete a) = snd <$> snapshotS a
+
+-- | Like 'stepper', but creates a 'Discrete'.
+stepperD :: a -> Event a -> SignalGen (Discrete a)
+stepperD initial (Event evt) = Discrete <$> transfer (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) => Event a -> SignalGen (Discrete a)
+stepperDefD = stepperD def
+
+-- | Use 'Nothing' to supply the initial value, and wrap the returned
+-- type in 'Maybe'.
+stepperMaybeD :: Event a -> SignalGen (Discrete (Maybe a))
+stepperMaybeD ev = stepperDefD (Just <$> ev)
+
+-- | Like @accumB@, but creates a 'Discrete'.
+accumD :: a -> Event (a -> a) -> SignalGen (Discrete a)
+accumD initial (Event evt) = Discrete <$> transfer (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) => Event a -> SignalGen (Event a)
+differentE ev = (filterNothingE . (f <$>)) <$> withPrev 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 :: Discrete a -> SignalGen (Discrete a)
+memoD (Discrete dis) = Discrete <$> memoS dis
+
+-- | Like 'delayS'.
+delayD :: a -> Discrete a -> SignalGen (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 :: Discrete (SignalGen a) -> SignalGen (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' :: (SignalSet s) => Discrete (SignalGen s) -> SignalGen 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 :: (Eq a) => Discrete a -> SignalGen (Discrete a)
+minimizeChanges (Discrete dis) = Discrete . fmap fromJust <$> transfer 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 :: Discrete a -> SignalGen (Discrete a)
+recordDiscrete (Discrete dis) = Discrete . fmap fromJust <$> transfer 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 :: Discrete a -> SignalGen (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) => Discrete s -> SignalGen s
+switchD dis = recordDiscrete dis >>= basicSwitchD >>= memoizeSignalSet
+
+-- | @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 :: Event () -> Discrete a -> SignalGen (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 :: Discrete (Maybe (Maybe a))
+ -> SignalGen (Discrete (Maybe a))
+keepJustsD tm = do
+ emm <- preservesD tm
+ stepperD Nothing (filterNothingE emm)
+
+keepDJustsD :: Discrete (Maybe (Discrete a))
+ -> SignalGen (Discrete (Maybe a))
+keepDJustsD dmd =
+ fmap (fmap Just) . filterNothingE <$> 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.
+
+--------------------------------------------------------------------------------
+-- 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 :: Discrete a -> SignalGen a
+ -- | Memoize a signal set.
+ memoizeSignalSet :: a -> SignalGen 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
+
+-- | 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
+
+--------------------------------------------------------------------------------
+-- Unit tests
+
+test_takeE :: Test
+test_takeE = test $ do
+ result <- networkToList 5 $ do
+ evt <- eventFromList [[1], [1::Int], [2,3], [], [4]]
+ evt2 <- takeE 3 evt
+ accumB 0 $ (+) <$> evt2
+ result @?= [1, 2, 4, 4, 4]
+
+test_takeWhileE :: Test
+test_takeWhileE = test $ do
+ result <- networkToList 5 $ do
+ evt <- eventFromList [[1], [1::Int], [2,3], [], [4]]
+ evt2 <- takeWhileE (<3) evt
+ accumB 0 $ (+) <$> evt2
+ result @?= [1, 2, 4, 4, 4]
+
+test_groupE :: Test
+test_groupE = test $ 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 <- stepper mempty threes
+ return $ eventToSignal $ joinEventSignal dyn
+ result @?= [[], [], [3], [], [3,3]]
+
+_unitTest :: IO Counts
+_unitTest = runTestTT $ test
+ [ test_takeE
+ , test_takeWhileE
+ , test_groupE
+ ]
+
+-- vim: ts=2 sts=2
35 FRP/Euphoria/Signal.hs
@@ -0,0 +1,35 @@
+{-# OPTIONS_GHC -Wall #-}
+-- | Re-exported and renamed definitions from FRP.Elerea.Simple.
+module FRP.Euphoria.Signal
+ (
+ -- * Re-exports
+ Signal
+ , SignalGen
+ , execute
+ , external
+ , start
+
+ -- * Renamed functions
+ , delayS
+ , generatorS
+ , snapshotS
+ , memoS
+ ) where
+
+import FRP.Elerea.Simple
+
+-- | Same as 'FRP.Elerea.Simple.delay'
+delayS :: a -> Signal a -> SignalGen (Signal a)
+delayS = delay
+
+-- | Same as 'FRP.Elerea.Simple.generator'
+generatorS :: Signal (SignalGen a) -> SignalGen (Signal a)
+generatorS = generator
+
+-- | Same as 'FRP.Elerea.Simple.snapshot'
+snapshotS :: Signal a -> SignalGen a
+snapshotS = snapshot
+
+-- | Same as 'FRP.Elerea.Simple.memo'
+memoS :: Signal a -> SignalGen (Signal a)
+memoS = memo
283 FRP/Euphoria/Update.hs
@@ -0,0 +1,283 @@
+{-# LANGUAGE ExistentialQuantification, TupleSections, BangPatterns #-}
+
+{-# OPTIONS_GHC -Wall #-}
+-- | Signals for incremental updates.
+module FRP.Euphoria.Update
+ ( Update(..)
+ , updateUseAll
+ , updateUseLast
+ , updateUseAllIO
+ , stepperUpdate
+ , discreteToUpdate
+ , mappendUpdateIO
+ , startUpdateNetwork
+ ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.IORef
+import Data.Maybe
+import Data.Monoid
+import Data.Unique
+import Unsafe.Coerce
+import Test.HUnit
+
+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 :: Discrete a -> SignalGen (Update (Maybe a))
+discreteToUpdate aD = updateUseLast <$> preservesD aD
+
+-- | Do the same thing as 'updateUseAll' but use (>>) in place of mappend.
+updateUseAllIO :: Event (IO ()) -> Update (IO ())
+updateUseAllIO ioE = unIOMonoid <$> updateUseAll (IOMonoid <$> ioE)
+
+-- | Do the same thing as 'mappend' but use (>>) in place of mappend.
+mappendUpdateIO :: Update (IO ()) -> Update (IO ()) -> Update (IO ())
+mappendUpdateIO d1 d2 = unIOMonoid <$> ((IOMonoid <$> d1) `mappend` (IOMonoid <$> d2))
+
+instance (Monoid a) => SignalSet (Update a) where
+ basicSwitchD dis = do
+ updatesE <- preservesD dis
+ dynUpdatesE <- effectfulEE mkDynUpdates updatesE
+ dynUpdatesD <- stepperD undefined dynUpdatesE
+ dynE <- switchD dynUpdatesD
+ initial <- 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
+ changesRef <- newIORef Nothing
+ -- IORef (Maybe Changes)
+ sample <- start $ do
+ update <- network
+ case update of
+ Update final updateE -> return $
+ updateRef changesRef final <$> eventToSignal updateE
+ return (join sample >> takeChanges changesRef, join sample)
+ 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
+
+ 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
+
+test_startUpdateNetwork :: Test
+test_startUpdateNetwork = test $ 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"]
+
+test_skip :: Test
+test_skip = test $ do
+ (sample, step) <- startUpdateNetwork $ do
+ update <- updateUseLast <$> eventFromList [[1], [2, 3], [], [4::Int]]
+ return $ update
+ step
+ val0 <- sample
+ val1 <- sample
+ step
+ val2 <- sample
+
+ val0 @?= Just 3
+ val1 @?= Nothing
+ val2 @?= Just 4
+
+test_mappendUpdate :: Test
+test_mappendUpdate = test $ 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"
+
+test_applicativeUpdate :: Test
+test_applicativeUpdate = test $ 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)]
+
+test_switchUD :: Test
+test_switchUD = test $ 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"
+
+_unitTest :: IO Counts
+_unitTest = runTestTT $ test
+ [ test_startUpdateNetwork
+ , test_mappendUpdate
+ , test_applicativeUpdate
+ , test_skip
+ , test_switchUD
+ ]
1 LICENSE
@@ -0,0 +1 @@
+The files are in the public domain.
2 Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
73 euphoria.cabal
@@ -0,0 +1,73 @@
+-- Initial euphoria.cabal generated by cabal init. For further documentation,
+-- see http://haskell.org/cabal/users-guide/
+
+name: euphoria
+version: 0.0.0.0
+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
+maintainer: aljee@hyper.cx <Takano Akio>
+-- copyright:
+category: FRP
+build-type: Simple
+cabal-version: >=1.8
+
+library
+ exposed-modules: FRP.Euphoria.Event, FRP.Euphoria.Signal, FRP.Euphoria.Update, FRP.Euphoria.Collection, FRP.Euphoria.Abbrev
+ -- other-modules:
+ build-depends: HUnit, base, elerea >= 2.7, data-default, enummapset

0 comments on commit 9a084de

Please sign in to comment.
Something went wrong with that request. Please try again.