{-# LANGUAGE LambdaCase #-}

module Haskell.DAP.GHCi.Command where

import qualified GHC
import HscTypes
import Outputable
import PprTyThing
import Debugger
import Exception
import FastString
import DataCon
import DynFlags
import RtClosureInspect
import qualified GHCi.UI as G
import qualified GHCi.UI.Monad as G hiding (runStmt)

import Control.DeepSeq (deepseq)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Concurrent
import Control.Monad

import qualified Data.Map as M
import qualified Data.List as L

import System.Console.Haskeline

import qualified GHCi.DAP.IFData as D
import Haskell.DAP.GHCi.Type
import Haskell.DAP.GHCi.Constant
import Haskell.DAP.GHCi.Utility


-- |
--
dapCommands :: MVar DAPContext -> [G.Command]
dapCommands ctx = map mkCmd [
    ("dap-echo",            dapEcho,                                   noCompletion)
  , ("dap-scopes",          dapCmdRunner dapScopesCommand ctx,         noCompletion)
  , ("dap-set-breakpoints", dapCmdRunner dapSetBreakpointsCommand ctx, noCompletion)
  , ("dap-set-function-breakpoints"
                  , dapCmdRunner dapSetFunctionBreakpointsCommand ctx, noCompletion)
  , ("dap-continue",        dapCmdRunner dapContinueCommand ctx,       noCompletion)
  , ("dap-next",            dapCmdRunner dapNextCommand ctx,           noCompletion)
  , ("dap-step-in",         dapCmdRunner dapStepInCommand ctx,         noCompletion)
  , ("dap-stacktrace",      dapCmdRunner dapStackTraceCommand ctx,     noCompletion)
  , ("dap-variables",       dapCmdRunner dapVariablesCommand ctx,      noCompletion)
  , ("dap-evaluate",        dapCmdRunner dapEvaluateCommand ctx,       noCompletion)
  ]
  where
    mkCmd (n,a,c) = G.Command { G.cmdName = n
                              , G.cmdAction = a
                              , G.cmdHidden = False
                              , G.cmdCompletionFunc = c
                              }


-- |
--
dapCmdRunner :: (MVar DAPContext -> String -> G.GHCi ())
             ->  MVar DAPContext -> String -> InputT G.GHCi Bool
dapCmdRunner cmd ctxMVar str = do
  
  lift $ cmd ctxMVar str

  liftIO $ putStrLn _DAP_CMD_END

  return False


------------------------------------------------------------------------------------------------
--  DAP Command :dap-echo
------------------------------------------------------------------------------------------------

-- |
--
dapEcho :: String -> InputT G.GHCi Bool
dapEcho str = do
  liftIO $ putStrLn $ "[DAP][INFO] dap-echo \"" ++ str ++ "\""
  return False


------------------------------------------------------------------------------------------------
--  DAP Command :dap-scopes
------------------------------------------------------------------------------------------------

-- |
--
dapScopesCommand :: MVar DAPContext -> String -> G.GHCi ()
dapScopesCommand ctxMVar argsStr = do
  res <- withArgs (readDAP argsStr) 
  printDAP res
  
  where
    withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++  err ++ " : " ++ argsStr
    withArgs (Right args) = do
      let idx  = D.frameIdScopesArguments args
      getScopesBody idx

    -- |
    --
    getScopesBody :: Int -> G.GHCi (Either String D.ScopesBody)
    getScopesBody curIdx = do
      -- liftIO $ putStrLn $ "[DAP][getScopesBody] frame id." ++ frameIdStr
      oldIdx <- liftIO $ frameIdDAPContext <$> readMVar ctxMVar
      let moveIdx = curIdx - oldIdx

      tyThings <- withMoveIdx moveIdx

      -- liftIO $ putStrLn $ "[DAP][getScopesBody] tyThings count." ++ show (length tyThings)
      ctx <- liftIO $ takeMVar ctxMVar
      liftIO $ putMVar ctxMVar ctx {
        variableReferenceMapDAPContext = M.empty
        , bindingDAPContext = tyThings
        , frameIdDAPContext = curIdx
        }
    
      return $ Right D.ScopesBody {
        D.scopesScopesBody = [
          D.defaultScope{
              D.nameScope = _GHCi_SCOPE
            , D.variablesReferenceScope = 1
            , D.namedVariablesScope = Nothing
            , D.indexedVariablesScope = Nothing
            , D.expensiveScope = False
            }
          ]
        }

    -- |
    --
    withMoveIdx moveIdx
      | 0 == moveIdx = GHC.getBindings
      | 0 < moveIdx = back moveIdx
      | otherwise = forward moveIdx
  
    -- |
    --
    back num = do
      (names, _, _, _) <- GHC.back num
      st <- G.getGHCiState
      enqueueCommands [G.stop st]

      foldM withName [] $ reverse names

      
    -- |
    --
    forward num = do
      (names, _, _, _) <- GHC.forward num
      st <- G.getGHCiState
      enqueueCommands [G.stop st]

      foldM withName [] $ reverse names
           
    -- |
    --
    enqueueCommands :: [String] -> G.GHCi ()
    enqueueCommands cmds = do
      -- make sure we force any exceptions in the commands while we're
      -- still inside the exception handler, otherwise bad things will
      -- happen (see #10501)
      cmds `deepseq` return ()
      G.modifyGHCiState $ \st -> st{ G.cmdqueue = cmds ++ G.cmdqueue st }

    -- |
    --
    withName acc n = GHC.lookupName n >>= \case
      Just ty -> return (ty : acc)
      Nothing ->  do
        dflags <- getDynFlags
        liftIO $ putStrLn $ "[DAP][ERROR][getScopesBody] variable not found. " ++ showSDoc dflags (ppr n)
        return acc

      
------------------------------------------------------------------------------------------------
--  DAP Command :dap-set-breakpoints
------------------------------------------------------------------------------------------------

-- |
--
dapSetBreakpointsCommand :: MVar DAPContext -> String -> G.GHCi ()
dapSetBreakpointsCommand ctxMVar argsStr = do
  res <- withArgs (readDAP argsStr) 
  printDAP res

  where
    -- |
    --
    withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++  err ++ " : " ++ argsStr
    withArgs (Right args) = getModule args >>= \case
      Left msg  -> return $ Left msg
      Right mod -> do      
        deleteBreakpoints mod
      
        addBreakpoints args mod


    -- |
    --
    getModule args = do
      let srcInfo = D.sourceSetBreakpointsArguments args
          srcPath = D.pathSource srcInfo

      modSums <- G.getLoadedModules
      let modPaths = map takeModPath modSums

      case filter (isPathMatch srcPath) modPaths of
        ((m, p):[]) -> do
          liftIO $ putStrLn $ "[DAP][INFO][dapSetBreakpointsCommand] " ++ p ++ " -> " ++ m
          return $ Right m
        _ -> return $ Left $ "[DAP][ERROR] loaded module can not find from path. <" ++ srcPath ++ "> " ++  show modPaths


    -- |
    --
    deleteBreakpoints :: ModuleName -> G.GHCi ()
    deleteBreakpoints mod = do
      bps <- liftIO $ getDelBPs mod

      liftIO $ putStrLn $ "[DAP][INFO][dapSetBreakpointsCommand] delete src bps " ++ show bps

      mapM_ delBreakpoint bps
      
    -- |
    --
    getDelBPs :: ModuleName -> IO [Int]
    getDelBPs mod = do
      ctx <- takeMVar ctxMVar

      let bpNOs = M.keys $ M.filter ((isModuleMatch mod)) $ srcBPsDAPContext ctx
          newSrcBPs = M.filter (not . (isModuleMatch mod)) $ srcBPsDAPContext ctx

      putMVar ctxMVar $ ctx {srcBPsDAPContext = newSrcBPs} 

      return bpNOs

    -- |
    --
    isModuleMatch :: ModuleName -> SourceBreakpointInfo -> Bool
    isModuleMatch mod bpInfo = mod == modNameSourceBreakpointInfo bpInfo


    -- |
    --
    takeModPath ms = (GHC.moduleNameString (GHC.ms_mod_name ms), GHC.ms_hspp_file ms)

    -- |
    --
    isPathMatch srcPath (_, p) = (nzPath srcPath) == (nzPath p)

    -- |
    --
    addBreakpoints :: D.SetBreakpointsArguments -> ModuleName -> G.GHCi (Either String D.SetBreakpointsResponseBody)
    addBreakpoints args mod = do
      let srcBPs = D.breakpointsSetBreakpointsArguments args

      addBps <- mapM (addBP mod) srcBPs

      liftIO $ updateBpCtx addBps

      return $ Right $ D.SetBreakpointsResponseBody $ map takeBp addBps
    
    -- |
    --
    addBP :: String -> D.SourceBreakpoint -> G.GHCi (ModuleName, D.SourceBreakpoint, D.Breakpoint)
    addBP mod srcBP = do
      let lineNo   = show $ D.lineSourceBreakpoint srcBP
          colNo    = maybe "" show $ D.columnSourceBreakpoint srcBP
          argStr   = mod ++ " " ++ lineNo ++ " " ++ colNo

      bp <- addBreakpoint argStr

      return (mod, srcBP, bp)

    -- |
    --
    updateBpCtx :: [(ModuleName, D.SourceBreakpoint, D.Breakpoint)] -> IO ()
    updateBpCtx bps = do
      ctx <- takeMVar ctxMVar
      let cur = srcBPsDAPContext ctx
          new = M.fromList $ foldr convSrcBps [] bps
      putMVar ctxMVar $ ctx{srcBPsDAPContext = (M.union cur new)}

    -- |
    --
    convSrcBps :: (ModuleName, D.SourceBreakpoint, D.Breakpoint)
               -> [(Int, SourceBreakpointInfo)]
               -> [(Int, SourceBreakpointInfo)]
    convSrcBps (mod, srcBp, bp) acc = case D.idBreakpoint bp of
      Nothing -> acc
      Just no -> (no, SourceBreakpointInfo mod srcBp 0) : acc 

    -- |
    --
    takeBp :: (ModuleName, D.SourceBreakpoint, D.Breakpoint) -> D.Breakpoint
    takeBp (_, _, bp) = bp


------------------------------------------------------------------------------------------------
--  DAP Command :dap-set-function-breakpoints
------------------------------------------------------------------------------------------------

-- |
--
dapSetFunctionBreakpointsCommand :: MVar DAPContext -> String -> G.GHCi ()
dapSetFunctionBreakpointsCommand ctxMVar argsStr = do
  res <- withArgs (readDAP argsStr) 
  printDAP res

  where
    withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++  err ++ " : " ++ argsStr
    withArgs (Right args) =  deleteBreakpoints
                          >> addBreakpoints args
      
    -- |
    --
    deleteBreakpoints :: G.GHCi ()
    deleteBreakpoints = do
      bps <- liftIO $ getDelBPs

      liftIO $ putStrLn $ "[DAP][INFO][dapSetFunctionBreakpointsCommand] delete func bps " ++ show bps

      mapM_ delBreakpoint bps
      
    -- |
    --
    getDelBPs :: IO [Int]
    getDelBPs = do
      ctx <- takeMVar ctxMVar

      let bpNOs = M.keys $ funcBPsDAPContext ctx

      putMVar ctxMVar $ ctx {funcBPsDAPContext = M.fromList []} 

      return bpNOs

    -- |
    --
    addBreakpoints :: D.SetFunctionBreakpointsArguments -> G.GHCi (Either String D.SetFunctionBreakpointsResponseBody)
    addBreakpoints args = do
      let funcBPs = D.breakpointsSetFunctionBreakpointsArguments args

      addBps <- mapM addBP funcBPs

      liftIO $ updateBpCtx addBps

      return $ Right $ D.SetFunctionBreakpointsResponseBody $ map snd addBps
    
    -- |
    --
    addBP :: D.FunctionBreakpoint -> G.GHCi (D.FunctionBreakpoint, D.Breakpoint)
    addBP funcBP = do
      let argStr = D.nameFunctionBreakpoint funcBP

      bp <- addBreakpoint argStr

      return (funcBP, bp)

    -- |
    --
    updateBpCtx :: [(D.FunctionBreakpoint, D.Breakpoint)] -> IO ()
    updateBpCtx bps = do
      ctx <- takeMVar ctxMVar
      let new = foldr getBpNo [] bps

      putMVar ctxMVar $ ctx{funcBPsDAPContext = M.fromList new}

    -- |
    --
    getBpNo :: (D.FunctionBreakpoint, D.Breakpoint) -> [(Int, (D.FunctionBreakpoint, Int))] -> [(Int, (D.FunctionBreakpoint, Int))]
    getBpNo (funcBP, bp) acc = case D.idBreakpoint bp of
      Nothing -> acc
      Just no -> (no, (funcBP, 0)) : acc 


------------------------------------------------------------------------------------------------

-- |
--
delBreakpoint :: Int -> G.GHCi Bool
delBreakpoint bpNoStr = do
  curSt <- G.getGHCiState
  let curCount = G.break_ctr curSt

  G.deleteCmd (show bpNoStr)
  
  newSt <- G.getGHCiState
  let newCount = G.break_ctr newSt
  
  return (newCount == curCount - 1)


-- |
--
addBreakpoint :: String -> G.GHCi D.Breakpoint
addBreakpoint argStr = do
  curSt <- G.getGHCiState
  let curCount = G.break_ctr curSt

  G.breakCmd argStr
  
  newSt <- G.getGHCiState
  let newCount = G.break_ctr newSt
      isAdded = (newCount == curCount + 1)
      locMay  =  if isAdded then Just (head (G.breaks newSt)) else Nothing
  
  withBreakLoc locMay

  where
    withBreakLoc (Just (no, bpLoc))= withSrcSpan no bpLoc (G.breakLoc bpLoc)
    withBreakLoc Nothing = return D.defaultBreakpoint {
        D.verifiedBreakpoint = False
      , D.messageBreakpoint  = "[DAP][ERROR]set breakpoint seems to be failed."
      }

    withSrcSpan no bpLoc (GHC.RealSrcSpan dat) = return
      D.defaultBreakpoint {
        D.idBreakpoint        = Just no
      , D.verifiedBreakpoint  = True
      , D.sourceBreakpoint    = D.defaultSource {
          D.nameSource             = (Just . GHC.moduleNameString . GHC.moduleName . G.breakModule) bpLoc
        , D.pathSource             = (unpackFS . GHC.srcSpanFile) dat
        , D.sourceReferenceSource  = Nothing
        , D.origineSource          = Nothing
        }
      , D.lineBreakpoint      = GHC.srcSpanStartLine dat
      , D.columnBreakpoint    = GHC.srcSpanStartCol dat
      , D.endLineBreakpoint   = GHC.srcSpanEndLine dat
      , D.endColumnBreakpoint = GHC.srcSpanEndCol dat
      }

    withSrcSpan _ _ (GHC.UnhelpfulSpan _) = return D.defaultBreakpoint {
        D.verifiedBreakpoint = False
      , D.messageBreakpoint  = "[DAP][ERROR] UnhelpfulSpan breakpoint."
      }


------------------------------------------------------------------------------------------------
--  DAP Command :dap-continue
------------------------------------------------------------------------------------------------

-- |
--
dapContinueCommand :: MVar DAPContext -> String -> G.GHCi ()
dapContinueCommand mvarCtx argsStr =   withArgs (readDAP argsStr) 
                                   >>= withStopResult

  where
  
    -- |
    --
    withArgs :: Either String D.ContinueArguments -> G.GHCi (Either String D.StoppedEventBody)
    withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++  err ++ " : " ++ argsStr
    withArgs (Right args) = case  D.exprContinueArguments args of
      Just expr -> runWithStmtTrace expr
      Nothing   -> runNoStmtTrace


    -- |
    --
    runWithStmtTrace expr = do
      clearTmpDAPContext

      G.traceCmd expr

      ctx <- liftIO $ readMVar mvarCtx
      withStmtTraceResults $ traceCmdExecResultDAPContext ctx


    -- |
    --
    withStmtTraceResults [] = return $ Left $ "[DAP][ERROR] invalid trace arg result."
    withStmtTraceResults (res:[]) = withStmtTraceResult res
    withStmtTraceResults (res:_) = do
      liftIO $ putStrLn $ "[DAP][WARN] two or more trace arg results. use first result. "
      withStmtTraceResult res
    

    -- |
    --
    withStmtTraceResult (Just res) = withExecResult mvarCtx "breakpoint" res
    withStmtTraceResult Nothing = do
      -- runStmt expr error occurred.
      msg <- getRunStmtSourceError
      return $ Left $ msg


    -- |
    --
    runNoStmtTrace = do
      clearTmpDAPContext

      G.traceCmd ""

      ctx <- liftIO $ readMVar mvarCtx
      withNoStmtTraceResults $ doContinueExecResultDAPContext ctx


    -- |
    --
    withNoStmtTraceResults [] = return $ Left $ "[DAP][ERROR] invalid trace no arg result."
    withNoStmtTraceResults (res:[]) = withExecResult mvarCtx "breakpoint" res
    withNoStmtTraceResults (res:_) = do
      liftIO $ putStrLn $ "[DAP][WARN] two or more trace no arg results. use first result. "
      withExecResult mvarCtx "breakpoint" res


    -- |
    --
    withStopResult :: Either String D.StoppedEventBody -> G.GHCi ()
    withStopResult res@(Right D.StoppedEventBody{D.reasonStoppedEventBody = "breakpoint"}) = breakthrough res
    withStopResult res = printDAP res


    -- |
    --
    breakthrough :: Either String D.StoppedEventBody -> G.GHCi ()
    breakthrough res = isBreakthrough >>= \case
      False -> printDAP res
      True  -> runNoStmtTrace >>= withStopResult


    -- |
    --
    isBreakthrough :: G.GHCi Bool
    isBreakthrough = GHC.getResumeContext >>= withResumes

    -- |
    --   @return
    --    True  -> thruough
    --    False -> break
    --
    withResumes :: [GHC.Resume] -> G.GHCi Bool
    withResumes [] = do
      liftIO $ putStrLn "[DAP][WARN] invalid resume state."
      return False

    withResumes (r:_) =   pure (GHC.resumeBreakInfo r)
                      >>= G.toBreakIdAndLocation
                      >>= withBreakInfo

    -- |
    --   @return
    --    True  -> thruough
    --    False -> break
    --
    withBreakInfo ::  Maybe (Int, G.BreakLocation) -> G.GHCi Bool
    withBreakInfo Nothing = do
      liftIO $ putStrLn "[DAP][WARN] invalid resume break info state."
      return False

    withBreakInfo (Just (no, _)) = findSrcBP no >>= \case
      Just srcBP -> withSrcBP no srcBP
      Nothing    -> findFuncBP no >>= \case
        Just fncBP -> withFuncBP no fncBP
        Nothing    -> do
          liftIO $ putStrLn $ "[DAP][WARN] invalid break no. " ++ show no
          return False

    -- |
    --
    findSrcBP no = do
      srcBPs <- liftIO $ srcBPsDAPContext <$> readMVar mvarCtx
      return $ M.lookup no srcBPs

    -- |
    --
    findFuncBP no = do
      funcBPs <- liftIO $ funcBPsDAPContext <$> readMVar mvarCtx
      return $ M.lookup no funcBPs

    -- |
    --   @return
    --    True  -> thruough
    --    False -> break
    --
    withSrcBP :: Int -> SourceBreakpointInfo -> G.GHCi Bool
    withSrcBP no bpInfo = 
      let bpCond = D.conditionSourceBreakpoint (srcBPSourceBreakpointInfo bpInfo)
          bpLog  = D.logMessageSourceBreakpoint (srcBPSourceBreakpointInfo bpInfo)
      in
        srcBreakthroughCounterHandler no bpInfo >>= \case
          Just res -> return res
          Nothing -> breakthroughCondtionHandler no bpCond >>= \case
            Just res -> return res
            Nothing -> logPointHandler no bpLog >>= \case
              Just res -> return res
              Nothing  -> return False


    -- |
    --   @return
    --    True  -> thruough
    --    False -> break
    --
    withFuncBP no bpInfo = 
      let bpCond = D.conditionFunctionBreakpoint (fst bpInfo)
      in
        funcBreakthroughCounterHandler no bpInfo >>= \case
          Just res -> return res
          Nothing -> breakthroughCondtionHandler no bpCond >>= \case
            Just res -> return res
            Nothing  -> return False

    -- |
    --
    srcBreakthroughCounterHandler :: Int -> SourceBreakpointInfo -> G.GHCi (Maybe Bool)
    srcBreakthroughCounterHandler _ SourceBreakpointInfo {
                                      srcBPSourceBreakpointInfo = D.SourceBreakpoint {
                                        D.hitConditionSourceBreakpoint = Nothing
                                      }
                                    } = return Nothing
    srcBreakthroughCounterHandler no bpInfo@SourceBreakpointInfo {
                                              srcBPSourceBreakpointInfo = D.SourceBreakpoint {
                                                  D.hitConditionSourceBreakpoint = Just condStr
                                              }
                                            , hitCntSourceBreakpointInfo = curCnt} = do
      let newCnt = curCnt + 1
          stmt   = "let _CNT = " ++ show newCnt ++ " in " ++ condStr

      liftIO $ updateSrcBreakCounter no bpInfo{hitCntSourceBreakpointInfo = newCnt}

      runStmtDAP mvarCtx False stmt >>= \case
        Left  err -> do
          liftIO $ putStrLn $ "[DAP][ERROR] hit condition statement fail. " ++ stmt ++ " -> " ++ err
          return $ Just False
        Right res -> do
          liftIO $ putStrLn $ "[DAP][INFO] hit condition statement result. " ++ stmt ++ " -> " ++ show res
          return $ Just ("False" == D.resultEvaluateBody res)

    -- |
    --
    updateSrcBreakCounter no bpInfo = do
      ctx <- takeMVar mvarCtx
      let cur = srcBPsDAPContext ctx
          new = M.insert no bpInfo cur
      putMVar mvarCtx ctx{srcBPsDAPContext = new}


    -- |
    --
    funcBreakthroughCounterHandler :: Int -> (D.FunctionBreakpoint, Int) -> G.GHCi (Maybe Bool)
    funcBreakthroughCounterHandler _ (D.FunctionBreakpoint{D.hitConditionFunctionBreakpoint = Nothing}, _) = return Nothing
    funcBreakthroughCounterHandler no info@(D.FunctionBreakpoint{D.hitConditionFunctionBreakpoint = Just condStr}, curCnt) = do
      let newCnt = curCnt + 1
          stmt   = "let _CNT = " ++ show newCnt ++ " in " ++ condStr

      liftIO $ updateFuncBreakCounter no (fst info, newCnt)

      runStmtDAP mvarCtx False stmt >>= \case
        Left  err -> do
          liftIO $ putStrLn $ "[DAP][ERROR] hit condition statement fail. " ++ stmt ++ " -> " ++ err
          return $ Just False
        Right res -> do
          when ("Bool" /= D.typeEvaluateBody res) $
            liftIO $ putStrLn $ "[DAP][INFO] hit condition statement result type is not Bool. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ show res
          return $ Just ("False" == D.resultEvaluateBody res)


    -- |
    --
    updateFuncBreakCounter no bpInfo = do
      ctx <- takeMVar mvarCtx
      let cur = funcBPsDAPContext ctx
          new = M.insert no bpInfo cur
      putMVar mvarCtx ctx{funcBPsDAPContext = new}

    -- |
    --   @return
    --     True  -> breakthrough
    --     False -> break
    --
    breakthroughCondtionHandler :: Int -> Maybe String -> G.GHCi (Maybe Bool)
    breakthroughCondtionHandler _ Nothing = return Nothing
    breakthroughCondtionHandler no (Just stmt) = runStmtDAP mvarCtx False stmt >>= \case
      Left  err -> do
        liftIO $ putStrLn $ "[DAP][ERROR] condition statement fail. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ err
        return $ Just False
      Right res -> do
        when ("Bool" /= D.typeEvaluateBody res) $
          liftIO $ putStrLn $ "[DAP][ERROR] condition statement result type is not Bool. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ show res
        return $ Just ("False" == D.resultEvaluateBody res)

    -- |
    --   @return
    --     must be True -> breakthrough
    -- 
    logPointHandler :: Int -> Maybe String -> G.GHCi (Maybe Bool)
    logPointHandler _ Nothing = return Nothing
    logPointHandler no (Just stmt) = runStmtDAP mvarCtx False stmt >>= \case
      Left err -> do
        let msg = "[DAP][ERROR] log statement fail. BPNO:" ++ show no ++ " " ++ stmt ++ " -> " ++ err
            body = D.defaultOutputEventBody { D.outputOutputEventBody = msg
                                            , D.categoryOutputEventBody = "stderr" }
        liftIO $ putStrLn msg

        printOutputEventDAP (Right body)
        
        return $ Just False

      Right res -> do
        let body = D.defaultOutputEventBody {D.outputOutputEventBody = D.resultEvaluateBody res}

        printOutputEventDAP (Right body)

        return $ Just True


-- |
--
withExecResult :: MVar DAPContext -> String-> GHC.ExecResult -> G.GHCi (Either String D.StoppedEventBody)
withExecResult _ _ (GHC.ExecComplete { GHC.execResult = Right _ }) = do
  return $  Right D.defaultStoppedEventBody {
              D.reasonStoppedEventBody = "complete"
            }
  
withExecResult _ _ (GHC.ExecComplete { GHC.execResult = Left (SomeException e)}) = do
  return $  Right D.defaultStoppedEventBody {
              D.reasonStoppedEventBody = "complete"
            , D.descriptionStoppedEventBody = show e
            , D.textStoppedEventBody = show e
            }

withExecResult _ reason (GHC.ExecBreak{GHC.breakInfo = Just _}) = do
  return $   Right D.defaultStoppedEventBody {
              D.reasonStoppedEventBody = reason
            }

withExecResult mvarCtx _ (GHC.ExecBreak{GHC.breakInfo = Nothing}) = do
  let key = "_exception"
  --runStmtDAP mvarCtx False key >>= \case
  gcatch (GHC.parseName key) parseNameErrorHandler >>= names2EvalBody mvarCtx False key >>= \case
    Left  msg  -> return $ Left $ "[DAP][ERROR] invalid _exception result." ++ msg
    Right body -> return $ Right D.defaultStoppedEventBody {
        D.reasonStoppedEventBody = "exception"
      , D.descriptionStoppedEventBody = D.resultEvaluateBody body
      , D.textStoppedEventBody = D.resultEvaluateBody body
      }

{-do
  evalBody <- getEvalBody "_exception" True
  return $   Right D.defaultStoppedEventBody {
              D.reasonStoppedEventBody = "exception"
            , D.descriptionStoppedEventBody = D.resultEvaluateBody evalBody
            , D.textStoppedEventBody = D.resultEvaluateBody evalBody
            }
            -}




------------------------------------------------------------------------------------------------
--  DAP Command :dap-next
------------------------------------------------------------------------------------------------

-- |
--
dapNextCommand :: MVar DAPContext -> String -> G.GHCi ()
dapNextCommand mvarCtx argsStr = do
  res <- withArgs (readDAP argsStr)
  printDAP res

  where
    withArgs :: Either String D.NextArguments -> G.GHCi (Either String D.StoppedEventBody)
    withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++  err ++ " : " ++ argsStr
    withArgs (Right _) = do
      clearTmpDAPContext

      G.stepLocalCmd ""

      ctx <- liftIO $ readMVar mvarCtx
      withResults $ doContinueExecResultDAPContext ctx


    -- |
    --
    withResults [] = return $ Left $ "[DAP][ERROR] invalid stepLocalCmd result."
    withResults (res:[]) = withExecResult mvarCtx "step" res
    withResults (res:_) = do
      liftIO $ putStrLn $ "[DAP][WARN] two or more stepLocalCmd results. use first result. "
      withExecResult mvarCtx "step" res


------------------------------------------------------------------------------------------------
--  DAP Command :dap-step-in
------------------------------------------------------------------------------------------------

-- |
--
dapStepInCommand :: MVar DAPContext -> String -> G.GHCi ()
dapStepInCommand mvarCtx argsStr = do
  res <- withArgs (readDAP argsStr)
  printDAP res
  
  where
    withArgs :: Either String D.StepInArguments -> G.GHCi (Either String D.StoppedEventBody)
    withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++  err ++ " : " ++ argsStr
    withArgs (Right _) = do
      clearTmpDAPContext

      G.stepCmd ""

      ctx <- liftIO $ readMVar mvarCtx
      withResults $ doContinueExecResultDAPContext ctx


    -- |
    --
    withResults [] = return $ Left $ "[DAP][ERROR] invalid stepCmd result."
    withResults (res:[]) = withExecResult mvarCtx "step" res
    withResults (res:_) = do
      liftIO $ putStrLn $ "[DAP][WARN] two or more stepCmd results. use first result. "
      withExecResult mvarCtx "step" res


------------------------------------------------------------------------------------------------
--  DAP Command :dap-stacktrace
------------------------------------------------------------------------------------------------

-- |
--
dapStackTraceCommand :: MVar DAPContext -> String -> G.GHCi ()
dapStackTraceCommand ctxMVar argsStr = do
  
  ctx <- liftIO $ takeMVar ctxMVar
  liftIO $ putMVar ctxMVar ctx {frameIdDAPContext = 0}

  res <- withArgs (readDAP argsStr) 
  printDAP res
  
  where
    withArgs :: Either String D.StackTraceArguments -> G.GHCi (Either String D.StackTraceBody)
    withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++  err ++ " : " ++ argsStr
    withArgs (Right _) = GHC.getResumeContext >>= \case
      [] -> return $ Left "no stacktrace found."
      (r:_) -> withResume r

    withResume r = case isExceptionResume r of
      True -> do
        dflags <- G.getDynFlags
        let maxSize = GHC.ghciHistSize dflags
        -- liftIO $ putStrLn $ "[DAP][INFO] " ++ show maxSize

        traces <- mapM resumeHist2stackFrame $ take maxSize $ GHC.resumeHistory r

        return $ Right D.defaultStackTraceBody {
            D.stackFramesStackTraceBody = traces
          , D.totalFramesStackTraceBody = length traces
          }
      False -> do
        dflags <- G.getDynFlags
        let start  = resume2stackframe r
            maxSize = (GHC.ghciHistSize dflags) - 1
        -- liftIO $ putStrLn $ "[DAP][INFO] " ++ show maxSize

        hists <- mapM resumeHist2stackFrame $ take maxSize $ GHC.resumeHistory r
        
        let traces = start : hists

        return $ Right D.defaultStackTraceBody {
            D.stackFramesStackTraceBody = traces
          , D.totalFramesStackTraceBody = length traces
          }

    resume2stackframe r = D.defaultStackFrame {
        D.idStackFrame = 0
      , D.nameStackFrame = (getStackFrameTitle r)
      , D.sourceStackFrame = D.defaultSource {
          D.pathSource = getSrcPath (GHC.resumeSpan r)
        }
      , D.lineStackFrame = getStartLinet (GHC.resumeSpan r)
      , D.columnStackFrame = getStartCol (GHC.resumeSpan r)
      , D.endLineStackFrame = getEndLinet (GHC.resumeSpan r)
      , D.endColumnStackFrame = getEndCol (GHC.resumeSpan r)
      }
      
    getStackFrameTitle r =  maybe "unknown" (GHC.moduleNameString  . GHC.moduleName . GHC.breakInfo_module) (GHC.resumeBreakInfo r)
                         ++ "."
                         ++ GHC.resumeDecl r

    getSrcPath (GHC.RealSrcSpan dat) = (unpackFS . GHC.srcSpanFile) dat
    getSrcPath (GHC.UnhelpfulSpan _) = "UnhelpfulSpan"

    getStartLinet (GHC.RealSrcSpan dat) = GHC.srcSpanStartLine dat
    getStartLinet (GHC.UnhelpfulSpan _) = 0

    getStartCol (GHC.RealSrcSpan dat) = GHC.srcSpanStartCol dat
    getStartCol (GHC.UnhelpfulSpan _) = 0

    getEndLinet (GHC.RealSrcSpan dat) = GHC.srcSpanEndLine dat
    getEndLinet (GHC.UnhelpfulSpan _) = 0

    getEndCol (GHC.RealSrcSpan dat) = GHC.srcSpanEndCol dat
    getEndCol (GHC.UnhelpfulSpan _) = 0

    resumeHist2stackFrame hist = do
      span <- GHC.getHistorySpan hist
      return D.defaultStackFrame {
        D.idStackFrame = 0
      , D.nameStackFrame = L.intercalate ":" (GHC.historyEnclosingDecls hist)
      , D.sourceStackFrame = D.defaultSource {
          D.pathSource = getSrcPath span
        }
      , D.lineStackFrame = getStartLinet span
      , D.columnStackFrame = getStartCol span
      , D.endLineStackFrame = getEndLinet span
      , D.endColumnStackFrame = getEndCol span
      }
    


------------------------------------------------------------------------------------------------
--  DAP Command :dap-variables
------------------------------------------------------------------------------------------------

-- |
--
dapVariablesCommand :: MVar DAPContext -> String -> G.GHCi ()
dapVariablesCommand ctxMVar argsStr = do
  res <- withArgs (readDAP argsStr) 
  printDAP res

  where
    withArgs :: Either String D.VariablesArguments -> G.GHCi (Either String D.VariablesBody)
    withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++  err ++ " : " ++ argsStr
    withArgs (Right args) = do
      let idx  = D.variablesReferenceVariablesArguments args

      vals <- getBindingVariables ctxMVar idx

      return $ Right $ D.VariablesBody vals


-- |
--
getBindingVariables :: MVar DAPContext -> Int -> G.GHCi [D.Variable]
getBindingVariables ctx idx
  | 1 == idx = getBindingVariablesRoot ctx 
  | otherwise  = getBindingVariablesNode ctx idx


-- |
--
getBindingVariablesRoot :: MVar DAPContext -> G.GHCi [D.Variable]
getBindingVariablesRoot ctxMVar = do
  bindings <- liftIO $ bindingDAPContext <$> readMVar ctxMVar
  -- liftIO $ putStrLn $ "[DAP][INFO] bindings " ++ show (length bindings)

  mapM tyThing2Val bindings

  where
    -- |
    --  TyThings https://hackage.haskell.org/package/ghc-8.2.1/docs/HscTypes.html#t:TyThing
    --
    tyThing2Val (AnId i) = do
      let isForce = False
      GHC.obtainTermFromId maxBound isForce i >>= withTerm i
    tyThing2Val x = do
      dflags <- getDynFlags
      return D.defaultVariable {
        D.nameVariable  = showSDoc dflags (ppr x)
      , D.typeVariable  = "not yet supported tything."
      , D.valueVariable = "not yet supported tything."
      , D.evaluateNameVariable = Just (showSDoc dflags (ppr x))
      , D.variablesReferenceVariable = 0
      }

    -- |
    --  Term https://hackage.haskell.org/package/ghc-8.2.1/docs/RtClosureInspect.html
    --
    withTerm ::  GHC.Id -> Term -> G.GHCi D.Variable
    withTerm i t@(Term ty _ _ _) = do
      dflags <- getDynFlags
      -- liftIO $ putStrLn $ "[DAP][DEBUG]" ++ "   subTerms. [" ++ show (length subTerms) ++ "]"
      termSDoc <- gcatch (showTerm t) showTermErrorHandler
      let nameStr = showSDoc dflags (ppr i)
          typeStr = showSDoc dflags (pprTypeForUser ty)
          valStr  = showSDoc dflags termSDoc

      return D.defaultVariable {
        D.nameVariable  = nameStr
      , D.typeVariable  = typeStr
      , D.valueVariable = valStr
      , D.evaluateNameVariable = Just nameStr
      , D.variablesReferenceVariable = 0
      }
    withTerm i _ = do
      dflags <- getDynFlags
      idSDoc   <- pprTypeAndContents i
      let (nameStr, typeStr, valStr) = getNameTypeValue (showSDoc dflags idSDoc)
      return D.defaultVariable {
        D.nameVariable  = nameStr
      , D.typeVariable  = typeStr
      , D.valueVariable = valStr
      , D.evaluateNameVariable = Just nameStr
      , D.variablesReferenceVariable = 0
      }


-- |
--
getNextIdx :: MVar DAPContext -> Term -> String -> G.GHCi Int
getNextIdx ctxMVar t@(Term ty _ _ subTerms) str = getDynFlags >>= withDynFlags
  where
    withDynFlags dflags 
      | 0 == length subTerms = return 0
      | 1 == length subTerms && isPrim (head subTerms)  = return 0
      | "[Char]" == showSDoc dflags (pprTypeForUser ty) = return 0
      | "String" == showSDoc dflags (pprTypeForUser ty) = return 0
      | otherwise = liftIO $ addTerm2VariableReferenceMap ctxMVar t str

getNextIdx ctxMVar t str = liftIO $ addTerm2VariableReferenceMap ctxMVar t str


-- |
--
addTerm2VariableReferenceMap :: MVar DAPContext -> Term -> String -> IO Int
addTerm2VariableReferenceMap ctxMVar t str = do
  ctx <- takeMVar ctxMVar
  let curMap = variableReferenceMapDAPContext ctx
      nextId = (M.size curMap) + 2

  putMVar ctxMVar $ ctx {variableReferenceMapDAPContext = M.insert nextId (t, str) curMap}

  return nextId


-- |
--
getDataConstructor :: Term -> G.GHCi String
getDataConstructor (Term _ (Left dc) _ _) = return dc
getDataConstructor (Term _ (Right dc) _ _) = do
  dflags <- getDynFlags
  let conStr  = if isTupleDataCon dc then "Tuple" else showSDoc dflags $ ppr $ dataConName dc
      conStr' = if ":" == conStr then "List" else conStr
      typeStr = showSDoc dflags (pprTypeForUser (dataConRepType dc))
  return $ conStr' ++ " :: " ++ typeStr
getDataConstructor _ = return "[getDataConstructor] not supported type."



-- |
--
getBindingVariablesNode :: MVar DAPContext -> Int -> G.GHCi [D.Variable]
getBindingVariablesNode ctxMVar idx = do
  ctx <- liftIO $ readMVar ctxMVar
  case M.lookup idx (variableReferenceMapDAPContext ctx) of
    Just (t, str)  -> withTerm t str
    Nothing -> do
      liftIO $ putStrLn $ "[DAP][ERROR][getBindingVariablesNode] id not found. " ++ show idx
      return []

  where
    withTerm (Term _ (Right dc) _ subTerms) str = do
      let labels = if 0 == length (dataConFieldLabels dc)
                     then map (\i->"_" ++ show i) [1..(length subTerms)]
                     else map (unpackFS . flLabel) (dataConFieldLabels dc)
      mapM (withSubTerm str) $ zip labels subTerms

    withTerm (Term _ (Left _) _ subTerms) str = do
      let labels = map (\i->"_" ++ show i) [1..(length subTerms)]
      mapM (withSubTerm str) $ zip labels subTerms

    withTerm _ _ = do
      liftIO $ putStrLn $ "[DAP][ERROR][getBindingVariablesNode] invalid map term type. " ++ show idx
      return []

    withSubTerm evalStr (label, t@(Term ty _ _ _)) = do
      -- liftIO $ putStrLn $ "[DEBUG]" ++ "   subTerms. [" ++ show (length subTerms) ++ "]"
      termSDoc <- gcatch (showTerm t) showTermErrorHandler
      dflags <- getDynFlags

      let nameStr = label
          typeStr = showSDoc dflags (pprTypeForUser ty)
          valStr  = showSDoc dflags termSDoc

      nextIdx <- getNextIdx ctxMVar t evalStr
      valStr' <- if 0 == nextIdx then return valStr
                   else  getDataConstructor t
      return D.defaultVariable {
        D.nameVariable  = nameStr
      , D.typeVariable  = typeStr
      , D.valueVariable = valStr'
      , D.evaluateNameVariable = Just evalStr
      , D.variablesReferenceVariable = nextIdx
      }
    withSubTerm evalStr (label, (Prim ty val)) = do
      dflags <- getDynFlags
      return D.defaultVariable {
        D.nameVariable  = label
      , D.typeVariable  = showSDoc dflags (pprTypeForUser ty)
      , D.valueVariable = showSDoc dflags (ppr val)
      , D.evaluateNameVariable = Just evalStr
      , D.variablesReferenceVariable = 0
      }
    withSubTerm evalStr (label, (Suspension _ ty _ _)) = do
      dflags <- getDynFlags
      return D.defaultVariable {
        D.nameVariable  = label
      , D.typeVariable  = showSDoc dflags (pprTypeForUser ty)
      , D.valueVariable = "function :: " ++ showSDoc dflags (pprTypeForUser ty)
      , D.evaluateNameVariable = Just evalStr
      , D.variablesReferenceVariable = 0
      }
    withSubTerm evalStr (label, _) = return D.defaultVariable {
        D.nameVariable  = label
      , D.typeVariable  = "not supported subTerm."
      , D.valueVariable = "not supported subTerm."
      , D.evaluateNameVariable = Just evalStr
      , D.variablesReferenceVariable = 0
      }

------------------------------------------------------------------------------------------------
--  DAP Command :dap-evaluate
------------------------------------------------------------------------------------------------

-- |
--
dapEvaluateCommand :: MVar DAPContext -> String -> G.GHCi ()
dapEvaluateCommand ctxMVar argsStr = do
  res <- withArgs (readDAP argsStr) 
  printDAP res

  where
    -- |
    --
    withArgs :: Either String D.EvaluateArguments -> G.GHCi (Either String D.EvaluateBody)
    withArgs (Left err) = return $ Left $ "[DAP][ERROR] " ++  err ++ " : " ++ argsStr
    withArgs (Right args) = case D.contextEvaluateArguments args of
      "repl" -> runRepl args
      _      -> runOther args

    -- |
    --
    runRepl ::  D.EvaluateArguments -> G.GHCi (Either String D.EvaluateBody)
    runRepl args
      | null (D.expressionEvaluateArguments args) = return $ Right D.defaultEvaluateBody {
          D.resultEvaluateBody = "no input."
        , D.typeEvaluateBody   = "no input."
        , D.variablesReferenceEvaluateBody = 0
        }
      | otherwise = do
        let stmt = D.expressionEvaluateArguments args
            isRefable = True

        runStmtDAP ctxMVar isRefable stmt


    -- |
    --
    runOther ::  D.EvaluateArguments -> G.GHCi (Either String D.EvaluateBody)
    runOther args = do 
      let nameStr = D.expressionEvaluateArguments args
      names <- gcatch (GHC.parseName nameStr) parseNameErrorHandler
      names2EvalBody ctxMVar True nameStr names


-- |
--
runStmtDAP :: MVar DAPContext -> Bool -> String -> G.GHCi (Either String D.EvaluateBody)
runStmtDAP ctxMVar isRefable stmt = do
  clearTmpDAPContext

  G.runStmt stmt GHC.RunToCompletion >>= \case
    Nothing -> Left <$> getRunStmtSourceError
--    Just (GHC.ExecBreak _ Nothing) -> Left <$> getRunStmtSourceError
--    Just (GHC.ExecBreak names _)   -> names2EvalBody ctxMVar isRefable stmt names
    Just (GHC.ExecBreak _ _) -> return $ Left $ "[DAP][ERROR] unexpected break result. "
    Just (GHC.ExecComplete (Left msg) _) -> return $ Left $ "[DAP][ERROR] error runStmt result. " ++ show msg
    Just (GHC.ExecComplete (Right names) _) -> names2EvalBody ctxMVar isRefable stmt names
    

-- |
--
--
names2EvalBody :: MVar DAPContext -> Bool -> String -> [GHC.Name] -> G.GHCi (Either String D.EvaluateBody)
names2EvalBody ctxMVar isRefable key names
  | 0 == length names = return $ Left $ "Not in scope. " ++ key
  | 1 == length names = withName $ head names
  | otherwise = return $ Left $ "Ambiguous name. " ++ key

  where
    withName n = GHC.lookupName n >>= \case
      Nothing -> return $ Left $ "TyThing not found. " ++ key
      Just ty -> withTyThing ty

    withTyThing (AnId i) = do
      let isForce = True
      body <- GHC.obtainTermFromId maxBound isForce i >>= withTerm i
      return $ Right body

    withTyThing x = do
      liftIO $ putStrLn "[DAP][INFO]  withTyThing x Not yet supported."
      dflags <- getDynFlags
      return $ Right D.defaultEvaluateBody {
               D.resultEvaluateBody = showSDoc dflags (ppr x)
             , D.typeEvaluateBody   = showSDoc dflags (ppr x)
             , D.variablesReferenceEvaluateBody = 0
             }

    -- |
    --  Term https://hackage.haskell.org/package/ghc-8.2.1/docs/RtClosureInspect.html
    --
    withTerm :: GHC.Id -> Term -> G.GHCi D.EvaluateBody
    withTerm _ t@(Term ty _ _ _) = do
      dflags <- getDynFlags
      termSDoc <- gcatch (showTerm t) showTermErrorHandler
      let typeStr = showSDoc dflags (pprTypeForUser ty)
          valStr  = showSDoc dflags termSDoc

      nextIdx <- if True == isRefable then getNextIdx ctxMVar t key else return 0
      valStr' <- if 0 == nextIdx then return valStr
                   else  getDataConstructor t

      -- liftIO $ putStrLn "[DAP][INFO] Term Not yet supported."

      return D.defaultEvaluateBody {
               D.resultEvaluateBody = delDQ typeStr valStr'
             , D.typeEvaluateBody   = typeStr
             , D.variablesReferenceEvaluateBody = nextIdx
             }

    withTerm _ t@(Prim ty _) = do
      dflags <- getDynFlags
      termSDoc <- gcatch (showTerm t) showTermErrorHandler
      let typeStr = showSDoc dflags (pprTypeForUser ty)
          valStr  = showSDoc dflags termSDoc

      -- liftIO $ putStrLn "[DAP][INFO] Prim Not yet supported."

      return D.defaultEvaluateBody {
                D.resultEvaluateBody = valStr
              , D.typeEvaluateBody   = typeStr
              , D.variablesReferenceEvaluateBody = 0
              }

    withTerm _ t@(Suspension clsr ty _ _) = do
      dflags <- getDynFlags
      termSDoc <- gcatch (showTerm t) showTermErrorHandler
      let typeStr = "closure(" ++ show clsr ++ ")" ++ " :: " ++ showSDoc dflags (pprTypeForUser ty) ++ " # " ++ showSDoc dflags termSDoc

      liftIO $ putStrLn "[DAP][INFO] Suspension Not yet supported."
      return D.defaultEvaluateBody {
                D.resultEvaluateBody = typeStr
              , D.typeEvaluateBody   = typeStr
              , D.variablesReferenceEvaluateBody = 0
              }

    withTerm _ (NewtypeWrap ty _ wt) = do
      dflags <- getDynFlags
      termSDoc <- gcatch (showTerm wt) showTermErrorHandler
      let typeStr = showSDoc dflags (pprTypeForUser ty)
          valStr  = showSDoc dflags termSDoc

      liftIO $ putStrLn "[DAP][INFO] NewtypeWrap Not yet supported."
      return D.defaultEvaluateBody {
                D.resultEvaluateBody = valStr
              , D.typeEvaluateBody   = typeStr
              , D.variablesReferenceEvaluateBody = 0
              }

    withTerm _ (RefWrap ty wt) = do
      dflags <- getDynFlags
      termSDoc <- gcatch (showTerm wt) showTermErrorHandler
      let typeStr = showSDoc dflags (pprTypeForUser ty)
          valStr  = showSDoc dflags termSDoc

      liftIO $ putStrLn "[DAP][INFO] RefWrap Not yet supported."
      return D.defaultEvaluateBody {
                D.resultEvaluateBody = valStr
              , D.typeEvaluateBody   = typeStr
              , D.variablesReferenceEvaluateBody = 0
              }

    delDQ :: String -> String -> String
    delDQ typ val
      | (typ == "[Char]" || typ == "String")
        && length val > 2
        && head val == '"' && last val == '"' = tail $ init val 
      | otherwise = val