Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: threadsafeSync
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 55 lines (43 sloc) 1.749 kb
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 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
{- | A synchronous implementation of the 'Control.Observer.Subject'
typeclass, , based on Observable.hs by Bastiaan Heeren,
originally from
<http://www.cs.uu.nl/wiki/bin/view/Afp0607/ExerciseWXHaskell>

The 'Control.Observer.Subject' implementation defined in this module
uses 'MVar's to provide a simple and threadsafe synchronous
implementation of the Observer design pattern.

Note that no constructor for 'Sub' is exported: client code must use
the 'createSub' smart constructor.

-}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Control.Observer.Synchronous (
    Sub,
    createSub
) where

import Control.Concurrent.MVar

import Control.Observer

-- | Threadsafe synchronous Subject implementation.

-- A Sub contains:
-- 1) an MVar pointer to the current value;
-- 2) an MVar pointer to a list of "notify" functions (the
-- observers).
data Sub a = SubC {
    value :: MVar a,
    observers :: MVar [a -> IO ()]
   }

instance Subject (Sub a) a where
    -- Read current value; would block if it was ever empty, but it
    -- shouldn't ever be.
    getValue = readMVar . value
    -- Write current value; we can't just use putMVar because it
    -- blocks if the MVar is full. We want to always overwrite.
    setValue' sub = modifyMVar_ (value sub) . const . return
    -- Append an observer to the list of observers.
    addObserver sub = modifyMVar_ (observers sub) . \x -> return . (++ [x])
    -- Get the current list of observers.
    getObservers = readMVar . observers

-- | Smart constructor for Sub.
createSub :: a -> IO (Sub a)
createSub val = do value' <- newMVar val
                   observers' <- newMVar []
                   return $ SubC value' observers'
Something went wrong with that request. Please try again.