module Reactive.Banana.Internal.InputOutput (
Channel, InputChannel, InputValue,
newInputChannel, getChannel,
fromValue, toValue,
Automaton(..), fromStateful, unfoldAutomaton,
) where
import Control.Applicative
import Control.Exception (evaluate)
import Data.Unique.Really
import qualified Data.Vault.Lazy as Vault
type Channel = Unique
type Key = Vault.Key
type Value = Vault.Vault
data InputChannel a = InputChannel { getChannelC :: Channel, getKey :: Key a }
data InputValue = InputValue { getChannelV :: Channel, getValue :: Value }
newInputChannel :: IO (InputChannel a)
newInputChannel = InputChannel <$> newUnique <*> Vault.newKey
fromValue :: InputChannel a -> InputValue -> Maybe a
fromValue i v = Vault.lookup (getKey i) (getValue v)
toValue :: InputChannel a -> a -> InputValue
toValue i a = InputValue (getChannelC i) $ Vault.insert (getKey i) a Vault.empty
class HasChannel a where
getChannel :: a -> Channel
instance HasChannel (InputChannel a) where getChannel = getChannelC
instance HasChannel (InputValue) where getChannel = getChannelV
data Automaton a = Step { runStep :: [InputValue] -> IO (Maybe a, Automaton a) }
fromStateful :: ([InputValue] -> s -> IO (Maybe a,s)) -> s -> Automaton a
fromStateful f s = Step $ \i -> do
(a,s') <- f i s
return (a, fromStateful f s')
unfoldAutomaton :: Automaton b -> InputChannel a -> [Maybe a] -> IO [Maybe b]
unfoldAutomaton _ _ [] = return []
unfoldAutomaton auto i (mx:mxs) = do
(b, auto) <- runStep auto $ maybe [] (\x -> [toValue i x]) mx
bs <- unfoldAutomaton auto i mxs
return (b:bs)