{-# LANGUAGE LambdaCase #-}

module Haskell.Debug.Adapter.Application where

import Control.Monad.IO.Class
import Data.Conduit
import Control.Lens
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar
import Control.Monad.State.Lazy
import Control.Monad.Except
import qualified System.Log.Logger as L

import Haskell.Debug.Adapter.Type
import Haskell.Debug.Adapter.Utility
import Haskell.Debug.Adapter.Constant
import Haskell.Debug.Adapter.State.Utility
import Haskell.Debug.Adapter.State.Init()
import Haskell.Debug.Adapter.State.GHCiRun()
import Haskell.Debug.Adapter.State.DebugRun()
import Haskell.Debug.Adapter.State.Shutdown()
import Haskell.Debug.Adapter.State.Contaminated()


-- |
--
run :: AppStores -> IO ()
run :: AppStores -> IO ()
run AppStores
appData = do
  ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_APP ErrMsg
"satrt application app"
  forall a.
AppStores -> AppContext a -> IO (Either ErrMsg (a, AppStores))
runApp AppStores
appData AppContext ()
app
  ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_APP ErrMsg
"end application app"


-- |
--
app :: AppContext ()
app :: AppContext ()
app = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ErrMsg -> AppContext ()
errHdl forall a b. (a -> b) -> a -> b
$ do
  ()
_ <- forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit ConduitM () Void (StateT AppStores (ExceptT ErrMsg IO)) ()
pipeline
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

  where
    pipeline :: ConduitM () Void AppContext ()
    pipeline :: ConduitM () Void (StateT AppStores (ExceptT ErrMsg IO)) ()
pipeline = ConduitT () WrapRequest (StateT AppStores (ExceptT ErrMsg IO)) ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT WrapRequest Void (StateT AppStores (ExceptT ErrMsg IO)) ()
sink

    errHdl :: ErrMsg -> AppContext ()
errHdl ErrMsg
msg = do
      ErrMsg -> ErrMsg -> AppContext ()
criticalEV ErrMsg
_LOG_APP ErrMsg
msg
      Event -> AppContext ()
addEvent Event
CriticalExitEvent

----------------------------------------------------------------
-- |
--
src :: ConduitT () WrapRequest AppContext ()
src :: ConduitT () WrapRequest (StateT AppStores (ExceptT ErrMsg IO)) ()
src = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_APP forall a b. (a -> b) -> a -> b
$ ErrMsg
"src start waiting."
  WrapRequest
req <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift AppContext WrapRequest
goApp
  forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield WrapRequest
req
  ConduitT () WrapRequest (StateT AppStores (ExceptT ErrMsg IO)) ()
src

  where
    goApp :: AppContext WrapRequest
    goApp :: AppContext WrapRequest
goApp = do
      MVar [WrapRequest]
mvar <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores (MVar [WrapRequest])
reqStoreAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar [WrapRequest] -> IO (Maybe WrapRequest)
takeRequest MVar [WrapRequest]
mvar) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just WrapRequest
res -> forall (m :: * -> *) a. Monad m => a -> m a
return WrapRequest
res
        Maybe WrapRequest
Nothing -> do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
_1_MILLI_SEC
          AppContext WrapRequest
goApp

-- |
--
takeRequest :: MVar [WrapRequest] -> IO (Maybe WrapRequest)
takeRequest :: MVar [WrapRequest] -> IO (Maybe WrapRequest)
takeRequest MVar [WrapRequest]
reqsMVar = IO Bool
isExists forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Bool
True  -> IO (Maybe WrapRequest)
take1

  where
    isExists :: IO Bool
isExists = forall a. MVar a -> IO a
readMVar MVar [WrapRequest]
reqsMVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [] -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      [WrapRequest]
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

    take1 :: IO (Maybe WrapRequest)
take1 = forall a. MVar a -> IO a
takeMVar MVar [WrapRequest]
reqsMVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [] -> do
        forall a. MVar a -> a -> IO ()
putMVar MVar [WrapRequest]
reqsMVar []
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      (WrapRequest
x:[WrapRequest]
xs) -> do
        forall a. MVar a -> a -> IO ()
putMVar MVar [WrapRequest]
reqsMVar [WrapRequest]
xs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just WrapRequest
x


------------------------------------------------------------------------
-- |
--
sink :: ConduitT WrapRequest Void AppContext ()
sink :: ConduitT WrapRequest Void (StateT AppStores (ExceptT ErrMsg IO)) ()
sink = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_APP forall a b. (a -> b) -> a -> b
$ ErrMsg
"sink start waiting."
  forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe WrapRequest
Nothing  -> do
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ ErrMsg
"[CRITICAL][response][sink] unexpectHed Nothing."
      forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (WrapRequest (DisconnectRequest DisconnectRequest
req)) -> do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_APP forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> ErrMsg
show DisconnectRequest
req
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.infoM ErrMsg
_LOG_APP forall a b. (a -> b) -> a -> b
$ ErrMsg
"disconnect."
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ DisconnectRequest -> AppContext ()
sendDisconnectResponse DisconnectRequest
req
      ConduitT WrapRequest Void (StateT AppStores (ExceptT ErrMsg IO)) ()
sink
    Just (WrapRequest (PauseRequest PauseRequest
req)) -> do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_APP forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> ErrMsg
show PauseRequest
req
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ErrMsg -> AppContext ()
sendConsoleEventLF forall a b. (a -> b) -> a -> b
$ ErrMsg
"pause request is not supported."
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PauseRequest -> AppContext ()
sendPauseResponse PauseRequest
req
      ConduitT WrapRequest Void (StateT AppStores (ExceptT ErrMsg IO)) ()
sink
    Just WrapRequest
req -> do
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ WrapRequest -> AppContext ()
appMain WrapRequest
req
      ConduitT WrapRequest Void (StateT AppStores (ExceptT ErrMsg IO)) ()
sink


------------------------------------------------------------------------
-- |
--
appMain :: WrapRequest -> AppContext ()
appMain :: WrapRequest -> AppContext ()
appMain (WrapRequest (InternalTransitRequest (HdaInternalTransitRequest StateTransit
s))) = StateTransit -> AppContext ()
transit StateTransit
s
appMain WrapRequest
reqW = do
  WrapAppState
stateW <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores WrapAppState
appStateWAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
  forall s.
WrapAppStateIF s =>
s -> WrapRequest -> AppContext (Maybe StateTransit)
doActivityW WrapAppState
stateW WrapRequest
reqW forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe StateTransit
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just StateTransit
st -> StateTransit -> AppContext ()
transit StateTransit
st

-- |
--
transit :: StateTransit -> AppContext ()
transit :: StateTransit -> AppContext ()
transit StateTransit
st = AppContext ()
actExitState
          forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateTransit -> AppContext ()
updateState StateTransit
st
          forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AppContext ()
actEntryState

  where
    actExitState :: AppContext ()
actExitState = do
      WrapAppState
stateW <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores WrapAppState
appStateWAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
      forall s. WrapAppStateIF s => s -> AppContext ()
exitActionW WrapAppState
stateW

    actEntryState :: AppContext ()
actEntryState = do
      WrapAppState
stateW <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores WrapAppState
appStateWAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
      forall s. WrapAppStateIF s => s -> AppContext ()
entryActionW WrapAppState
stateW


-- |
--
updateState :: StateTransit -> AppContext ()
updateState :: StateTransit -> AppContext ()
updateState StateTransit
Init_GHCiRun          = WrapAppState -> AppContext ()
changeState forall a b. (a -> b) -> a -> b
$ forall s. AppStateIF s => AppState s -> WrapAppState
WrapAppState AppState GHCiRunStateData
GHCiRunState
updateState StateTransit
Init_Shutdown         = WrapAppState -> AppContext ()
changeState forall a b. (a -> b) -> a -> b
$ forall s. AppStateIF s => AppState s -> WrapAppState
WrapAppState AppState ShutdownStateData
ShutdownState
updateState StateTransit
GHCiRun_DebugRun      = WrapAppState -> AppContext ()
changeState forall a b. (a -> b) -> a -> b
$ forall s. AppStateIF s => AppState s -> WrapAppState
WrapAppState AppState DebugRunStateData
DebugRunState
updateState StateTransit
GHCiRun_Contaminated  = WrapAppState -> AppContext ()
changeState forall a b. (a -> b) -> a -> b
$ forall s. AppStateIF s => AppState s -> WrapAppState
WrapAppState AppState ContaminatedStateData
ContaminatedState
updateState StateTransit
GHCiRun_Shutdown      = WrapAppState -> AppContext ()
changeState forall a b. (a -> b) -> a -> b
$ forall s. AppStateIF s => AppState s -> WrapAppState
WrapAppState AppState ShutdownStateData
ShutdownState
updateState StateTransit
DebugRun_Contaminated = WrapAppState -> AppContext ()
changeState forall a b. (a -> b) -> a -> b
$ forall s. AppStateIF s => AppState s -> WrapAppState
WrapAppState AppState ContaminatedStateData
ContaminatedState
updateState StateTransit
DebugRun_Shutdown     = WrapAppState -> AppContext ()
changeState forall a b. (a -> b) -> a -> b
$ forall s. AppStateIF s => AppState s -> WrapAppState
WrapAppState AppState ShutdownStateData
ShutdownState
updateState StateTransit
DebugRun_GHCiRun      = WrapAppState -> AppContext ()
changeState forall a b. (a -> b) -> a -> b
$ forall s. AppStateIF s => AppState s -> WrapAppState
WrapAppState AppState GHCiRunStateData
GHCiRunState
updateState StateTransit
Contaminated_Shutdown = WrapAppState -> AppContext ()
changeState forall a b. (a -> b) -> a -> b
$ forall s. AppStateIF s => AppState s -> WrapAppState
WrapAppState AppState ShutdownStateData
ShutdownState


-- |
--
changeState :: WrapAppState -> AppContext ()
changeState :: WrapAppState -> AppContext ()
changeState WrapAppState
s = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \AppStores
d -> AppStores
d {_appStateWAppStores :: WrapAppState
_appStateWAppStores = WrapAppState
s}