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
WGen :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b
instance Monad m => Alternative (Wire m a) where
empty = zeroArrow
(<|>) = (<+>)
instance Monad m => Applicative (Wire m a) where
pure = arr . const
wf <*> wx = wf &&& wx >>> arr (uncurry ($))
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)
second (WGen f) = WGen $ \ws (x, y') -> liftM (fmap (x,) *** second) (f ws y')
second (WArr f) = WArr (second f)
(***) = wsidebyside 0
(&&&) = wboth 0
instance Monad m => ArrowChoice (Wire m) where
left w' = wl 0
where
wl t' =
WGen $ \ws@(wsDTime -> dt) mx' ->
let t = t' + dt in
t `seq`
case mx' of
Left x' -> liftM (fmap Left *** left) (toGen w' (ws { wsDTime = t }) x')
Right x -> return (pure (Right x), wl t)
right w' = wl 0
where
wl t' =
WGen $ \ws@(wsDTime -> dt) mx' ->
let t = t' + dt in
t `seq`
case mx' of
Right x' -> liftM (fmap Right *** right) (toGen w' (ws { wsDTime = t }) x')
Left x -> return (pure (Left x), wl t)
wf' +++ wg' = wl 0 0 wf' wg'
where
wl tf' tg' wf' wg' =
WGen $ \ws@(wsDTime -> dt) mx' ->
let tf = tf' + dt
tg = tg' + dt in
tf `seq` tg `seq`
case mx' of
Left x' -> do
(mx, wf) <- toGen wf' (ws { wsDTime = tf }) x'
return (fmap Left mx, wl 0 tg wf wg')
Right x' -> do
(mx, wg) <- toGen wg' (ws { wsDTime = tg }) x'
return (fmap Right mx, wl tf 0 wf' wg)
wf' ||| wg' = wl 0 0 wf' wg'
where
wl tf' tg' wf' wg' =
WGen $ \ws@(wsDTime -> dt) mx' ->
let tf = tf' + dt
tg = tg' + dt in
tf `seq` tg `seq`
case mx' of
Left x' -> do
(mx, wf) <- toGen wf' (ws { wsDTime = tf }) x'
return (mx, wl 0 tg wf wg')
Right x' -> do
(mx, wg) <- toGen wg' (ws { wsDTime = tg }) x'
return (mx, wl tf 0 wf' wg)
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
wf'@(WGen _) <+> wg' = wl 0 wf' wg'
where
wl t' wf' wg' =
WGen $ \ws@(wsDTime -> dt) x' -> do
let t = t' + dt
(mx, wf) <- toGen wf' ws x'
case mx of
Right _ -> t `seq` return (mx, wl t wf wg')
Left _ -> do
(mx2, wg) <- t `seq` toGen wg' (ws { wsDTime = t }) x'
return (mx2, wl 0 wf wg)
wa@(WArr _) <+> _ = wa
instance Monad m => ArrowZero (Wire m) where
zeroArrow = mkGen $ \_ _ -> return (Left (inhibitEx "Signal inhibited"), zeroArrow)
instance Monad m => Category (Wire m) where
id = WArr id
(.) = flip (wcompose 0)
instance Monad m => Functor (Wire m a) where
fmap f = (>>> arr 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)
wboth :: Monad m => Time -> Wire m a b -> Wire m a c -> Wire m a (b, c)
wboth t' (WGen f) wg'@(WGen g) =
WGen $ \ws@(wsDTime -> dt) x' -> do
let t = t' + dt
(mx1, wf) <- t `seq` f ws x'
case mx1 of
Left ex -> return (Left ex, wboth t wf wg')
Right _ -> do
(mx2, wg) <- g ws x'
return (liftA2 (,) mx1 mx2, wboth 0 wf wg)
wboth t' wf@(WArr f) (WGen g) =
WGen $ \ws x' -> do
(mx2, wg) <- g ws x'
return (fmap (f x',) mx2, wboth t' wf wg)
wboth t' (WGen f) wg@(WArr g) =
WGen $ \ws x' -> do
(mx1, wf) <- f ws x'
return (fmap (, g x') mx1, wboth t' wf wg)
wboth _ (WArr f) (WArr g) = WArr (f &&& g)
wcompose :: Monad m => Time -> Wire m a b -> Wire m b c -> Wire m a c
wcompose t' (WGen f) wg'@(WGen g) =
WGen $ \ws@(wsDTime -> dt) x'' -> do
let t = t' + dt
(mx', wf) <- t `seq` f ws x''
case mx' of
Left ex -> return (Left ex, wcompose t wf wg')
Right x' -> do
(mx, wg) <- g (ws { wsDTime = t }) x'
return (mx, wcompose 0 wf wg)
wcompose t' wf@(WArr f) (WGen g) =
WGen $ \ws x' -> do
(mx, wg) <- g ws (f x')
return (mx, wcompose t' wf wg)
wcompose t' (WGen f) wg@(WArr g) =
WGen $ \ws x' -> do
(mx, wf) <- f ws x'
return (fmap g mx, wcompose t' wf wg)
wcompose _ (WArr f) (WArr g) = WArr (g . f)
wsidebyside :: Monad m => Time -> Wire m a c -> Wire m b d -> Wire m (a, b) (c, d)
wsidebyside t' (WGen f) wg'@(WGen g) =
WGen $ \ws@(wsDTime -> dt) (x', y') -> do
let t = t' + dt
(mx, wf) <- t `seq` f ws x'
case mx of
Left ex -> return (Left ex, wsidebyside t wf wg')
Right _ -> do
(my, wg) <- g ws y'
return (liftA2 (,) mx my, wsidebyside 0 wf wg)
wsidebyside t' wf@(WArr f) (WGen g) =
WGen $ \ws (x', y') -> do
(my, wg) <- g ws y'
return (fmap (f x',) my, wsidebyside t' wf wg)
wsidebyside t' (WGen f) wg@(WArr g) =
WGen $ \ws (x', y') -> do
(mx, wf) <- f ws x'
return (fmap (, g y') mx, wsidebyside t' wf wg)
wsidebyside _ (WArr f) (WArr g) = WArr (f *** g)