Exhibit.hs

-- |
-- Module:     Control.Wire.Trans.Exhibit
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Wire transformers for handling inhibited signals.

module Control.Wire.Trans.Exhibit
    ( -- * Exhibition
      WExhibit(..)
    )
    where

import Control.Arrow
import Control.Wire.Types


-- | Wire transformers for handling inhibited signals.

class Arrow (>~) => WExhibit (>~) where
    -- | Produces 'Just', whenever the argument wire produces, otherwise
    -- 'Nothing'.
    --
    -- * Depends: like argument wire.
    event :: Wire e (>~) a b -> Wire e (>~) a (Maybe b)

    -- | Produces 'Right', whenever the argument wire produces, otherwise
    -- 'Left' with the inhibition value.
    --
    -- * Depends: like argument wire.
    exhibit :: Wire e (>~) a b -> Wire e (>~) a (Either e b)

    -- | Produces 'True', whenever the argument wire produces, otherwise
    -- 'False'.
    gotEvent :: Wire e (>~) a b -> Wire e (>~) a Bool


instance Monad m => WExhibit (Kleisli m) where
    event (WmPure f) =
        WmPure $ \(f -> (mx, w)) ->
            (Right (either (const Nothing) Just mx), event w)
    event (WmGen c) =
        WmGen $ \x' -> do
            (mx, w) <- c x'
            return (Right (either (const Nothing) Just mx), event w)

    exhibit (WmPure f) =
        WmPure $ \(f -> (mx, w)) ->
            (Right mx, exhibit w)
    exhibit (WmGen c) =
        WmGen $ \x' -> do
            (mx, w) <- c x'
            return (Right mx, exhibit w)

    gotEvent (WmPure f) =
        WmPure $ \(f -> (mx, w)) ->
            (Right (isRight mx), gotEvent w)
    gotEvent (WmGen c) =
        WmGen $ \x' -> do
            (mx, w) <- c x'
            return (Right (isRight mx), gotEvent w)


-- | 'True', if 'Right'.

isRight :: Either e a -> Bool
isRight (Right _) = True
isRight (Left _)  = False