{-# 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
  String -> String -> IO ()
L.debugM String
_LOG_APP String
"satrt application app"
  AppStores -> AppContext () -> IO (Either String ((), AppStores))
forall a.
AppStores -> AppContext a -> IO (Either String (a, AppStores))
runApp AppStores
appData AppContext ()
app
  String -> String -> IO ()
L.debugM String
_LOG_APP String
"end application app"


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

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

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

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

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

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

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

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


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


------------------------------------------------------------------------
-- |
--
appMain :: WrapRequest -> AppContext ()
appMain :: WrapRequest -> AppContext ()
appMain (WrapRequest (InternalTransitRequest (HdaInternalTransitRequest StateTransit
s))) = StateTransit -> AppContext ()
transit StateTransit
s
appMain WrapRequest
reqW = do
  WrapAppState
stateW <- Getting WrapAppState AppStores WrapAppState
-> AppStores -> WrapAppState
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting WrapAppState AppStores WrapAppState
Lens' AppStores WrapAppState
appStateWAppStores (AppStores -> WrapAppState)
-> StateT AppStores (ExceptT String IO) AppStores
-> StateT AppStores (ExceptT String IO) WrapAppState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT String IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
  WrapAppState -> WrapRequest -> AppContext (Maybe StateTransit)
forall s.
WrapAppStateIF s =>
s -> WrapRequest -> AppContext (Maybe StateTransit)
doActivityW WrapAppState
stateW WrapRequest
reqW AppContext (Maybe StateTransit)
-> (Maybe StateTransit -> AppContext ()) -> AppContext ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe StateTransit
Nothing -> () -> AppContext ()
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
          AppContext () -> AppContext () -> AppContext ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateTransit -> AppContext ()
updateState StateTransit
st
          AppContext () -> AppContext () -> AppContext ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AppContext ()
actEntryState

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

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


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


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