{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module TypedGUI where
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (
Chan,
newChan,
readChan,
writeChan,
)
import Control.Monad (void)
import Control.Monad.State (MonadIO (liftIO), StateT (runStateT))
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Singletons.Base.TH (SEq, Sing, SomeSing (..))
import Graphics.UI.Threepenny (Element, UI, Window, runUI)
import TypedFsm (
AnyMsg (..),
Result (..),
SomeMsg (..),
SomeOperate (SomeOperate),
UnexpectMsg (..),
UnexpectMsgHandler (IgnoreAndTrace),
getSomeOperateSing,
runOperate,
)
type family RecRenderOutVal (t :: ps)
type RenderSt cs ds =
forall (t :: cs)
. Sing t
-> ds
-> Chan (AnyMsg cs)
-> Window
-> UI cs t (Maybe (Element, IO (RecRenderOutVal t)))
data InternalStRef cs ds = InternalStRef
{ forall cs ds. InternalStRef cs ds -> IORef ds
dsRef :: IORef ds
, forall cs ds. InternalStRef cs ds -> IORef (SomeSing cs)
csStRef :: IORef (SomeSing cs)
, forall cs ds. InternalStRef cs ds -> Chan (AnyMsg cs)
anyMsgTChan :: Chan (AnyMsg cs)
}
newInternalStRef
:: Sing (t :: cs)
-> ds
-> IO (InternalStRef cs ds)
newInternalStRef :: forall cs (t :: cs) ds. Sing t -> ds -> IO (InternalStRef cs ds)
newInternalStRef Sing t
sst ds
ds = do
a <- ds -> IO (IORef ds)
forall a. a -> IO (IORef a)
newIORef ds
ds
b <- newIORef (SomeSing sst)
c <- newChan
pure (InternalStRef a b c)
runHandler
:: (SEq cs)
=> InternalStRef cs ds
-> Result cs (UnexpectMsg cs) (StateT ds IO) a
-> IO (Result cs (UnexpectMsg cs) (StateT ds IO) a)
runHandler :: forall cs ds a.
SEq cs =>
InternalStRef cs ds
-> Result cs (UnexpectMsg cs) (StateT ds IO) a
-> IO (Result cs (UnexpectMsg cs) (StateT ds IO) a)
runHandler
InternalStRef
{ IORef ds
dsRef :: forall cs ds. InternalStRef cs ds -> IORef ds
dsRef :: IORef ds
dsRef
, IORef (SomeSing cs)
csStRef :: forall cs ds. InternalStRef cs ds -> IORef (SomeSing cs)
csStRef :: IORef (SomeSing cs)
csStRef
, Chan (AnyMsg cs)
anyMsgTChan :: forall cs ds. InternalStRef cs ds -> Chan (AnyMsg cs)
anyMsgTChan :: Chan (AnyMsg cs)
anyMsgTChan
}
Result cs (UnexpectMsg cs) (StateT ds IO) a
result = case Result cs (UnexpectMsg cs) (StateT ds IO) a
result of
Finish a
a -> Result cs (UnexpectMsg cs) (StateT ds IO) a
-> IO (Result cs (UnexpectMsg cs) (StateT ds IO) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Result cs (UnexpectMsg cs) (StateT ds IO) a
forall ps e (m :: * -> *) a. a -> Result ps e m a
Finish a
a)
e :: Result cs (UnexpectMsg cs) (StateT ds IO) a
e@(ErrorInfo (UnexpectMsg AnyMsg cs
_)) -> Result cs (UnexpectMsg cs) (StateT ds IO) a
-> IO (Result cs (UnexpectMsg cs) (StateT ds IO) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result cs (UnexpectMsg cs) (StateT ds IO) a
e
Cont (SomeOperate Sing i
cssing Operate (StateT ds IO) (At a o) i
op) -> do
anyMsg <- Chan (AnyMsg cs) -> IO (AnyMsg cs)
forall a. Chan a -> IO a
readChan Chan (AnyMsg cs)
anyMsgTChan
ds <- readIORef dsRef
(newResult, ds') <-
runStateT
( runOperate
( IgnoreAndTrace
(\AnyMsg cs
_ -> IO () -> StateT ds IO ()
forall a. IO a -> StateT ds IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT ds IO ()) -> IO () -> StateT ds IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"recive unexpect msg!!")
)
[anyMsg]
cssing
op
)
ds
writeIORef dsRef ds'
case newResult of
Cont SomeOperate cs (StateT ds IO) a
sop -> do
let st :: Sing Any
st = SomeOperate cs (StateT ds IO) a -> Sing Any
forall ts (m :: * -> *) a (r :: ts). SomeOperate ts m a -> Sing r
getSomeOperateSing SomeOperate cs (StateT ds IO) a
sop
IORef (SomeSing cs) -> SomeSing cs -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeSing cs)
csStRef (SomeSing cs -> IO ()) -> SomeSing cs -> IO ()
forall a b. (a -> b) -> a -> b
$ Sing Any -> SomeSing cs
forall k (a :: k). Sing a -> SomeSing k
SomeSing Sing Any
st
Result cs (UnexpectMsg cs) (StateT ds IO) a
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
pure newResult
sendSomeMsg
:: Chan (AnyMsg cs)
-> Sing (t :: cs)
-> SomeMsg cs t
-> UI cs t ()
sendSomeMsg :: forall cs (t :: cs).
Chan (AnyMsg cs) -> Sing t -> SomeMsg cs t -> UI cs t ()
sendSomeMsg Chan (AnyMsg cs)
tchan Sing t
sfrom (SomeMsg Sing to
sto Msg cs t to
msg) =
IO () -> UI cs t ()
forall a. IO a -> UI cs t a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> UI cs t ()) -> IO () -> UI cs t ()
forall a b. (a -> b) -> a -> b
$ Chan (AnyMsg cs) -> AnyMsg cs -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (AnyMsg cs)
tchan (Sing t -> Sing to -> Msg cs t to -> AnyMsg cs
forall ps (from :: ps) (to :: ps).
Sing from -> Sing to -> Msg ps from to -> AnyMsg ps
AnyMsg Sing t
sfrom Sing to
sto Msg cs t to
msg)
renderUI
:: forall cs ds
. InternalStRef cs ds
-> RenderSt cs ds
-> Window
-> IO ()
renderUI :: forall cs ds.
InternalStRef cs ds -> RenderSt cs ds -> Window -> IO ()
renderUI
InternalStRef{IORef ds
dsRef :: forall cs ds. InternalStRef cs ds -> IORef ds
dsRef :: IORef ds
dsRef, IORef (SomeSing cs)
csStRef :: forall cs ds. InternalStRef cs ds -> IORef (SomeSing cs)
csStRef :: IORef (SomeSing cs)
csStRef, Chan (AnyMsg cs)
anyMsgTChan :: forall cs ds. InternalStRef cs ds -> Chan (AnyMsg cs)
anyMsgTChan :: Chan (AnyMsg cs)
anyMsgTChan}
RenderSt cs ds
renderStFun
Window
window =
do
(SomeSing sst, ds) <- do
somesst <- IORef (SomeSing cs) -> IO (SomeSing cs)
forall a. IORef a -> IO a
readIORef IORef (SomeSing cs)
csStRef
ds <- readIORef dsRef
pure (somesst, ds)
void $ runUI window $ renderStFun sst ds anyMsgTChan window
uiSetup
:: (SEq cs)
=> InternalStRef cs ds
-> RenderSt cs ds
-> Result cs (UnexpectMsg cs) (StateT ds IO) ()
-> Window
-> UI ps (t :: ps) ()
uiSetup :: forall cs ds ps (t :: ps).
SEq cs =>
InternalStRef cs ds
-> RenderSt cs ds
-> Result cs (UnexpectMsg cs) (StateT ds IO) ()
-> Window
-> UI ps t ()
uiSetup InternalStRef cs ds
interStRef RenderSt cs ds
renderSt Result cs (UnexpectMsg cs) (StateT ds IO) ()
sthandler Window
window = do
let loop :: Result cs (UnexpectMsg cs) (StateT ds IO) () -> IO Any
loop Result cs (UnexpectMsg cs) (StateT ds IO) ()
result = do
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InternalStRef cs ds -> RenderSt cs ds -> Window -> IO ()
forall cs ds.
InternalStRef cs ds -> RenderSt cs ds -> Window -> IO ()
renderUI InternalStRef cs ds
interStRef Sing t
-> ds
-> Chan (AnyMsg cs)
-> Window
-> UI cs t (Maybe (Element, IO (RecRenderOutVal t)))
RenderSt cs ds
renderSt Window
window
newResult <- IO (Result cs (UnexpectMsg cs) (StateT ds IO) ())
-> IO (Result cs (UnexpectMsg cs) (StateT ds IO) ())
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Result cs (UnexpectMsg cs) (StateT ds IO) ())
-> IO (Result cs (UnexpectMsg cs) (StateT ds IO) ()))
-> IO (Result cs (UnexpectMsg cs) (StateT ds IO) ())
-> IO (Result cs (UnexpectMsg cs) (StateT ds IO) ())
forall a b. (a -> b) -> a -> b
$ InternalStRef cs ds
-> Result cs (UnexpectMsg cs) (StateT ds IO) ()
-> IO (Result cs (UnexpectMsg cs) (StateT ds IO) ())
forall cs ds a.
SEq cs =>
InternalStRef cs ds
-> Result cs (UnexpectMsg cs) (StateT ds IO) a
-> IO (Result cs (UnexpectMsg cs) (StateT ds IO) a)
runHandler InternalStRef cs ds
interStRef Result cs (UnexpectMsg cs) (StateT ds IO) ()
result
loop newResult
UI ps t ThreadId -> UI ps t ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Control.Monad.void (UI ps t ThreadId -> UI ps t ()) -> UI ps t ThreadId -> UI ps t ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> UI ps t ThreadId
forall a. IO a -> UI ps t a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> UI ps t ThreadId)
-> IO ThreadId -> UI ps t ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Control.Monad.void (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ Result cs (UnexpectMsg cs) (StateT ds IO) () -> IO Any
loop Result cs (UnexpectMsg cs) (StateT ds IO) ()
sthandler