{-# 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}