content: {-# 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 DebugRunState = do
      liftIO $ L.debugM _LOG_APP "DebugRunState entryAction called."
      goEntry
  
    -- |
    --
    exitAction DebugRunState = do
      liftIO $ L.debugM _LOG_APP "DebugRunState exitAction called."
      return ()
  
  
    -- |
    --
    doActivity s (WrapRequest r@InitializeRequest{})              = action s r
    doActivity s (WrapRequest r@LaunchRequest{})                  = action s r
    doActivity s (WrapRequest r@DisconnectRequest{})              = action s r
    doActivity s (WrapRequest r@PauseRequest{})                   = action s r
    doActivity s (WrapRequest r@TerminateRequest{})               = action s r
    doActivity s (WrapRequest r@SetBreakpointsRequest{})          = action s r
    doActivity s (WrapRequest r@SetFunctionBreakpointsRequest{})  = action s r
    doActivity s (WrapRequest r@SetExceptionBreakpointsRequest{}) = action s r
    doActivity s (WrapRequest r@ConfigurationDoneRequest{})       = action s r
    doActivity s (WrapRequest r@ThreadsRequest{})                 = action s r
    doActivity s (WrapRequest r@StackTraceRequest{})              = action s r
    doActivity s (WrapRequest r@ScopesRequest{})                  = action s r
    doActivity s (WrapRequest r@VariablesRequest{})               = action s r
    doActivity s (WrapRequest r@SourceRequest{})                  = action s r
    doActivity s (WrapRequest r@ContinueRequest{})                = action s r
    doActivity s (WrapRequest r@NextRequest{})                    = action s r
    doActivity s (WrapRequest r@StepInRequest{})                  = action s r
    doActivity s (WrapRequest r@EvaluateRequest{})                = action s r
    doActivity s (WrapRequest r@CompletionsRequest{})             = action s r
    doActivity s (WrapRequest r@InternalTransitRequest{})         = action s r
    doActivity s (WrapRequest r@InternalTerminateRequest{})       = action s r
    doActivity s (WrapRequest r@InternalLoadRequest{})            = action s 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 = view stopOnEntryAppStores <$> get >>= \case
    True  -> stopOnEntry
    False -> startDebug
  
  -- |
  --
  stopOnEntry :: AppContext ()
  stopOnEntry = do
    startupFile <- view startupAppStores <$> get
    startupFunc <- view startupFuncAppStores <$> get
  
    let funcName = if null startupFunc then "main" else startupFunc
        funcBp   = (startupFile, DAP.FunctionBreakpoint funcName Nothing Nothing)
        cmd = ":dap-set-function-breakpoint " ++ U.showDAP funcBp
  
    P.command cmd
    res <- P.expectPmpt
  
    withAdhocAddDapHeader $ filter (U.startswith _DAP_HEADER) res
  
    where
      -- |
      --
      withAdhocAddDapHeader :: [String] -> AppContext ()
      withAdhocAddDapHeader [] = do
        U.warnEV _LOG_APP $ "can not set func breakpoint. no dap header found."
        startDebug
      withAdhocAddDapHeader (str:[]) = case R.readEither (drop (length _DAP_HEADER) str) of
        Left err -> do
          U.warnEV _LOG_APP $ "read response body failed. " ++ err ++ " : " ++ str
          startDebug
        Right (Left err) -> do
          U.warnEV _LOG_APP $ "set adhoc breakpoint failed. " ++ err ++ " : " ++ str
          startDebug
        Right (Right bp) -> do
          startDebug
          adhocDelBreakpoint bp
      withAdhocAddDapHeader _ = do
        U.warnEV _LOG_APP $ "can not set func breakpoint. ambiguous dap header found."
        startDebug
  
      -- |
      --
      adhocDelBreakpoint :: DAP.Breakpoint -> AppContext ()
      adhocDelBreakpoint bp = do
        let cmd = ":dap-delete-breakpoint " ++ U.showDAP bp
  
        P.command cmd
        res <- P.expectPmpt
  
        withAdhocDelDapHeader $ filter (U.startswith _DAP_HEADER) res
  
      -- |
      --
      withAdhocDelDapHeader :: [String] -> AppContext ()
      withAdhocDelDapHeader [] = throwError $ "can not del func breakpoint. no dap header found."
      withAdhocDelDapHeader (str:[]) = case R.readEither (drop (length _DAP_HEADER) str) of
        Left err -> throwError $ "read response body failed. " ++ err ++ " : " ++ str
        Right (Left err) -> throwError $ "del adhoc breakpoint failed. " ++ err ++ " : " ++ str
        Right (Right res) -> return res
      withAdhocDelDapHeader _ = throwError $ "can not del func breakpoint. ambiguous dap header found."
  
  
  -- |
  --
  startDebug :: AppContext ()
  startDebug = do
    expr <- getTraceExpr
    let args = DAP.defaultContinueRequestArguments {
               DAP.exprContinueRequestArguments = Just expr
             }
  
    startDebugDAP args
  
    where
      getTraceExpr = view startupFuncAppStores <$> get >>= \case
        [] -> return "main"
        func -> do
          funcArgs <- view startupArgsAppStores <$> get
          return $ U.strip $ func ++ " " ++ funcArgs
  
      startDebugDAP args = do
  
        let dap = ":dap-continue "
            cmd = dap ++ U.showDAP args
            dbg = dap ++ show args
  
        P.command cmd
        U.debugEV _LOG_APP dbg
        P.expectPmpt >>= SU.takeDapResult >>= dapHdl
  
        return ()
  
      -- |
      --
      dapHdl :: String -> AppContext ()
      dapHdl str = case R.readEither str of
        Left err -> errHdl str err
        Right (Left err) -> errHdl str err
        Right (Right body) -> U.handleStoppedEventBody body
  
      -- |
      --
      errHdl :: String -> String -> AppContext()
      errHdl str err = do
        let msg = "start debugging failed. " ++ err ++ " : " ++ str
        liftIO $ L.errorM _LOG_APP msg
        U.sendErrorEventLF msg
  
  
  -- |
  --  Any errors should be sent back as False result Response
  --
  instance StateActivityIF DebugRunStateData DAP.SetBreakpointsRequest where
    action _ (SetBreakpointsRequest req) = do
      liftIO $ L.debugM _LOG_APP $ "DebugRunState SetBreakpointsRequest called. " ++ show req
      SU.setBreakpointsRequest req
  
  -- |
  --  Any errors should be sent back as False result Response
  --
  instance StateActivityIF DebugRunStateData DAP.SetExceptionBreakpointsRequest where
    action _ (SetExceptionBreakpointsRequest req) = do
      liftIO $ L.debugM _LOG_APP $ "DebugRunState SetExceptionBreakpointsRequest called. " ++ show req
      SU.setExceptionBreakpointsRequest req
  
  -- |
  --  Any errors should be sent back as False result Response
  --
  instance StateActivityIF DebugRunStateData DAP.SetFunctionBreakpointsRequest where
    action _ (SetFunctionBreakpointsRequest req) = do
      liftIO $ L.debugM _LOG_APP $ "DebugRunState SetFunctionBreakpointsRequest called. " ++ show req
      SU.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 _ (EvaluateRequest req) = do
      liftIO $ L.debugM _LOG_APP $ "DebugRunState EvaluateRequest called. " ++ show req
      SU.evaluateRequest req
  
  -- |
  --  Any errors should be sent back as False result Response
  --
  instance StateActivityIF DebugRunStateData DAP.CompletionsRequest where
    action _ (CompletionsRequest req) = do
      liftIO $ L.debugM _LOG_APP $ "DebugRunState CompletionsRequest called. " ++ show req
      SU.completionsRequest req
  
  -- |
  --   default nop.
  --
  instance StateActivityIF DebugRunStateData HdaInternalTransitRequest
  
  -- |
  --  Any errors should be sent back as False result Response
  --
  instance StateActivityIF DebugRunStateData HdaInternalLoadRequest where
    action _ (InternalLoadRequest req) = do
      liftIO $ L.debugM _LOG_APP $ "DebugRunState InternalLoadRequest called. " ++ show req
      SU.loadHsFile $ pathHdaInternalLoadRequest req
      return $ Just DebugRun_Contaminated
  
  