Application.hs

{-# 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 appData = do
  L.debugM _LOG_APP "satrt application app"
  runApp appData app
  L.debugM _LOG_APP "end application app"


-- |
--
app :: AppContext ()
app = flip catchError errHdl $ do
  _ <- runConduit pipeline
  return ()

  where
    pipeline :: ConduitM () Void AppContext ()
    pipeline = src .| sink

    errHdl msg = do
      criticalEV _LOG_APP msg
      addEvent CriticalExitEvent

----------------------------------------------------------------
-- |
--
src :: ConduitT () WrapRequest AppContext ()
src = do
  liftIO $ L.debugM _LOG_APP $ "src start waiting."
  req <- lift goApp
  yield req
  src

  where
    goApp :: AppContext WrapRequest
    goApp = do
      mvar <- view reqStoreAppStores <$> get
      liftIO (takeRequest mvar) >>= \case
        Just res -> return res
        Nothing -> do
          liftIO $ threadDelay _1_MILLI_SEC
          goApp

-- |
--
takeRequest :: MVar [WrapRequest] -> IO (Maybe WrapRequest)
takeRequest reqsMVar = isExists >>= \case
    False -> return Nothing
    True  -> take1

  where
    isExists = readMVar reqsMVar >>= \case
      [] -> return False
      _  -> return True

    take1 = takeMVar reqsMVar >>= \case
      [] -> do
        putMVar reqsMVar []
        return Nothing
      (x:xs) -> do
        putMVar reqsMVar xs
        return $ Just x


------------------------------------------------------------------------
-- |
--
sink :: ConduitT WrapRequest Void AppContext ()
sink = do
  liftIO $ L.debugM _LOG_APP $ "sink start waiting."
  await >>= \case
    Nothing  -> do
      throwError $ "[CRITICAL][response][sink] unexpectHed Nothing."
      return ()
    Just (WrapRequest (DisconnectRequest req)) -> do
      liftIO $ L.debugM _LOG_APP $ show req
      liftIO $ L.infoM _LOG_APP $ "disconnect."
      lift $ sendDisconnectResponse req
      sink
    Just (WrapRequest (PauseRequest req)) -> do
      liftIO $ L.debugM _LOG_APP $ show req
      lift $ sendConsoleEventLF $ "pause request is not supported."
      lift $ sendPauseResponse req
      sink
    Just req -> do
      lift $ appMain req
      sink


------------------------------------------------------------------------
-- |
--
appMain :: WrapRequest -> AppContext ()
appMain (WrapRequest (InternalTransitRequest (HdaInternalTransitRequest s))) = transit s
appMain reqW = do
  stateW <- view appStateWAppStores <$> get
  doActivityW stateW reqW >>= \case
    Nothing -> return ()
    Just st -> transit st

-- |
--
transit :: StateTransit -> AppContext ()
transit st = actExitState
          >> updateState st
          >> actEntryState

  where
    actExitState = do
      stateW <- view appStateWAppStores <$> get
      exitActionW stateW

    actEntryState = do
      stateW <- view appStateWAppStores <$> get
      entryActionW stateW


-- |
--
updateState :: StateTransit -> AppContext ()
updateState Init_GHCiRun          = changeState $ WrapAppState GHCiRunState
updateState Init_Shutdown         = changeState $ WrapAppState ShutdownState
updateState GHCiRun_DebugRun      = changeState $ WrapAppState DebugRunState
updateState GHCiRun_Contaminated  = changeState $ WrapAppState ContaminatedState
updateState GHCiRun_Shutdown      = changeState $ WrapAppState ShutdownState
updateState DebugRun_Contaminated = changeState $ WrapAppState ContaminatedState
updateState DebugRun_Shutdown     = changeState $ WrapAppState ShutdownState
updateState DebugRun_GHCiRun      = changeState $ WrapAppState GHCiRunState
updateState Contaminated_Shutdown = changeState $ WrapAppState ShutdownState


-- |
--
changeState :: WrapAppState -> AppContext ()
changeState s = modify $ \d -> d {_appStateWAppStores = s}