Types.hs

-- |
-- Module:     Control.Wire.Types
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Types used in the netwire library.

module Control.Wire.Types
    ( -- * The wire
      Wire(..),

      -- * Smart construction
      mkFix,
      mkGen,
      mkPure,
      mkPureFix,

      -- * Destruction
      toGen
    )
    where

import qualified Control.Exception as Ex
import Control.Applicative
import Control.Arrow
import Control.Arrow.Operations
import Control.Arrow.Transformer
import Control.Category
import Control.Wire.Classes
import Data.Monoid
import Prelude hiding ((.), id)


-- | Signal networks.

data Wire e (>~) a b where
    WGen  :: !(a >~ (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b
    WPure :: !(a -> (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b


-- | Wire side channels.

instance ArrowChoice (>~) => Arrow (Wire e (>~)) where
    arr f = mkPureFix $ Right . f

    first (WGen c) =
        WGen $ proc (x', y) -> do
            (mx, w) <- c -< x'
            returnA -< (fmap (, y) mx, first w)
    first (WPure f) =
        WPure $ \(x', y) ->
            let (mx, w) = f x'
            in (fmap (, y) mx, first w)

    second (WGen c) =
        WGen $ proc (x, y') -> do
            (my, w) <- c -< y'
            returnA -< (fmap (x,) my, second w)
    second (WPure f) =
        WPure $ \(x, y') ->
            let (my, w) = f y'
            in (fmap (x,) my, second w)

    -- (&&&) combinator.
    WGen c1 &&& w2'@(WGen c2) =
        WGen $ proc x' -> do
            (mx1, w1) <- c1 -< x'
            case mx1 of
              Left ex  -> returnA -< (Left ex, w1 &&& w2')
              Right x1 -> do
                  (mx2, w2) <- c2 -< x'
                  returnA -< (fmap (x1,) mx2, w1 &&& w2)

    WGen c1 &&& w2'@(WPure g) =
        WGen $ proc x' -> do
            (mx1, w1) <- c1 -< x'
            case mx1 of
              Left ex  -> returnA -< (Left ex, w1 &&& w2')
              Right x1 ->
                  let (mx2, w2) = g x' in
                  returnA -< (fmap (x1,) mx2, w1 &&& w2)

    WPure f &&& w2'@(WGen c2) =
        WGen $ proc x' ->
            let (mx1, w1) = f x' in
            case mx1 of
              Left ex  -> returnA -< (Left ex, w1 &&& w2')
              Right x1 -> do
                  (mx2, w2) <- c2 -< x'
                  returnA -< (fmap (x1,) mx2, w1 &&& w2)

    WPure f &&& w2'@(WPure g) =
        WPure $ \x' ->
            let (mx1, w1) = f x'
                (mx2, w2) = g x' in
            case mx1 of
              Left ex  -> (Left ex, w1 &&& w2')
              Right x1 -> (fmap (x1,) mx2, w1 &&& w2)

    -- (***) combinator.
    WGen c1 *** w2'@(WGen c2) =
        WGen $ proc (x', y') -> do
            (mx, w1) <- c1 -< x'
            case mx of
              Left ex -> returnA -< (Left ex, w1 *** w2')
              Right x -> do
                  (my, w2) <- c2 -< y'
                  returnA -< (fmap (x,) my, w1 *** w2)

    WGen c1 *** w2'@(WPure g) =
        WGen $ proc (x', g -> (my, w2)) -> do
            (mx, w1) <- c1 -< x'
            case mx of
              Left ex -> returnA -< (Left ex, w1 *** w2')
              Right x -> returnA -< (fmap (x,) my, w1 *** w2)

    WPure f *** w2'@(WGen c2) =
        WGen $ proc (f -> (mx, w1), y') -> do
            case mx of
              Left ex -> returnA -< (Left ex, w1 *** w2')
              Right x -> do
                  (my, w2) <- c2 -< y'
                  returnA -< (fmap (x,) my, w1 *** w2)

    WPure f *** w2'@(WPure g) =
        WPure $ \(f -> (mx, w1), g -> (my, w2)) ->
            case mx of
              Left ex -> (Left ex, w1 *** w2')
              Right x -> (fmap (x,) my, w1 *** w2)


-- | Support for choice (signal redirection).

instance ArrowChoice (>~) => ArrowChoice (Wire e (>~)) where
    left w'@(WPure f) =
        WPure $ \mx' ->
            case mx' of
              Left x'  -> fmap Left *** left $ f x'
              Right x' -> (Right (Right x'), left w')

    left w'@(WGen c) =
        WGen $ proc mx' ->
            case mx' of
              Left x'  -> (fmap Left *** left) ^<< c -< x'
              Right x' -> returnA -< (Right (Right x'), left w')

    right w'@(WPure f) =
        WPure $ \mx' ->
            case mx' of
              Right x' -> fmap Right *** right $ f x'
              Left x'  -> (Right (Left x'), right w')

    right w'@(WGen c) =
        WGen $ proc mx' ->
            case mx' of
              Right x' -> (fmap Right *** right) ^<< c -< x'
              Left x'  -> returnA -< (Right (Left x'), right w')

    wl'@(WPure f) +++ wr'@(WPure g) =
        WPure $ \mx' ->
            case mx' of
              Left x'  -> (fmap Left  *** (+++ wr')) . f $ x'
              Right x' -> (fmap Right *** (wl' +++)) . g $ x'

    wl' +++ wr' =
        WGen $ proc mx' ->
            case mx' of
              Left x'  -> arr (fmap Left  *** (+++ wr')) . toGen wl' -< x'
              Right x' -> arr (fmap Right *** (wl' +++)) . toGen wr' -< x'

    wl'@(WPure f) ||| wr'@(WPure g) =
        WPure $ \mx' ->
            case mx' of
              Left x'  -> second (||| wr') . f $ x'
              Right x' -> second (wl' |||) . g $ x'

    wl' ||| wr' =
        WGen $ proc mx' ->
            case mx' of
              Left x'  -> arr (second (||| wr')) . toGen wl' -< x'
              Right x' -> arr (second (wl' |||)) . toGen wr' -< x'


-- | Support for one-instant delays.

instance (ArrowChoice (>~), ArrowLoop (>~)) => ArrowCircuit (Wire e (>~)) where
    delay x' = mkPure $ \x -> (Right x', delay x)


-- | Inhibition handling interface.  See also the
-- "Control.Wire.Trans.Exhibit" and "Control.Wire.Prefab.Event" modules.

instance ArrowChoice (>~) => ArrowError e (Wire e (>~)) where
    raise = mkPureFix Left

    handle (WPure f) wh'@(WPure fh) =
        WPure $ \x' ->
            let (mx, w) = f x' in
            case mx of
              Left ex ->
                  let (mxh, wh) = fh (x', ex)
                  in (mxh, handle w wh)
              Right _ -> (mx, handle w wh')

    handle w' wh' =
        WGen $ proc x' -> do
            (mx, w) <- toGen w' -< x'
            case mx of
              Left ex -> do
                  (mxh, wh) <- toGen wh' -< (x', ex)
                  returnA -< (mxh, handle w wh)
              Right _ -> returnA -< (mx, handle w wh')

    newError (WPure f) = WPure $ (Right *** newError) . f
    newError (WGen c) = WGen $ arr (Right *** newError) . c

    tryInUnless (WPure f) ws'@(WPure fs) we'@(WPure fe) =
        WPure $ \x' ->
            let (mx, w) = f x' in
            case mx of
              Left ex ->
                  let (mxe, we) = fe (x', ex)
                  in (mxe, tryInUnless w ws' we)
              Right x ->
                  let (mxs, ws) = fs (x', x)
                  in (mxs, tryInUnless w ws we')

    tryInUnless w' ws' we' =
        WGen $ proc x' -> do
            (mx, w) <- toGen w' -< x'
            case mx of
              Left ex -> do
                  (mxe, we) <- toGen we' -< (x', ex)
                  returnA -< (mxe, tryInUnless w ws' we)
              Right x -> do
                  (mxs, ws) <- toGen ws' -< (x', x)
                  returnA -< (mxs, tryInUnless w ws we')


-- | When the target arrow is an 'ArrowIO' (e.g. a Kleisli arrow over
-- IO), then the wire arrow is also an @ArrowIO@.

instance (Applicative f, ArrowChoice (>~), ArrowIO (>~)) =>
         ArrowIO (Wire (f Ex.SomeException) (>~)) where
    arrIO = mkFix $ arr (mapLeft pure) <<< arrIO <<< arr Ex.try


-- | Value recursion in the wire arrows.  **NOTE**: Wires with feedback
-- must *never* inhibit.  There is an inherent, fundamental problem with
-- handling the inhibition case, which you will observe as a fatal
-- pattern match error.

instance (ArrowChoice (>~), ArrowLoop (>~)) => ArrowLoop (Wire e (>~)) where
    loop w' =
        WGen $ proc x' -> do
            rec (Right (x, d), w) <- toGen w' -< (x', d)
            returnA -< (Right x, loop w)


-- | Combining possibly inhibiting wires.

instance (ArrowChoice (>~), Monoid e) => ArrowPlus (Wire e (>~)) where
    WGen c1 <+> w2'@(WGen c2) =
        WGen $ proc x' -> do
            (mx1, w1) <- c1 -< x'
            case mx1 of
              Right _ -> returnA -< (mx1, w1 <+> w2')
              Left ex1 -> do
                  (mx2, w2) <- c2 -< x'
                  returnA -< (mapLeft (mappend ex1) mx2, w1 <+> w2)

    WGen c1 <+> w2'@(WPure g) =
        WGen $ proc x' -> do
            (mx1, w1) <- c1 -< x'
            case mx1 of
              Right _ -> returnA -< (mx1, w1 <+> w2')
              Left ex1 ->
                  let (mx2, w2) = g x' in
                  returnA -< (mapLeft (mappend ex1) mx2, w1 <+> w2)

    WPure f <+> w2'@(WGen c2) =
        WGen $ proc x' ->
            let (mx1, w1) = f x' in
            case mx1 of
              Right _ -> returnA -< (mx1, w1 <+> w2')
              Left ex1 -> do
                  (mx2, w2) <- c2 -< x'
                  returnA -< (mapLeft (mappend ex1) mx2, w1 <+> w2)

    WPure f <+> w2'@(WPure g) =
        WPure $ \x' ->
            let (mx1, w1) = f x'
                (mx2, w2) = g x' in
            case mx1 of
              Right _  -> (mx1, w1 <+> w2')
              Left ex1 -> (mapLeft (mappend ex1) mx2, w1 <+> w2)


-- | If the underlying arrow is a reader arrow, then the wire arrow is
-- also a reader arrow.

instance (ArrowChoice (>~), ArrowReader r (>~)) => ArrowReader r (Wire e (>~)) where
    readState = lift readState

    newReader (WPure f) = WPure (second newReader . f . fst)
    newReader (WGen c)  = WGen $ arr (second newReader) . newReader c


-- | If the underlying arrow is a state arrow, then the wire arrow is
-- also a state arrow.

instance (ArrowChoice (>~), ArrowState s (>~)) => ArrowState s (Wire e (>~)) where
    fetch = lift fetch
    store = lift store


-- | Wire arrows are arrow transformers.

instance ArrowChoice (>~) => ArrowTransformer (Wire e) (>~) where
    lift c = mkFix $ Right ^<< c


-- | If the underlying arrow is a writer arrow, then the wire arrow is
-- also a writer arrow.

instance (ArrowChoice (>~), ArrowWriter w (>~)) => ArrowWriter w (Wire e (>~)) where
    write = lift write

    newWriter (WPure f) = WPure ((fmap (, mempty) *** newWriter) . f)
    newWriter (WGen c) =
        WGen $ arr (\((mx, w), log) ->
                        (fmap (, log) mx, newWriter w)) .
               newWriter c


-- | The always inhibiting wire.  The @zeroArrow@ is equivalent to
-- "Control.Wire.Prefab.Event.never".

instance (ArrowChoice (>~), Monoid e) => ArrowZero (Wire e (>~)) where
    zeroArrow = mkPureFix (const $ Left mempty)


-- | Sequencing of wires.

instance ArrowChoice (>~) => Category (Wire e (>~)) where
    id = arr id

    w2'@(WGen c2) . WGen c1 =
        WGen $ proc x'' -> do
            (mx', w1) <- c1 -< x''
            case mx' of
              Left ex  -> returnA -< (Left ex, w2' . w1)
              Right x' -> do
                  (mx, w2) <- c2 -< x'
                  returnA -< (mx, w2 . w1)

    w2'@(WGen c2) . WPure g =
        WGen $ proc (g -> (mx', w1)) -> do
            case mx' of
              Left ex  -> returnA -< (Left ex, w2' . w1)
              Right x' -> do
                  (mx, w2) <- c2 -< x'
                  returnA -< (mx, w2 . w1)

    w2'@(WPure f) . WGen c1 =
        WGen $ proc x'' -> do
            (mx', w1) <- c1 -< x''
            case mx' of
              Left ex               -> returnA -< (Left ex, w2' . w1)
              Right (f -> (mx, w2)) -> returnA -< (mx, w2 . w1)

    w2'@(WPure f) . WPure g =
        WPure $ \(g -> (mx', w1)) ->
            case mx' of
              Left ex               -> (Left ex, w2' . w1)
              Right (f -> (mx, w2)) -> (mx, w2 . w1)


-- | Maps over the left side of an 'Either' value.

mapLeft :: (e' -> e) -> Either e' a -> Either e a
mapLeft f (Left x)  = Left (f x)
mapLeft _ (Right x) = Right x


-- | Create a wire from the given stateless transformation computation.

mkFix :: Arrow (>~) => (a >~ Either e b) -> Wire e (>~) a b
mkFix c = let w = WGen (arr (, w) . c) in w


-- | Create a wire from the given transformation computation.

mkGen :: (a >~ (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b
mkGen = WGen


-- | Create a pure wire from the given transformation function.

mkPure :: (a -> (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b
mkPure = WPure


-- | Create a pure wire from the given transformation function.

mkPureFix :: (a -> Either e b) -> Wire e (>~) a b
mkPureFix f = let w = WPure ((, w) . f) in w


-- | Convert the given wire to a generic arrow computation.

toGen :: Arrow (>~) => Wire e (>~) a b -> (a >~ (Either e b, Wire e (>~) a b))
toGen (WGen c)  = c
toGen (WPure f) = arr f