summaryrefslogtreecommitdiff
path: root/Reactor/Observer.hs
blob: 58e5923b1a6c0da6eb8938eb357aff7a06fecc1a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
{-# LANGUAGE DeriveDataTypeable #-}
module Reactor.Observer
  ( Observer(..)
  , (?!)
  ) where

import Prelude hiding (filter)
import Control.Monad
import Control.Exception hiding (handle)
import Control.Monad.Error
import Data.Monoid
import Data.Functor.Contravariant
import Data.Data
import Reactor.Filtered
import Reactor.Task

data Observer a = Observer 
  { (!)      :: a -> Task ()
  , handle   :: SomeException -> Task ()
  , complete :: Task ()
  } deriving Typeable

instance Contravariant Observer where
  contramap g (Observer f h c) = Observer (f . g) h c

instance Filtered Observer where
  filter p (Observer f h c) = Observer (\a -> when (p a) (f a)) h c

instance Monoid (Observer a) where
  mempty = Observer (\_ -> return ()) throwError (return ())
  p `mappend` q = Observer
    (\a -> do p ! a; q ! a)
    (\e -> do handle p e; handle q e)
    (do complete p; complete q)

-- filter and map in one operation
(?!) :: Observer b -> (a -> Maybe b) -> Observer a
Observer f h c ?! p = Observer (maybe (return ()) f . p) h c