module Control.Wire.Types
(
Wire(..),
WireM,
WireGen(..),
WirePure(..),
WireToGen(..),
mkFixM,
toGenM,
LastException,
inhibitException,
inhibitMsg,
mapInputM
)
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.Monad
import Control.Monad.Fix
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Writer.Class
import Control.Wire.Classes
import Data.Monoid
import Prelude hiding ((.), id)
type LastException = Last Ex.SomeException
data family Wire :: * -> (* -> * -> *) -> * -> * -> *
data instance Wire e (Kleisli m) a b where
WmGen :: (a -> m (Either e b, Wire e (Kleisli m) a b)) -> Wire e (Kleisli m) a b
WmPure :: (a -> (Either e b, Wire e (Kleisli m) a b)) -> Wire e (Kleisli m) a b
instance (Monad m, Monoid e) => Alternative (Wire e (Kleisli m) a) where
empty = zeroArrow
(<|>) = (<+>)
instance Monad m => Applicative (Wire e (Kleisli m) a) where
pure = mkPureFix . const . Right
WmPure ff <*> wx'@(WmPure fx) =
WmPure $ \x' ->
case ff x' of
(Left ex, wf) -> (Left ex, wf <*> wx')
(Right f, wf) ->
let (mx, wx) = fx x'
in (fmap f mx, wf <*> wx)
WmPure ff <*> wx'@(WmGen fx) =
WmGen $ \x' ->
case ff x' of
(Left ex, wf) -> return (Left ex, wf <*> wx')
(Right f, wf) -> liftM (fmap f *** (wf <*>)) (fx x')
WmGen ff <*> wx'@(WmPure fx) =
WmGen $ \x' -> do
(mf, wf) <- ff x'
return $
case mf of
Left ex -> (Left ex, wf <*> wx')
Right f ->
let (mx, wx) = fx x'
in (fmap f mx, wf <*> wx)
WmGen ff <*> wx'@(WmGen fx) =
WmGen $ \x' -> do
(mf, wf) <- ff x'
case mf of
Left ex -> return (Left ex, wf <*> wx')
Right f -> liftM (fmap f *** (wf <*>)) (fx x')
instance Monad m => Arrow (Wire e (Kleisli m)) where
arr f = mkPureFix $ Right . f
first (WmGen c) =
WmGen $ \(x', y) -> do
(mx, w) <- c x'
return (fmap (, y) mx, first w)
first (WmPure f) =
WmPure $ \(x', y) ->
let (mx, w) = f x'
in (fmap (, y) mx, first w)
second (WmGen c) =
WmGen $ \(x, y') -> do
(my, w) <- c y'
return (fmap (x,) my, second w)
second (WmPure f) =
WmPure $ \(x, y') ->
let (my, w) = f y'
in (fmap (x,) my, second w)
WmGen c1 &&& w2'@(WmGen c2) =
WmGen $ \x' -> do
(mx1, w1) <- c1 x'
case mx1 of
Left ex -> return (Left ex, w1 &&& w2')
Right x1 -> do
(mx2, w2) <- c2 x'
return (fmap (x1,) mx2, w1 &&& w2)
WmGen c1 &&& w2'@(WmPure g) =
WmGen $ \x' -> do
(mx1, w1) <- c1 x'
case mx1 of
Left ex -> return (Left ex, w1 &&& w2')
Right x1 ->
let (mx2, w2) = g x' in
return (fmap (x1,) mx2, w1 &&& w2)
WmPure f &&& w2'@(WmGen c2) =
WmGen $ \x' ->
let (mx1, w1) = f x' in
case mx1 of
Left ex -> return (Left ex, w1 &&& w2')
Right x1 -> do
(mx2, w2) <- c2 x'
return (fmap (x1,) mx2, w1 &&& w2)
WmPure f &&& w2'@(WmPure g) =
WmPure $ \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)
WmGen c1 *** w2'@(WmGen c2) =
WmGen $ \(x', y') -> do
(mx, w1) <- c1 x'
case mx of
Left ex -> return (Left ex, w1 *** w2')
Right x -> do
(my, w2) <- c2 y'
return (fmap (x,) my, w1 *** w2)
WmGen c1 *** w2'@(WmPure g) =
WmGen $ \(x', g -> (my, w2)) -> do
(mx, w1) <- c1 x'
return $
case mx of
Left ex -> (Left ex, w1 *** w2')
Right x -> (fmap (x,) my, w1 *** w2)
WmPure f *** w2'@(WmGen c2) =
WmGen $ \(f -> (mx, w1), y') -> do
case mx of
Left ex -> return (Left ex, w1 *** w2')
Right x -> do
(my, w2) <- c2 y'
return (fmap (x,) my, w1 *** w2)
WmPure f *** w2'@(WmPure g) =
WmPure $ \(f -> (mx, w1), g -> (my, w2)) ->
case mx of
Left ex -> (Left ex, w1 *** w2')
Right x -> (fmap (x,) my, w1 *** w2)
instance Monad m => ArrowChoice (Wire e (Kleisli m)) where
left w'@(WmPure f) =
WmPure $ \mx' ->
case mx' of
Left x' -> fmap Left *** left $ f x'
Right x' -> (Right (Right x'), left w')
left w'@(WmGen c) =
WmGen $ \mx' ->
case mx' of
Left x' -> liftM (fmap Left *** left) (c x')
Right x' -> return (Right (Right x'), left w')
right w'@(WmPure f) =
WmPure $ \mx' ->
case mx' of
Right x' -> fmap Right *** right $ f x'
Left x' -> (Right (Left x'), right w')
right w'@(WmGen c) =
WmGen $ \mx' ->
case mx' of
Right x' -> liftM (fmap Right *** right) (c x')
Left x' -> return (Right (Left x'), right w')
wl'@(WmPure f) +++ wr'@(WmPure g) =
WmPure $ \mx' ->
case mx' of
Left x' -> (fmap Left *** (+++ wr')) . f $ x'
Right x' -> (fmap Right *** (wl' +++)) . g $ x'
wl' +++ wr' =
WmGen $ \mx' ->
case mx' of
Left x' -> liftM (fmap Left *** (+++ wr')) (toGenM wl' x')
Right x' -> liftM (fmap Right *** (wl' +++)) (toGenM wr' x')
wl'@(WmPure f) ||| wr'@(WmPure g) =
WmPure $ \mx' ->
case mx' of
Left x' -> second (||| wr') . f $ x'
Right x' -> second (wl' |||) . g $ x'
wl' ||| wr' =
WmGen $ \mx' ->
case mx' of
Left x' -> liftM (second (||| wr')) (toGenM wl' x')
Right x' -> liftM (second (wl' |||)) (toGenM wr' x')
instance (MonadFix m, Monoid e) => ArrowCircuit (Wire e (Kleisli m)) where
delay x' = WmPure $ \x -> (Right x', delay x)
instance Monad m => ArrowError e (Wire e (Kleisli m)) where
raise = mkPureFix Left
handle (WmPure f) wh'@(WmPure fh) =
WmPure $ \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' =
WmGen $ \x' -> do
(mx, w) <- toGenM w' x'
case mx of
Left ex -> do
(mxh, wh) <- toGenM wh' (x', ex)
return (mxh, handle w wh)
Right _ -> return (mx, handle w wh')
newError (WmPure f) = WmPure $ (Right *** newError) . f
newError (WmGen c) = WmGen $ liftM (Right *** newError) . c
tryInUnless (WmPure f) ws'@(WmPure fs) we'@(WmPure fe) =
WmPure $ \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' =
WmGen $ \x' -> do
(mx, w) <- toGenM w' x'
case mx of
Left ex -> do
(mxe, we) <- toGenM we' (x', ex)
return (mxe, tryInUnless w ws' we)
Right x -> do
(mxs, ws) <- toGenM ws' (x', x)
return (mxs, tryInUnless w ws we')
instance Monad m => ArrowKleisli m (Wire e (Kleisli m)) where
arrM = mkFix (Right ^<< arrM)
instance (MonadFix m, Monoid e) => ArrowLoop (Wire e (Kleisli m)) where
loop w' =
WmGen $ \x' -> do
rec (mx, w) <- toGenM w' (x', d)
let d = either (error "Loop data dependency broken by inhibition") snd mx
return (fmap fst mx, loop w)
instance (Monad m, Monoid e) => ArrowPlus (Wire e (Kleisli m)) where
WmGen c1 <+> w2'@(WmGen c2) =
WmGen $ \x' -> do
(mx1, w1) <- c1 x'
case mx1 of
Right _ -> return (mx1, w1 <+> w2')
Left ex1 -> do
(mx2, w2) <- c2 x'
return (mapLeft (mappend ex1) mx2, w1 <+> w2)
WmGen c1 <+> w2'@(WmPure g) =
WmGen $ \x' -> do
(mx1, w1) <- c1 x'
case mx1 of
Right _ -> return (mx1, w1 <+> w2')
Left ex1 ->
let (mx2, w2) = g x' in
return (mapLeft (mappend ex1) mx2, w1 <+> w2)
WmPure f <+> w2'@(WmGen c2) =
WmGen $ \x' ->
let (mx1, w1) = f x' in
case mx1 of
Right _ -> return (mx1, w1 <+> w2')
Left ex1 -> do
(mx2, w2) <- c2 x'
return (mapLeft (mappend ex1) mx2, w1 <+> w2)
WmPure f <+> w2'@(WmPure g) =
WmPure $ \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)
instance MonadReader r m => ArrowReader r (Wire e (Kleisli m)) where
readState = mkFixM (const (liftM Right ask))
newReader (WmPure f) = WmPure (second newReader . f . fst)
newReader (WmGen c) =
WmGen $ \(x', env) ->
liftM (second newReader) (local (const env) (c x'))
instance MonadState s m => ArrowState s (Wire e (Kleisli m)) where
fetch = mkFixM (const (liftM Right get))
store = mkFixM (liftM Right . put)
instance Monad m => ArrowTransformer (Wire e) (Kleisli m) where
lift (Kleisli f) = mkFixM (liftM Right . f)
instance MonadWriter w m => ArrowWriter w (Wire e (Kleisli m)) where
write = mkFixM (liftM Right . tell)
newWriter (WmPure f) = WmPure ((fmap (, mempty) *** newWriter) . f)
newWriter (WmGen c) =
WmGen $ \x' -> do
((mx, w), log) <- listen (c x')
return (fmap (, log) mx, newWriter w)
instance (Monad m, Monoid e) => ArrowZero (Wire e (Kleisli m)) where
zeroArrow = mkPureFix (const $ Left mempty)
instance Monad m => Category (Wire e (Kleisli m)) where
id = WmPure $ \x -> (Right x, id)
w2'@(WmGen c2) . WmGen c1 =
WmGen $ \x'' -> do
(mx', w1) <- c1 x''
case mx' of
Left ex -> return (Left ex, w2' . w1)
Right x' -> do
(mx, w2) <- c2 x'
return (mx, w2 . w1)
w2'@(WmGen c2) . WmPure g =
WmGen $ \(g -> (mx', w1)) -> do
case mx' of
Left ex -> return (Left ex, w2' . w1)
Right x' -> do
(mx, w2) <- c2 x'
return (mx, w2 . w1)
w2'@(WmPure f) . WmGen c1 =
WmGen $ \x'' -> do
(mx', w1) <- c1 x''
return $
case mx' of
Left ex -> (Left ex, w2' . w1)
Right (f -> (mx, w2)) -> (mx, w2 . w1)
w2'@(WmPure f) . WmPure g =
WmPure $ \(g -> (mx', w1)) ->
case mx' of
Left ex -> (Left ex, w2' . w1)
Right (f -> (mx, w2)) -> (mx, w2 . w1)
instance Monad m => Functor (Wire e (Kleisli m) a) where
fmap f (WmGen g) = WmGen (liftM (fmap f *** fmap f) . g)
fmap f (WmPure g) = WmPure ((fmap f *** fmap f) . g)
class Arrow (>~) => WireGen (>~) where
mkGen :: (a >~ (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b
mkFix :: Arrow (>~) => (a >~ Either e b) -> Wire e (>~) a b
mkFix c = let w = mkGen (arr (, w) . c) in w
instance Monad m => WireGen (Kleisli m) where
mkGen (Kleisli c) = WmGen c
mkFix (Kleisli c) = let w = WmGen (liftM (, w) . c) in w
type WireM e m = Wire e (Kleisli m)
class Arrow (>~) => WirePure (>~) where
mkPure :: (a -> (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b
mkPureFix :: (a -> Either e b) -> Wire e (>~) a b
mkPureFix f = let w = mkPure (\x -> (f x, w)) in w
instance Monad m => WirePure (Kleisli m) where
mkPure = WmPure
class WireToGen (>~) where
toGen :: Wire e (>~) a b -> (a >~ (Either e b, Wire e (>~) a b))
instance Monad m => WireToGen (Kleisli m) where
toGen = Kleisli . toGenM
inhibitException :: Ex.Exception e => e -> LastException
inhibitException = Last . Just . Ex.toException
inhibitMsg :: String -> LastException
inhibitMsg = inhibitException . userError
mapInputM :: Monad m => (a' -> a) -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) a' b
mapInputM f (WmPure g) = WmPure (second (mapInputM f) . g . f)
mapInputM f (WmGen g) = WmGen (liftM (second (mapInputM f)) . g . f)
mapLeft :: (e' -> e) -> Either e' b -> Either e b
mapLeft f = either (Left . f) Right
mkFixM ::
Monad m
=> (a -> m (Either e b))
-> Wire e (Kleisli m) a b
mkFixM f = let w = WmGen (liftM (, w) . f) in w
toGenM ::
Monad m
=> Wire e (Kleisli m) a b
-> a
-> m (Either e b, Wire e (Kleisli m) a b)
toGenM (WmGen c) = c
toGenM (WmPure f) = (return . f)