{-# 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,
 )

{-

Control status : cs
Data status    : ds

-}

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