{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
module FRP.Rhine.Terminal
( TerminalEventClock (..)
, flowTerminal
, terminalConcurrently
) where
import Prelude hiding (putChar)
import Unsafe.Coerce (unsafeCoerce)
import Control.Monad.Catch (MonadMask)
import Data.Time.Clock ( getCurrentTime )
import System.Terminal ( awaitEvent, runTerminalT, Event, Interrupt, TerminalT, MonadInput )
import System.Terminal.Internal ( Terminal )
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class (lift)
import FRP.Rhine
data TerminalEventClock = TerminalEventClock
instance (MonadInput m, MonadIO m) => Clock m TerminalEventClock
where
type Time TerminalEventClock = UTCTime
type Tag TerminalEventClock = Either Interrupt Event
initClock :: TerminalEventClock
-> RunningClockInit
m (Time TerminalEventClock) (Tag TerminalEventClock)
initClock TerminalEventClock
TerminalEventClock = do
UTCTime
initialTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
forall (m :: * -> *) a. Monad m => a -> m a
return
( forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM forall a b. (a -> b) -> a -> b
$ do
Either Interrupt Event
event <- forall (m :: * -> *). MonadInput m => m (Either Interrupt Event)
awaitEvent
UTCTime
time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
time, Either Interrupt Event
event)
, UTCTime
initialTime
)
instance GetClockProxy TerminalEventClock
instance Semigroup TerminalEventClock where
TerminalEventClock
t <> :: TerminalEventClock -> TerminalEventClock -> TerminalEventClock
<> TerminalEventClock
_ = TerminalEventClock
t
flowTerminal
:: ( MonadIO m
, MonadMask m
, Terminal t
, Clock (TerminalT t m) cl
, GetClockProxy cl
, Time cl ~ Time (In cl)
, Time cl ~ Time (Out cl)
)
=> t
-> Rhine (TerminalT t m) cl () ()
-> m ()
flowTerminal :: forall (m :: * -> *) t cl.
(MonadIO m, MonadMask m, Terminal t, Clock (TerminalT t m) cl,
GetClockProxy cl, Time cl ~ Time (In cl),
Time cl ~ Time (Out cl)) =>
t -> Rhine (TerminalT t m) cl () () -> m ()
flowTerminal t
term Rhine (TerminalT t m) cl () ()
clsf = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) t a.
(MonadIO m, MonadMask m, Terminal t) =>
TerminalT t m a -> t -> m a
runTerminalT t
term forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) cl.
(Monad m, Clock m cl, GetClockProxy cl, Time cl ~ Time (In cl),
Time cl ~ Time (Out cl)) =>
Rhine m cl () () -> m ()
flow Rhine (TerminalT t m) cl () ()
clsf
terminalConcurrently
:: forall t cl1 cl2. (
Terminal t
, Clock (TerminalT t IO) cl1
, Clock (TerminalT t IO) cl2
, Time cl1 ~ Time cl2
)
=> Schedule (TerminalT t IO) cl1 cl2
terminalConcurrently :: forall t cl1 cl2.
(Terminal t, Clock (TerminalT t IO) cl1,
Clock (TerminalT t IO) cl2, Time cl1 ~ Time cl2) =>
Schedule (TerminalT t IO) cl1 cl2
terminalConcurrently
= forall (m :: * -> *) cl1 cl2.
(Time cl1 ~ Time cl2) =>
(cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule m cl1 cl2
Schedule forall a b. (a -> b) -> a -> b
$ \cl1
cl1 cl2
cl2 -> do
t
term <- forall t (m :: * -> *) a. ReaderT t m a -> TerminalT t m a
terminalT forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTrans t, Monad m, Monad (t m)) =>
MSF m a b -> MSF (t m) a b
liftTransS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall (m :: * -> *) cl1 cl2.
Schedule m cl1 cl2
-> cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))
initSchedule forall cl1 cl2.
(Clock IO cl1, Clock IO cl2, Time cl1 ~ Time cl2) =>
Schedule IO cl1 cl2
concurrently (forall t cl. Terminal t => t -> cl -> RunTerminalClock IO t cl
runTerminalClock t
term cl1
cl1) (forall t cl. Terminal t => t -> cl -> RunTerminalClock IO t cl
runTerminalClock t
term cl2
cl2)
terminalT :: ReaderT t m a -> TerminalT t m a
terminalT :: forall t (m :: * -> *) a. ReaderT t m a -> TerminalT t m a
terminalT = forall a b. a -> b
unsafeCoerce
type RunTerminalClock m t cl = HoistClock (TerminalT t m) m cl
runTerminalClock
:: Terminal t
=> t
-> cl
-> RunTerminalClock IO t cl
runTerminalClock :: forall t cl. Terminal t => t -> cl -> RunTerminalClock IO t cl
runTerminalClock t
term cl
unhoistedClock = HoistClock
{ monadMorphism :: forall a. TerminalT t IO a -> IO a
monadMorphism = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) t a.
(MonadIO m, MonadMask m, Terminal t) =>
TerminalT t m a -> t -> m a
runTerminalT t
term
, cl
unhoistedClock :: cl
unhoistedClock :: cl
..
}