module Control.Wire.Types
(
Wire(..),
mkFix,
mkGen,
mkPure,
mkPureFix,
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)
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
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)
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)
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)
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'
instance (ArrowChoice (>~), ArrowLoop (>~)) => ArrowCircuit (Wire e (>~)) where
delay x' = mkPure $ \x -> (Right x', delay x)
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')
instance (Applicative f, ArrowChoice (>~), ArrowIO (>~)) =>
ArrowIO (Wire (f Ex.SomeException) (>~)) where
arrIO = mkFix $ arr (mapLeft pure) <<< arrIO <<< arr Ex.try
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)
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)
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
instance (ArrowChoice (>~), ArrowState s (>~)) => ArrowState s (Wire e (>~)) where
fetch = lift fetch
store = lift store
instance ArrowChoice (>~) => ArrowTransformer (Wire e) (>~) where
lift c = mkFix $ Right ^<< c
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
instance (ArrowChoice (>~), Monoid e) => ArrowZero (Wire e (>~)) where
zeroArrow = mkPureFix (const $ Left mempty)
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)
mapLeft :: (e' -> e) -> Either e' a -> Either e a
mapLeft f (Left x) = Left (f x)
mapLeft _ (Right x) = Right x
mkFix :: Arrow (>~) => (a >~ Either e b) -> Wire e (>~) a b
mkFix c = let w = WGen (arr (, w) . c) in w
mkGen :: (a >~ (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b
mkGen = WGen
mkPure :: (a -> (Either e b, Wire e (>~) a b)) -> Wire e (>~) a b
mkPure = WPure
mkPureFix :: (a -> Either e b) -> Wire e (>~) a b
mkPureFix f = let w = WPure ((, w) . f) in w
toGen :: Arrow (>~) => Wire e (>~) a b -> (a >~ (Either e b, Wire e (>~) a b))
toGen (WGen c) = c
toGen (WPure f) = arr f