module Control.Wire.Core
(
Wire(..),
stepWire,
mkConst,
mkEmpty,
mkGen,
mkGen_,
mkGenN,
mkId,
mkPure,
mkPure_,
mkPureN,
mkSF,
mkSF_,
mkSFN,
delay,
evalWith,
force,
forceNF,
(&&&!),
(***!),
lstrict,
mapWire
)
where
import qualified Data.Semigroup as Sg
import Control.Applicative
import Control.Arrow
import Control.Category
import Control.DeepSeq hiding (force)
import Control.Monad
import Control.Monad.Fix
import Control.Parallel.Strategies
import Data.Monoid
import Data.String
import Prelude hiding ((.), id)
data Wire s e m a b where
WArr :: (Either e a -> Either e b) -> Wire s e m a b
WConst :: Either e b -> Wire s e m a b
WGen :: (s -> Either e a -> m (Either e b, Wire s e m a b)) -> Wire s e m a b
WId :: Wire s e m a a
WPure :: (s -> Either e a -> (Either e b, Wire s e m a b)) -> Wire s e m a b
instance (Monad m, Monoid e) => Alternative (Wire s e m a) where
empty = WConst (Left mempty)
w1' <|> w2' =
WGen $ \ds mx' ->
liftM2 (\(mx1, w1) (mx2, w2) -> lstrict (choose mx1 mx2, w1 <|> w2))
(stepWire w1' ds mx')
(stepWire w2' ds mx')
where
choose mx1@(Right _) _ = mx1
choose _ mx2@(Right _) = mx2
choose (Left ex1) (Left ex2) = Left (ex1 <> ex2)
instance (Monad m) => Applicative (Wire s e m a) where
pure = WConst . Right
wf' <*> wx' =
WGen $ \ds mx' ->
liftM2 (\(mf, wf) (mx, wx) -> lstrict (mf <*> mx, wf <*> wx))
(stepWire wf' ds mx')
(stepWire wx' ds mx')
instance (Monad m) => Arrow (Wire s e m) where
arr f = WArr (fmap f)
first w' =
WGen $ \ds mxy' ->
liftM (\(mx, w) -> lstrict (liftA2 (,) mx (fmap snd mxy'), first w))
(stepWire w' ds (fmap fst mxy'))
instance (Monad m, Monoid e) => ArrowChoice (Wire s e m) where
left w' =
WGen $ \ds mmx' ->
liftM (fmap Left ***! left) .
stepWire w' ds $
case mmx' of
Right (Left x) -> Right x
Right (Right _) -> Left mempty
Left ex -> Left ex
right w' =
WGen $ \ds mmx' ->
liftM (fmap Right ***! right) .
stepWire w' ds $
case mmx' of
Right (Right x) -> Right x
Right (Left _) -> Left mempty
Left ex -> Left ex
wl' +++ wr' =
WGen $ \ds mmx' ->
case mmx' of
Right (Left x) -> do
liftM2 (\(mx, wl) (_, wr) -> lstrict (fmap Left mx, wl +++ wr))
(stepWire wl' ds (Right x))
(stepWire wr' ds (Left mempty))
Right (Right x) -> do
liftM2 (\(_, wl) (mx, wr) -> lstrict (fmap Right mx, wl +++ wr))
(stepWire wl' ds (Left mempty))
(stepWire wr' ds (Right x))
Left ex ->
liftM2 (\(_, wl) (_, wr) -> lstrict (Left ex, wl +++ wr))
(stepWire wl' ds (Left ex))
(stepWire wr' ds (Left ex))
wl' ||| wr' =
WGen $ \ds mmx' ->
case mmx' of
Right (Left x) -> do
liftM2 (\(mx, wl) (_, wr) -> lstrict (mx, wl ||| wr))
(stepWire wl' ds (Right x))
(stepWire wr' ds (Left mempty))
Right (Right x) -> do
liftM2 (\(_, wl) (mx, wr) -> lstrict (mx, wl ||| wr))
(stepWire wl' ds (Left mempty))
(stepWire wr' ds (Right x))
Left ex ->
liftM2 (\(_, wl) (_, wr) -> lstrict (Left ex, wl ||| wr))
(stepWire wl' ds (Left ex))
(stepWire wr' ds (Left ex))
instance (MonadFix m) => ArrowLoop (Wire s e m) where
loop w' =
WGen $ \ds mx' ->
liftM (fmap fst ***! loop) .
mfix $ \ ~(mx, _) ->
let d | Right (_, d) <- mx = d
| otherwise = error "Feedback broken by inhibition"
in stepWire w' ds (fmap (, d) mx')
instance (Monad m, Monoid e) => ArrowPlus (Wire s e m) where
(<+>) = (<|>)
instance (Monad m, Monoid e) => ArrowZero (Wire s e m) where
zeroArrow = empty
instance (Monad m) => Category (Wire s e m) where
id = WId
w2' . w1' =
WGen $ \ds mx0 -> do
(mx1, w1) <- stepWire w1' ds mx0
(mx2, w2) <- stepWire w2' ds mx1
mx2 `seq` return (mx2, w2 . w1)
instance (Monad m, Floating b) => Floating (Wire s e m a b) where
(**) = liftA2 (**)
acos = fmap acos
acosh = fmap acosh
asin = fmap asin
asinh = fmap asinh
atan = fmap atan
atanh = fmap atanh
cos = fmap cos
cosh = fmap cosh
exp = fmap exp
log = fmap log
logBase = liftA2 logBase
pi = pure pi
sin = fmap sin
sinh = fmap sinh
sqrt = fmap sqrt
tan = fmap tan
tanh = fmap tanh
instance (Monad m, Fractional b) => Fractional (Wire s e m a b) where
(/) = liftA2 (/)
recip = fmap recip
fromRational = pure . fromRational
instance (Monad m) => Functor (Wire s e m a) where
fmap f (WArr g) = WArr (fmap f . g)
fmap f (WConst mx) = WConst (fmap f mx)
fmap f (WGen g) = WGen (\ds -> liftM (fmap f ***! fmap f) . g ds)
fmap f WId = WArr (fmap f)
fmap f (WPure g) = WPure (\ds -> (fmap f ***! fmap f) . g ds)
instance (Monad m, IsString b) => IsString (Wire s e m a b) where
fromString = pure . fromString
instance (Monad m, Monoid b) => Monoid (Wire s e m a b) where
mempty = pure mempty
mappend = liftA2 mappend
instance (Monad m, Num b) => Num (Wire s e m a b) where
(+) = liftA2 (+)
() = liftA2 ()
(*) = liftA2 (*)
abs = fmap abs
negate = fmap negate
signum = fmap signum
fromInteger = pure . fromInteger
instance (Monad m, Sg.Semigroup b) => Sg.Semigroup (Wire s e m a b) where
(<>) = liftA2 (Sg.<>)
(&&&!) :: (a -> b) -> (a -> c) -> (a -> (b, c))
(&&&!) f g x' =
let (x, y) = (f x', g x')
in x `seq` (x, y)
(***!) :: (a -> c) -> (b -> d) -> ((a, b) -> (c, d))
(***!) f g (x', y') =
let (x, y) = (f x', g y')
in x `seq` (x, y)
delay :: a -> Wire s e m a a
delay x' = mkSFN $ \x -> (x', delay x)
evalWith :: Strategy a -> Wire s e m a a
evalWith s =
WArr $ \mx ->
case mx of
Right x -> (x `using` s) `seq` mx
Left _ -> mx
force :: Wire s e m a a
force =
WArr $ \mx ->
case mx of
Right x -> x `seq` mx
Left ex -> ex `seq` mx
forceNF :: (NFData a) => Wire s e m a a
forceNF =
WArr $ \mx ->
case mx of
Right x -> x `deepseq` mx
Left _ -> mx
lstrict :: (a, b) -> (a, b)
lstrict (x, y) = x `seq` (x, y)
mapWire ::
(Monad m', Monad m)
=> (forall a. m' a -> m a)
-> Wire s e m' a b
-> Wire s e m a b
mapWire _ (WArr g) = WArr g
mapWire _ (WConst mx) = WConst mx
mapWire f (WGen g) = WGen (\ds -> liftM (lstrict . second (mapWire f)) . f . g ds)
mapWire _ WId = WId
mapWire f (WPure g) = WPure (\ds -> lstrict . second (mapWire f) . g ds)
mkConst :: Either e b -> Wire s e m a b
mkConst = WConst
mkEmpty :: (Monoid e) => Wire s e m a b
mkEmpty = mkConst (Left mempty)
mkGen :: (Monad m, Monoid s) => (s -> a -> m (Either e b, Wire s e m a b)) -> Wire s e m a b
mkGen f = loop mempty
where
loop s' =
WGen $ \ds mx ->
let s = s' <> ds in
s `seq`
case mx of
Left ex -> return (Left ex, loop s)
Right x' -> liftM lstrict (f s x')
mkGen_ :: (Monad m) => (a -> m (Either e b)) -> Wire s e m a b
mkGen_ f = loop
where
loop =
WGen $ \_ mx ->
case mx of
Left ex -> return (Left ex, loop)
Right x -> liftM (lstrict . (, loop)) (f x)
mkGenN :: (Monad m) => (a -> m (Either e b, Wire s e m a b)) -> Wire s e m a b
mkGenN f = loop
where
loop =
WGen $ \_ mx ->
case mx of
Left ex -> return (Left ex, loop)
Right x' -> liftM lstrict (f x')
mkId :: Wire s e m a a
mkId = WId
mkPure :: (Monoid s) => (s -> a -> (Either e b, Wire s e m a b)) -> Wire s e m a b
mkPure f = loop mempty
where
loop s' =
WPure $ \ds mx ->
let s = s' <> ds in
s `seq`
case mx of
Left ex -> (Left ex, loop s)
Right x' -> lstrict (f s x')
mkPure_ :: (a -> Either e b) -> Wire s e m a b
mkPure_ f = WArr $ (>>= f)
mkPureN :: (a -> (Either e b, Wire s e m a b)) -> Wire s e m a b
mkPureN f = loop
where
loop =
WPure $ \_ mx ->
case mx of
Left ex -> (Left ex, loop)
Right x' -> lstrict (f x')
mkSF :: (Monoid s) => (s -> a -> (b, Wire s e m a b)) -> Wire s e m a b
mkSF f = mkPure (\ds -> lstrict . first (Right) . f ds)
mkSF_ :: (a -> b) -> Wire s e m a b
mkSF_ f = WArr (fmap f)
mkSFN :: (a -> (b, Wire s e m a b)) -> Wire s e m a b
mkSFN f = mkPureN (lstrict . first (Right) . f)
stepWire :: (Monad m) => Wire s e m a b -> s -> Either e a -> m (Either e b, Wire s e m a b)
stepWire w@(WArr f) _ mx' = return (f mx', w)
stepWire w@(WConst mx) _ mx' = return (mx' *> mx, w)
stepWire (WGen f) ds mx' = f ds mx'
stepWire w@WId _ mx' = return (mx', w)
stepWire (WPure f) ds mx' = return (f ds mx')