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 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 -> [a] -> IO [Maybe b]
unfoldAutomaton _ _ [] = return []
unfoldAutomaton auto i (x:xs) = do
(b, auto) <- runStep auto $ [toValue i x]
bs <- unfoldAutomaton auto i xs
return (b:bs)