module FRP.NetWire.Wire
(
Wire(..),
WireState(..),
Event,
InhibitException,
Output,
SF,
Time,
cleanupWireState,
inhibitEx,
initWireState,
mkGen,
toGen
)
where
import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Concurrent.STM
import Control.Exception (Exception(..), SomeException)
import Control.Monad.IO.Class
import Data.Functor.Identity
import Data.Typeable
import Prelude hiding ((.), id)
import System.Random.Mersenne
type Event = Maybe
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
(mf, wf) <- toGen wf' ws x'
(mx, wx) <- toGen wx' ws x'
return (mf <*> mx, wf <*> wx)
instance Monad m => Arrow (Wire m) where
arr = WArr
first (WGen f) =
WGen $ \ws (x', y) -> do
(mx, w) <- f ws x'
return (fmap (,y) mx, first w)
first (WArr f) = WArr (first f)
first (WConst c) = WArr (first (const c))
first WId = WId
second (WGen f) =
WGen $ \ws (x, y') -> do
(my, w) <- f ws y'
return (fmap (x,) my, second w)
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
(mx, wf) <- toGen wf' ws x'
(my, wg) <- toGen wg' ws y'
return (liftA2 (,) mx my, wf *** wg)
wf' &&& wg' =
WGen $ \ws x' -> do
(mx1, wf) <- toGen wf' ws x'
(mx2, wg) <- toGen wg' ws x'
return (liftA2 (,) mx1 mx2, wf &&& wg)
instance Monad m => ArrowChoice (Wire m) where
left w' = wl
where
wl =
WGen $ \ws mx' ->
case mx' of
Left x' -> do
(mx, w) <- toGen w' ws x'
return (fmap Left mx, left w)
Right x -> return (Right (Right x), wl)
right w' = wl
where
wl =
WGen $ \ws mx' ->
case mx' of
Right x' -> do
(mx, w) <- toGen w' ws x'
return (fmap Right mx, right w)
Left x -> return (Right (Left x), wl)
wf' +++ wg' =
WGen $ \ws mx' ->
case mx' of
Left x' -> do
(mx, wf) <- toGen wf' ws x'
return (fmap Left mx, wf +++ wg')
Right x' -> do
(mx, wg) <- toGen wg' ws x'
return (fmap Right mx, wf' +++ wg)
wf' ||| wg' =
WGen $ \ws mx' ->
case mx' of
Left x' -> do
(mx, wf) <- toGen wf' ws x'
return (mx, wf ||| wg')
Right x' -> do
(mx, wg) <- toGen wg' ws x'
return (mx, wf' ||| wg)
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
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)