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

module Haskell.Debug.Adapter.State.DebugRun where

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

import qualified Haskell.DAP as DAP
import Haskell.Debug.Adapter.Constant
import qualified Haskell.Debug.Adapter.Utility as U
import Haskell.Debug.Adapter.Type
import qualified Haskell.Debug.Adapter.GHCi as P
import Haskell.Debug.Adapter.State.DebugRun.Threads()
import Haskell.Debug.Adapter.State.DebugRun.StackTrace()
import Haskell.Debug.Adapter.State.DebugRun.Scopes()
import Haskell.Debug.Adapter.State.DebugRun.Variables()
import Haskell.Debug.Adapter.State.DebugRun.Source()
import Haskell.Debug.Adapter.State.DebugRun.Continue()
import Haskell.Debug.Adapter.State.DebugRun.Next()
import Haskell.Debug.Adapter.State.DebugRun.StepIn()
import Haskell.Debug.Adapter.State.DebugRun.Terminate()
import Haskell.Debug.Adapter.State.DebugRun.InternalTerminate()
import qualified Haskell.Debug.Adapter.State.Utility as SU


instance AppStateIF DebugRunStateData where
  -- |
  --
  entryAction :: AppState DebugRunStateData -> AppContext ()
entryAction AppState DebugRunStateData
DebugRunState = do
    IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_APP ErrMsg
"DebugRunState entryAction called."
    AppContext ()
goEntry

  -- |
  --
  exitAction :: AppState DebugRunStateData -> AppContext ()
exitAction AppState DebugRunStateData
DebugRunState = do
    IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.debugM ErrMsg
_LOG_APP ErrMsg
"DebugRunState exitAction called."
    () -> AppContext ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


  -- |
  --
  doActivity :: AppState DebugRunStateData
-> WrapRequest -> AppContext (Maybe StateTransit)
doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@InitializeRequest{})              = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@LaunchRequest{})                  = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@DisconnectRequest{})              = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@PauseRequest{})                   = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@TerminateRequest{})               = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@SetBreakpointsRequest{})          = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@SetFunctionBreakpointsRequest{})  = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@SetExceptionBreakpointsRequest{}) = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@ConfigurationDoneRequest{})       = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@ThreadsRequest{})                 = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@StackTraceRequest{})              = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@ScopesRequest{})                  = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@VariablesRequest{})               = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@SourceRequest{})                  = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@ContinueRequest{})                = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@NextRequest{})                    = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@StepInRequest{})                  = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@EvaluateRequest{})                = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@CompletionsRequest{})             = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@InternalTransitRequest{})         = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@InternalTerminateRequest{})       = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r
  doActivity AppState DebugRunStateData
s (WrapRequest r :: Request a
r@InternalLoadRequest{})            = AppState DebugRunStateData
-> Request a -> AppContext (Maybe StateTransit)
forall s r.
StateActivityIF s r =>
AppState s -> Request r -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
s Request a
r

-- |
--   default nop.
--
instance StateActivityIF DebugRunStateData DAP.InitializeRequest

-- |
--   default nop.
--
instance StateActivityIF DebugRunStateData DAP.LaunchRequest

-- |
--   default nop.
--
instance StateActivityIF DebugRunStateData DAP.DisconnectRequest

-- |
--   default nop.
--
instance StateActivityIF DebugRunStateData DAP.PauseRequest

-- |
--
goEntry :: AppContext ()
goEntry :: AppContext ()
goEntry = Getting Bool AppStores Bool -> AppStores -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool AppStores Bool
Lens' AppStores Bool
stopOnEntryAppStores (AppStores -> Bool)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get StateT AppStores (ExceptT ErrMsg IO) Bool
-> (Bool -> AppContext ()) -> AppContext ()
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
>>= \case
  Bool
True  -> AppContext ()
stopOnEntry
  Bool
False -> AppContext ()
startDebug

-- |
--
stopOnEntry :: AppContext ()
stopOnEntry :: AppContext ()
stopOnEntry = do
  ErrMsg
startupFile <- Getting ErrMsg AppStores ErrMsg -> AppStores -> ErrMsg
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ErrMsg AppStores ErrMsg
Lens' AppStores ErrMsg
startupAppStores (AppStores -> ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
  ErrMsg
startupFunc <- Getting ErrMsg AppStores ErrMsg -> AppStores -> ErrMsg
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ErrMsg AppStores ErrMsg
Lens' AppStores ErrMsg
startupFuncAppStores (AppStores -> ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get

  let funcName :: ErrMsg
funcName = if ErrMsg -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ErrMsg
startupFunc then ErrMsg
"main" else ErrMsg
startupFunc
      funcBp :: (ErrMsg, FunctionBreakpoint)
funcBp   = (ErrMsg
startupFile, ErrMsg -> Maybe ErrMsg -> Maybe ErrMsg -> FunctionBreakpoint
DAP.FunctionBreakpoint ErrMsg
funcName Maybe ErrMsg
forall a. Maybe a
Nothing Maybe ErrMsg
forall a. Maybe a
Nothing)
      cmd :: ErrMsg
cmd = ErrMsg
":dap-set-function-breakpoint " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ (ErrMsg, FunctionBreakpoint) -> ErrMsg
forall a. Show a => a -> ErrMsg
U.showDAP (ErrMsg, FunctionBreakpoint)
funcBp

  ErrMsg -> AppContext ()
P.command ErrMsg
cmd
  [ErrMsg]
res <- AppContext [ErrMsg]
P.expectPmpt

  [ErrMsg] -> AppContext ()
withAdhocAddDapHeader ([ErrMsg] -> AppContext ()) -> [ErrMsg] -> AppContext ()
forall a b. (a -> b) -> a -> b
$ (ErrMsg -> Bool) -> [ErrMsg] -> [ErrMsg]
forall a. (a -> Bool) -> [a] -> [a]
filter (ErrMsg -> ErrMsg -> Bool
U.startswith ErrMsg
_DAP_HEADER) [ErrMsg]
res

  where
    -- |
    --
    withAdhocAddDapHeader :: [String] -> AppContext ()
    withAdhocAddDapHeader :: [ErrMsg] -> AppContext ()
withAdhocAddDapHeader [] = do
      ErrMsg -> ErrMsg -> AppContext ()
U.warnEV ErrMsg
_LOG_APP (ErrMsg -> AppContext ()) -> ErrMsg -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"can not set func breakpoint. no dap header found."
      AppContext ()
startDebug
    withAdhocAddDapHeader (ErrMsg
str:[]) = case ErrMsg -> Either ErrMsg (Either ErrMsg Breakpoint)
forall a. Read a => ErrMsg -> Either ErrMsg a
R.readEither (Int -> ErrMsg -> ErrMsg
forall a. Int -> [a] -> [a]
drop (ErrMsg -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ErrMsg
_DAP_HEADER) ErrMsg
str) of
      Left ErrMsg
err -> do
        ErrMsg -> ErrMsg -> AppContext ()
U.warnEV ErrMsg
_LOG_APP (ErrMsg -> AppContext ()) -> ErrMsg -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"read response body failed. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
err ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
" : " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
str
        AppContext ()
startDebug
      Right (Left ErrMsg
err) -> do
        ErrMsg -> ErrMsg -> AppContext ()
U.warnEV ErrMsg
_LOG_APP (ErrMsg -> AppContext ()) -> ErrMsg -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"set adhoc breakpoint failed. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
err ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
" : " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
str
        AppContext ()
startDebug
      Right (Right Breakpoint
bp) -> do
        AppContext ()
startDebug
        Breakpoint -> AppContext ()
adhocDelBreakpoint Breakpoint
bp
    withAdhocAddDapHeader [ErrMsg]
_ = do
      ErrMsg -> ErrMsg -> AppContext ()
U.warnEV ErrMsg
_LOG_APP (ErrMsg -> AppContext ()) -> ErrMsg -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"can not set func breakpoint. ambiguous dap header found."
      AppContext ()
startDebug

    -- |
    --
    adhocDelBreakpoint :: DAP.Breakpoint -> AppContext ()
    adhocDelBreakpoint :: Breakpoint -> AppContext ()
adhocDelBreakpoint Breakpoint
bp = do
      let cmd :: ErrMsg
cmd = ErrMsg
":dap-delete-breakpoint " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ Breakpoint -> ErrMsg
forall a. Show a => a -> ErrMsg
U.showDAP Breakpoint
bp

      ErrMsg -> AppContext ()
P.command ErrMsg
cmd
      [ErrMsg]
res <- AppContext [ErrMsg]
P.expectPmpt

      [ErrMsg] -> AppContext ()
withAdhocDelDapHeader ([ErrMsg] -> AppContext ()) -> [ErrMsg] -> AppContext ()
forall a b. (a -> b) -> a -> b
$ (ErrMsg -> Bool) -> [ErrMsg] -> [ErrMsg]
forall a. (a -> Bool) -> [a] -> [a]
filter (ErrMsg -> ErrMsg -> Bool
U.startswith ErrMsg
_DAP_HEADER) [ErrMsg]
res

    -- |
    --
    withAdhocDelDapHeader :: [String] -> AppContext ()
    withAdhocDelDapHeader :: [ErrMsg] -> AppContext ()
withAdhocDelDapHeader [] = ErrMsg -> AppContext ()
forall a. ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrMsg -> AppContext ()) -> ErrMsg -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"can not del func breakpoint. no dap header found."
    withAdhocDelDapHeader (ErrMsg
str:[]) = case ErrMsg -> Either ErrMsg (Either ErrMsg ())
forall a. Read a => ErrMsg -> Either ErrMsg a
R.readEither (Int -> ErrMsg -> ErrMsg
forall a. Int -> [a] -> [a]
drop (ErrMsg -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ErrMsg
_DAP_HEADER) ErrMsg
str) of
      Left ErrMsg
err -> ErrMsg -> AppContext ()
forall a. ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrMsg -> AppContext ()) -> ErrMsg -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"read response body failed. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
err ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
" : " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
str
      Right (Left ErrMsg
err) -> ErrMsg -> AppContext ()
forall a. ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrMsg -> AppContext ()) -> ErrMsg -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"del adhoc breakpoint failed. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
err ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
" : " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
str
      Right (Right ()
res) -> () -> AppContext ()
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
res
    withAdhocDelDapHeader [ErrMsg]
_ = ErrMsg -> AppContext ()
forall a. ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrMsg -> AppContext ()) -> ErrMsg -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg
"can not del func breakpoint. ambiguous dap header found."


-- |
--
startDebug :: AppContext ()
startDebug :: AppContext ()
startDebug = do
  ErrMsg
expr <- StateT AppStores (ExceptT ErrMsg IO) ErrMsg
getTraceExpr
  let args :: ContinueRequestArguments
args = ContinueRequestArguments
DAP.defaultContinueRequestArguments {
             DAP.exprContinueRequestArguments = Just expr
           }

  ContinueRequestArguments -> AppContext ()
forall {a}. Show a => a -> AppContext ()
startDebugDAP ContinueRequestArguments
args

  where
    getTraceExpr :: StateT AppStores (ExceptT ErrMsg IO) ErrMsg
getTraceExpr = Getting ErrMsg AppStores ErrMsg -> AppStores -> ErrMsg
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ErrMsg AppStores ErrMsg
Lens' AppStores ErrMsg
startupFuncAppStores (AppStores -> ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get StateT AppStores (ExceptT ErrMsg IO) 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
>>= \case
      [] -> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ErrMsg
"main"
      ErrMsg
func -> do
        ErrMsg
funcArgs <- Getting ErrMsg AppStores ErrMsg -> AppStores -> ErrMsg
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ErrMsg AppStores ErrMsg
Lens' AppStores ErrMsg
startupArgsAppStores (AppStores -> ErrMsg)
-> StateT AppStores (ExceptT ErrMsg IO) AppStores
-> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AppStores (ExceptT ErrMsg IO) AppStores
forall s (m :: * -> *). MonadState s m => m s
get
        ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a. a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg)
-> ErrMsg -> StateT AppStores (ExceptT ErrMsg IO) ErrMsg
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg
U.strip (ErrMsg -> ErrMsg) -> ErrMsg -> ErrMsg
forall a b. (a -> b) -> a -> b
$ ErrMsg
func ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
" " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
funcArgs

    startDebugDAP :: a -> AppContext ()
startDebugDAP a
args = do

      let dap :: ErrMsg
dap = ErrMsg
":dap-continue "
          cmd :: ErrMsg
cmd = ErrMsg
dap ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ a -> ErrMsg
forall a. Show a => a -> ErrMsg
U.showDAP a
args
          dbg :: ErrMsg
dbg = ErrMsg
dap ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ a -> ErrMsg
forall a. Show a => a -> ErrMsg
show a
args

      ErrMsg -> AppContext ()
P.command ErrMsg
cmd
      ErrMsg -> ErrMsg -> AppContext ()
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 -> AppContext ()) -> AppContext ()
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 -> AppContext ()
dapHdl

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

    -- |
    --
    dapHdl :: String -> AppContext ()
    dapHdl :: ErrMsg -> AppContext ()
dapHdl ErrMsg
str = case ErrMsg -> Either ErrMsg (Either ErrMsg StoppedEventBody)
forall a. Read a => ErrMsg -> Either ErrMsg a
R.readEither ErrMsg
str of
      Left ErrMsg
err -> ErrMsg -> ErrMsg -> AppContext ()
errHdl ErrMsg
str ErrMsg
err
      Right (Left ErrMsg
err) -> ErrMsg -> ErrMsg -> AppContext ()
errHdl ErrMsg
str ErrMsg
err
      Right (Right StoppedEventBody
body) -> StoppedEventBody -> AppContext ()
U.handleStoppedEventBody StoppedEventBody
body

    -- |
    --
    errHdl :: String -> String -> AppContext()
    errHdl :: ErrMsg -> ErrMsg -> AppContext ()
errHdl ErrMsg
str ErrMsg
err = do
      let msg :: ErrMsg
msg = ErrMsg
"start debugging failed. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
err ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
" : " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ ErrMsg
str
      IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrMsg -> IO ()
L.errorM ErrMsg
_LOG_APP ErrMsg
msg
      ErrMsg -> AppContext ()
U.sendErrorEventLF ErrMsg
msg


-- |
--  Any errors should be sent back as False result Response
--
instance StateActivityIF DebugRunStateData DAP.SetBreakpointsRequest where
  action :: AppState DebugRunStateData
-> Request SetBreakpointsRequest -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
_ (SetBreakpointsRequest SetBreakpointsRequest
req) = do
    IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
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 SetBreakpointsRequest called. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ SetBreakpointsRequest -> ErrMsg
forall a. Show a => a -> ErrMsg
show SetBreakpointsRequest
req
    SetBreakpointsRequest -> AppContext (Maybe StateTransit)
SU.setBreakpointsRequest SetBreakpointsRequest
req

-- |
--  Any errors should be sent back as False result Response
--
instance StateActivityIF DebugRunStateData DAP.SetExceptionBreakpointsRequest where
  action :: AppState DebugRunStateData
-> Request SetExceptionBreakpointsRequest
-> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
_ (SetExceptionBreakpointsRequest SetExceptionBreakpointsRequest
req) = do
    IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
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 SetExceptionBreakpointsRequest called. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ SetExceptionBreakpointsRequest -> ErrMsg
forall a. Show a => a -> ErrMsg
show SetExceptionBreakpointsRequest
req
    SetExceptionBreakpointsRequest -> AppContext (Maybe StateTransit)
SU.setExceptionBreakpointsRequest SetExceptionBreakpointsRequest
req

-- |
--  Any errors should be sent back as False result Response
--
instance StateActivityIF DebugRunStateData DAP.SetFunctionBreakpointsRequest where
  action :: AppState DebugRunStateData
-> Request SetFunctionBreakpointsRequest
-> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
_ (SetFunctionBreakpointsRequest SetFunctionBreakpointsRequest
req) = do
    IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
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 SetFunctionBreakpointsRequest called. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ SetFunctionBreakpointsRequest -> ErrMsg
forall a. Show a => a -> ErrMsg
show SetFunctionBreakpointsRequest
req
    SetFunctionBreakpointsRequest -> AppContext (Maybe StateTransit)
SU.setFunctionBreakpointsRequest SetFunctionBreakpointsRequest
req

-- |
--   default nop.
--
instance StateActivityIF DebugRunStateData DAP.ConfigurationDoneRequest

-- |
--  Any errors should be sent back as False result Response
--
instance StateActivityIF DebugRunStateData DAP.EvaluateRequest where
  action :: AppState DebugRunStateData
-> Request EvaluateRequest -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
_ (EvaluateRequest EvaluateRequest
req) = do
    IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
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 EvaluateRequest called. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ EvaluateRequest -> ErrMsg
forall a. Show a => a -> ErrMsg
show EvaluateRequest
req
    EvaluateRequest -> AppContext (Maybe StateTransit)
SU.evaluateRequest EvaluateRequest
req

-- |
--  Any errors should be sent back as False result Response
--
instance StateActivityIF DebugRunStateData DAP.CompletionsRequest where
  action :: AppState DebugRunStateData
-> Request CompletionsRequest -> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
_ (CompletionsRequest CompletionsRequest
req) = do
    IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
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 CompletionsRequest called. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ CompletionsRequest -> ErrMsg
forall a. Show a => a -> ErrMsg
show CompletionsRequest
req
    CompletionsRequest -> AppContext (Maybe StateTransit)
SU.completionsRequest CompletionsRequest
req

-- |
--   default nop.
--
instance StateActivityIF DebugRunStateData HdaInternalTransitRequest

-- |
--  Any errors should be sent back as False result Response
--
instance StateActivityIF DebugRunStateData HdaInternalLoadRequest where
  action :: AppState DebugRunStateData
-> Request HdaInternalLoadRequest
-> AppContext (Maybe StateTransit)
action AppState DebugRunStateData
_ (InternalLoadRequest HdaInternalLoadRequest
req) = do
    IO () -> AppContext ()
forall a. IO a -> StateT AppStores (ExceptT ErrMsg IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppContext ()) -> IO () -> AppContext ()
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 InternalLoadRequest called. " ErrMsg -> ErrMsg -> ErrMsg
forall a. [a] -> [a] -> [a]
++ HdaInternalLoadRequest -> ErrMsg
forall a. Show a => a -> ErrMsg
show HdaInternalLoadRequest
req
    ErrMsg -> AppContext ()
SU.loadHsFile (ErrMsg -> AppContext ()) -> ErrMsg -> AppContext ()
forall a b. (a -> b) -> a -> b
$ HdaInternalLoadRequest -> ErrMsg
pathHdaInternalLoadRequest HdaInternalLoadRequest
req
    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 -> AppContext (Maybe StateTransit))
-> Maybe StateTransit -> AppContext (Maybe StateTransit)
forall a b. (a -> b) -> a -> b
$ StateTransit -> Maybe StateTransit
forall a. a -> Maybe a
Just StateTransit
DebugRun_Contaminated