module FRP.NetWire.Wire
(
Wire(..),
WireState(..),
InhibitException(..),
Output,
SF,
Time,
cleanupWireState,
inhibitEx,
initWireState,
mkGen,
noEvent,
toGen
)
where
import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Concurrent.STM
import Control.Exception (Exception(..), SomeException)
import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import Data.Functor.Identity
import Data.Typeable
import Prelude hiding ((.), id)
import System.Random.Mersenne
data InhibitException =
InhibitException String
deriving (Read, Show, Typeable)
instance Exception InhibitException
type Output = Either SomeException
type SF = Wire Identity
type Time = Double
data Wire :: (* -> *) -> * -> * -> * where
WArr :: (a -> b) -> Wire m a b
WConst :: b -> Wire m a b
WGen :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b
WId :: Wire m a a
instance Monad m => Alternative (Wire m a) where
empty = zeroArrow
(<|>) = (<+>)
instance Monad m => Applicative (Wire m a) where
pure = WConst
wf' <*> wx' =
WGen $ \ws x' -> do
(cf, wf) <- toGen wf' ws x'
(cx, wx) <- toGen wx' ws x'
return (cf <*> cx, wf <*> wx)
instance Monad m => Arrow (Wire m) where
arr = WArr
first (WGen f) = WGen $ \ws (x', y) -> liftM (fmap (, y) *** first) (f ws x')
first (WArr f) = WArr (first f)
first (WConst c) = WArr (first (const c))
first WId = WId
second (WGen f) = WGen $ \ws (x, y') -> liftM (fmap (x,) *** second) (f ws y')
second (WArr f) = WArr (second f)
second (WConst c) = WArr (second (const c))
second WId = WId
wf *** WId = first wf
WId *** wg = second wg
wf' *** wg' =
WGen $ \ws (x', y') -> do
(cx, wf) <- toGen wf' ws x'
(cy, wg) <- toGen wg' ws y'
return (liftA2 (,) cx cy, wf *** wg)
wf' &&& wg' =
WGen $ \ws x' -> do
(cx1, wf) <- toGen wf' ws x'
(cx2, wg) <- toGen wg' ws x'
return (liftA2 (,) cx1 cx2, wf &&& wg)
instance Monad m => ArrowChoice (Wire m) where
left w' = wl
where
wl =
WGen $ \ws mx' ->
case mx' of
Left x' -> liftM (fmap Left *** left) (toGen w' ws x')
Right x -> return (pure (Right x), wl)
right w' = wl
where
wl =
WGen $ \ws mx' ->
case mx' of
Right x' -> liftM (fmap Right *** right) (toGen w' ws x')
Left x -> return (pure (Left x), wl)
wf' +++ wg' =
WGen $ \ws mx' ->
case mx' of
Left x' -> liftM (fmap Left *** (+++ wg')) (toGen wf' ws x')
Right x' -> liftM (fmap Right *** (wf' +++)) (toGen wg' ws x')
wf' ||| wg' =
WGen $ \ws mx' ->
case mx' of
Left x' -> liftM (second (||| wg')) (toGen wf' ws x')
Right x' -> liftM (second (wf' |||)) (toGen wg' ws x')
instance MonadFix m => ArrowLoop (Wire m) where
loop w' =
WGen $ \ws x' -> do
rec (Right (x, d), w) <- toGen w' ws (x', d)
return (Right x, loop w)
instance Monad m => ArrowPlus (Wire m) where
WGen f <+> wg =
WGen $ \ws x' -> do
(mx, w1) <- f ws x'
case mx of
Right _ -> return (mx, w1 <+> wg)
Left _ -> do
(mx2, w2) <- toGen wg ws x'
return (mx2, w1 <+> w2)
wa@(WArr _) <+> _ = wa
wc@(WConst _) <+> _ = wc
WId <+> _ = WId
instance Monad m => ArrowZero (Wire m) where
zeroArrow = mkGen $ \_ _ -> return (Left (inhibitEx "Signal inhibited"), zeroArrow)
instance Monad m => Category (Wire m) where
id = WId
wf@(WGen f) . WGen g =
WGen $ \ws x'' -> do
(mx', w1) <- g ws x''
case mx' of
Left ex -> return (Left ex, wf . w1)
Right x' -> do
(mx, w2) <- f ws x'
return (mx, w2 . w1)
wf@(WArr f) . WGen g =
WGen $ \ws x' -> do
(mx, w) <- g ws x'
return (fmap f mx, wf . w)
wc@(WConst c) . WGen g =
WGen $ \ws x' -> do
(mx, w) <- g ws x'
return (fmap (const c) mx, wc . w)
WGen f . wg@(WArr g) =
WGen $ \ws x' -> do
(mx, w) <- f ws (g x')
return (mx, w . wg)
WGen f . wc@(WConst c) =
WGen $ \ws _ -> do
(mx, w) <- f ws c
return (mx, w . wc)
WArr f . WArr g = WArr (f . g)
WArr f . WConst c = WArr (const (f c))
WConst c . WArr _ = WConst c
WConst c . WConst _ = WConst c
WId . w2 = w2
w1 . WId = w1
instance Monad m => Functor (Wire m a) where
fmap f (WGen w') =
WGen $ \ws x' -> do
(x, w) <- w' ws x'
return (fmap f x, fmap f w)
fmap f (WArr g) = WArr (f . g)
fmap f (WConst c) = WConst (f c)
fmap f WId = WArr f
data WireState :: (* -> *) -> * where
ImpureState ::
MonadIO m =>
{ wsDTime :: Double,
wsRndGen :: MTGen,
wsReqVar :: TVar Int
} -> WireState m
PureState :: { wsDTime :: Double } -> WireState m
cleanupWireState :: WireState m -> IO ()
cleanupWireState _ = return ()
inhibitEx :: String -> SomeException
inhibitEx = toException . InhibitException
initWireState :: MonadIO m => IO (WireState m)
initWireState =
ImpureState
<$> pure 0
<*> getStdGen
<*> newTVarIO 0
mkGen :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b
mkGen = WGen
noEvent :: SomeException
noEvent = inhibitEx "No event"
toGen :: Monad m => Wire m a b -> WireState m -> a -> m (Output b, Wire m a b)
toGen (WGen f) ws x = f ws x
toGen wf@(WArr f) _ x = return (Right (f x), wf)
toGen wc@(WConst c) _ _ = return (Right c, wc)
toGen wi@WId _ x = return (Right x, wi)