{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Haskell.Debug.Adapter.State.DebugRun.StackTrace where

import Control.Monad.IO.Class
import qualified System.Log.Logger as L
import qualified Text.Read as R
import Control.Monad.Except

import qualified Haskell.DAP as DAP
import Haskell.Debug.Adapter.Type
import Haskell.Debug.Adapter.Constant
import qualified Haskell.Debug.Adapter.Utility as U
import qualified Haskell.Debug.Adapter.GHCi as P
import qualified Haskell.Debug.Adapter.State.Utility as SU


-- |
--  Any errors should be sent back as False result Response
--
instance StateActivityIF DebugRunStateData DAP.StackTraceRequest where
  action :: AppState DebugRunStateData
-> Request StackTraceRequest -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
_ (StackTraceRequest StackTraceRequest
req) = do
    IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT AppStores (ExceptT ErrMsg IO) ())
-> IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_APP (ErrMsg -> IO ()) -> ErrMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"DebugRunState StackTraceRequest called. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ StackTraceRequest -> ErrMsg
forall a. Show a => a -> ErrMsg
show StackTraceRequest
req
    StackTraceRequest -> AppContext (Maybe StateTransit)
app StackTraceRequest
req

-- |
--
app :: DAP.StackTraceRequest -> AppContext (Maybe StateTransit)
app :: StackTraceRequest -> AppContext (Maybe StateTransit)
app StackTraceRequest
req = (AppContext (Maybe StateTransit)
 -> (ErrMsg -> AppContext (Maybe StateTransit))
 -> AppContext (Maybe StateTransit))
-> (ErrMsg -> AppContext (Maybe StateTransit))
-> AppContext (Maybe StateTransit)
-> AppContext (Maybe StateTransit)
forall a b c. (a -> b -> c) -> b -> a -> c
flip AppContext (Maybe StateTransit)
-> (ErrMsg -> AppContext (Maybe StateTransit))
-> AppContext (Maybe StateTransit)
forall a.
StateT AppStores (ExceptT ErrMsg IO) a
-> (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a)
-> StateT AppStores (ExceptT ErrMsg IO) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ErrMsg -> AppContext (Maybe StateTransit)
errHdl (AppContext (Maybe StateTransit)
 -> AppContext (Maybe StateTransit))
-> AppContext (Maybe StateTransit)
-> AppContext (Maybe StateTransit)
forall a b. (a -> b) -> a -> b
$ do

  let args :: StackTraceRequestArguments
args = StackTraceRequest -> StackTraceRequestArguments
DAP.argumentsStackTraceRequest StackTraceRequest
req
      dap :: ErrMsg
dap = ErrMsg
":dap-stacktrace "
      cmd :: ErrMsg
cmd = ErrMsg
dap ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ StackTraceRequestArguments -> ErrMsg
forall a. Show a => a -> ErrMsg
U.showDAP StackTraceRequestArguments
args
      dbg :: ErrMsg
dbg = ErrMsg
dap ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ StackTraceRequestArguments -> ErrMsg
forall a. Show a => a -> ErrMsg
show StackTraceRequestArguments
args

  ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
P.command ErrMsg
cmd
  ErrMsg -> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
U.debugEV ErrMsg
_LOG_APP ErrMsg
dbg
  AppContext [ErrMsg]
P.expectPmpt AppContext [ErrMsg]
-> ([ErrMsg] -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> (a -> StateT AppStores (ExceptT ErrMsg IO) b)
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ErrMsg] -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
SU.takeDapResult StateT AppStores (ExceptT ErrMsg IO) ErrMsg
-> (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ())
-> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> (a -> StateT AppStores (ExceptT ErrMsg IO) b)
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
dapHdl

  Maybe StateTransit -> AppContext (Maybe StateTransit)
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StateTransit
forall a. Maybe a
Nothing

  where
    -- |
    --
    dapHdl :: String -> AppContext ()
    dapHdl :: ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ()
dapHdl ErrMsg
str = case ErrMsg -> Either ErrMsg (Either ErrMsg StackTraceResponseBody)
forall a. Read a => ErrMsg -> Either ErrMsg a
R.readEither ErrMsg
str of
      Left ErrMsg
err -> ErrMsg -> AppContext (Maybe StateTransit)
errHdl ErrMsg
err AppContext (Maybe StateTransit)
-> StateT AppStores (ExceptT ErrMsg IO) ()
-> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> StateT AppStores (ExceptT ErrMsg IO) b
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Right (Left ErrMsg
err) -> ErrMsg -> AppContext (Maybe StateTransit)
errHdl ErrMsg
err AppContext (Maybe StateTransit)
-> StateT AppStores (ExceptT ErrMsg IO) ()
-> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b.
StateT AppStores (ExceptT ErrMsg IO) a
-> StateT AppStores (ExceptT ErrMsg IO) b
-> StateT AppStores (ExceptT ErrMsg IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Right (Right StackTraceResponseBody
body) -> do
        Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
        let res :: StackTraceResponse
res = StackTraceResponse
DAP.defaultStackTraceResponse {
                  DAP.seqStackTraceResponse = resSeq
                , DAP.request_seqStackTraceResponse = DAP.seqStackTraceRequest req
                , DAP.successStackTraceResponse = True
                , DAP.bodyStackTraceResponse = body
                }

        Response -> StateT AppStores (ExceptT ErrMsg IO) ()
U.addResponse (Response -> StateT AppStores (ExceptT ErrMsg IO) ())
-> Response -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ StackTraceResponse -> Response
StackTraceResponse StackTraceResponse
res

    -- |
    --
    errHdl :: String -> AppContext (Maybe StateTransit)
    errHdl :: ErrMsg -> AppContext (Maybe StateTransit)
errHdl ErrMsg
msg = do
      IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT AppStores (ExceptT ErrMsg IO) ())
-> IO () -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.errorM ErrMsg
_LOG_APP ErrMsg
msg
      Int
resSeq <- AppContext Int
U.getIncreasedResponseSequence
      let res :: StackTraceResponse
res = StackTraceResponse
DAP.defaultStackTraceResponse {
                DAP.seqStackTraceResponse = resSeq
              , DAP.request_seqStackTraceResponse = DAP.seqStackTraceRequest req
              , DAP.successStackTraceResponse = False
              , DAP.messageStackTraceResponse = msg
              }

      Response -> StateT AppStores (ExceptT ErrMsg IO) ()
U.addResponse (Response -> StateT AppStores (ExceptT ErrMsg IO) ())
-> Response -> StateT AppStores (ExceptT ErrMsg IO) ()
forall a b. (a -> b) -> a -> b
$ StackTraceResponse -> Response
StackTraceResponse StackTraceResponse
res
      Maybe StateTransit -> AppContext (Maybe StateTransit)
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StateTransit
forall a. Maybe a
Nothing