Control.hs

{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE BinaryLiterals      #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable  #-}

module Phoityne.IO.GUI.Control (
  run
, DebugCommandData(..)
) where

import Phoityne.Constant
import Phoityne.Utility

import qualified Phoityne.IO.GUI.VSCode.TH.BreakpointJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ContinueRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ContinueResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.DisconnectRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.DisconnectResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.EvaluateArgumentsJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.EvaluateBodyJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.EvaluateRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.EvaluateResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.InitializedEventJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.InitializeRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.InitializeResponseCapabilitesJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.InitializeResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.LaunchRequestArgumentsJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.LaunchRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.LaunchResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.NextRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.NextResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.OutputEventJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.OutputEventBodyJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.PauseRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.PauseResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.RequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ScopesArgumentsJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ScopesRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ScopesResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SetBreakpointsRequestArgumentsJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SetBreakpointsRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SetBreakpointsResponseBodyJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SetBreakpointsResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SourceBreakpointJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SourceJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SourceRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.SourceResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StackFrameJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StackTraceBodyJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StackTraceRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StackTraceResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StepInRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StepInResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StepOutRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StepOutResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.StoppedEventJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.TerminatedEventJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.TerminatedEventBodyJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ThreadsRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.ThreadsResponseJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.VariableJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.VariablesBodyJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.VariablesRequestJSON as J
import qualified Phoityne.IO.GUI.VSCode.TH.VariablesResponseJSON as J

import System.IO
import System.Exit
import System.FilePath
import System.Log.Logger
import qualified Data.Aeson as J
import qualified Data.ByteString.Lazy as BSL
import Text.Parsec
import Data.String.Utils
import qualified Data.List as L
import qualified Control.Exception as E
import qualified Data.Map as MAP
import Control.Concurrent
import Data.List.Split
import Data.Char
import Data.Maybe
import Data.Functor.Identity
import Control.Monad
import qualified System.FSNotify as FSN


-- |
--
--
data DebugContext = 
  DebugContext {
    resSeqDebugContext          :: Int
  , breakPointDatasDebugContext :: BreakPointDatas
  , workspaceDebugContext       :: FilePath
  , startupDebugContext         :: FilePath
  , debugStartedDebugContext    :: Bool
  , debugStoppedPosDebugContext :: Maybe HighlightTextRangeData
  , currentFrameIdDebugContext  :: Int
  , modifiedDebugContext        :: Bool
  } deriving (Show, Read, Eq, Ord)



-- |
--
--
data DebugCommandData =
  DebugCommandData {
    startDebugCommandData        :: FilePath ->  IO ()
  , stopDebugCommandData         :: IO ExitCode
  , readDebugCommandData         :: IO String
  , readLinesDebugCommandData    :: ([String] -> IO Bool) -> IO [String]
  , promptDebugCommandData       :: IO String
  , breakDebugCommandData        :: ModuleName -> Int -> IO String
  , bindingsDebugCommandData     :: IO String
  , runDebugCommandData          :: Bool -> IO String
  , continueDebugCommandData     :: Bool -> IO String
  , stepDebugCommandData         :: IO String
  , stepOverDebugCommandData     :: IO String
  , printEvldDebugCommandData    :: IO String 
  , deleteBreakDebugCommandData  :: Int -> IO String
  , traceHistDebugCommandData    :: IO String
  , traceBackDebugCommandData    :: IO String
  , traceForwardDebugCommandData :: IO String
  , forceDebugCommandData        :: String -> IO String
  , execCommandData              :: String -> IO String
  , quitDebugCommandData         :: IO String
  , buildStartDebugCommandData   :: FilePath -> IO ()
  , cleanStartDebugCommandData   :: FilePath -> IO ()
  , loadFileDebugCommandData     :: FilePath -> IO String
  , readWhileDebugCommandData    :: (String -> Bool) -> IO String
  , infoDebugCommandData         :: String -> IO String
  }

-- |
--
--
data HighlightTextRangeData = HighlightTextRangeData {
    filePathHighlightTextRangeData    :: FilePath
  , startLineNoHighlightTextRangeData :: Int
  , startColNoHighlightTextRangeData  :: Int
  , endLineNoHighlightTextRangeData   :: Int
  , endColNoHighlightTextRangeData    :: Int
  } deriving (Show, Read, Eq, Ord)


-- |
--  
-- 
data BreakPointData =
  BreakPointData {
    moduleNameBreakPointData :: String
  , filePathBreakPointData   :: FilePath
  , lineNoBreakPointData     :: Int
  , breakNoBreakPointData    :: Maybe Int
  , conditionBreakPointData  :: Maybe String
  } deriving (Show, Read, Eq, Ord)

-- |
--  
-- 
data TraceData = TraceData {
    traceIdTraceData  :: String
  , functionTraceData :: String
  , filePathTraceData :: String
  } deriving (Show, Read, Eq, Ord)

-- |
--  
-- 
data BindingData = BindingData {
    varNameBindingData :: String
  , modNameBindingData :: String
  , valueBindingData :: String
  } deriving (Show, Read, Eq, Ord)

-- |
--  
-- 
type BreakPointDataKey = (FilePath, Int)
type BreakPointDatas = MAP.Map BreakPointDataKey BreakPointData


-- |
--
--
_INITIAL_RESPONSE_SEQUENCE :: Int
_INITIAL_RESPONSE_SEQUENCE = 0


-- |
--
--
_TWO_CRLF :: String
_TWO_CRLF = "\r\n\r\n"


-- |
--
--
_SEP_WIN :: Char
_SEP_WIN = '\\'

_SEP_UNIX :: Char
_SEP_UNIX = '/'


-- |
--
--
defaultDebugContext :: DebugContext
defaultDebugContext = DebugContext _INITIAL_RESPONSE_SEQUENCE (MAP.fromList []) "" "" False Nothing 0 False



-- |
--
--
getKeyOfHighlightTextRangeData :: HighlightTextRangeData -> BreakPointDataKey
getKeyOfHighlightTextRangeData (HighlightTextRangeData file line _ _ _) = (file, line)


-- |
--
--
run :: DebugCommandData -> IO ()
run cmdData = do

  hSetBuffering stdin NoBuffering
  hSetEncoding  stdin utf8

  hSetBuffering stdout NoBuffering
  hSetEncoding  stdout utf8

  mvarCtx <- newMVar defaultDebugContext

  wait cmdData mvarCtx


-- |
--
-- 
wait :: DebugCommandData -> MVar DebugContext -> IO ()
wait cmdData ctx = go BSL.empty
  where
    go :: BSL.ByteString -> IO ()
    go buf = do
      c <- BSL.hGet stdin 1
      let newBuf = BSL.append buf c
      case readContentLength (lbs2str newBuf) of
        Left _ -> go newBuf
        Right len -> do
          infoM _LOG_NAME $ "[REQUEST] Content-Length: " ++ show len
          cnt <- BSL.hGet stdin len
          infoM _LOG_NAME $ "[REQUEST] " ++ lbs2str cnt
          handleRequest cmdData ctx cnt
    
      where
        readContentLength :: String -> Either ParseError Int
        readContentLength = parse parser "readContentLength"
    
        parser = do
          string "Content-Length: "
          len <- manyTill digit (string _TWO_CRLF)
          return . read $ len

-- |
--
--
handleRequest :: DebugCommandData -> MVar DebugContext -> BSL.ByteString -> IO ()
handleRequest cmdData mvarCtx jsonStr = case J.eitherDecode  jsonStr :: Either String J.Request of
  Left  err     -> errRes jsonStr $ "requet parse error. [" ++ err ++ "]" 
  Right jsonDat -> sucRes jsonStr jsonDat

  where
    errRes :: BSL.ByteString -> String -> IO ()
    errRes jsonStr msg = do
      errorM _LOG_NAME $ msg ++ " [" ++ lbs2str jsonStr ++ "]"
      wait cmdData mvarCtx

    sucRes jsonStr (J.Request cmd) = do
      handle jsonStr cmd
      wait cmdData mvarCtx

    handle jsonStr "initialize" = case J.eitherDecode jsonStr :: Either String J.InitializeRequest of
      Left  err -> errRes jsonStr $ "initialize parse error. [" ++ err ++ "]" 
      Right req -> initializeHandler mvarCtx req


    handle jsonStr "launch" = case J.eitherDecode jsonStr :: Either String J.LaunchRequest of
      Left  err -> errRes jsonStr $ "launch parse error. [" ++ err ++ "]" 
      Right req -> launchHandler cmdData mvarCtx req


    handle jsonStr "disconnect" = case J.eitherDecode jsonStr :: Either String J.DisconnectRequest of
      Left  err -> errRes jsonStr $ "disconnect parse error. [" ++ err ++ "]" 
      Right req -> disconnectHandler cmdData mvarCtx req


    handle jsonStr "setBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetBreakpointsRequest of
      Left  err -> errRes jsonStr $ "setBreakpoints parse error. [" ++ err ++ "]" 
      Right req -> setBreakpointsHandler cmdData mvarCtx req


    handle jsonStr "continue" = case J.eitherDecode jsonStr :: Either String J.ContinueRequest of
      Left  err -> errRes jsonStr $ "continue parse error. [" ++ err ++ "]" 
      Right req -> continueHandler cmdData mvarCtx req


    handle jsonStr "next" = case J.eitherDecode jsonStr :: Either String J.NextRequest of
      Left  err -> errRes jsonStr $ "next parse error. [" ++ err ++ "]" 
      Right req -> stepOverHandler cmdData mvarCtx req


    handle jsonStr "stepIn" = case J.eitherDecode jsonStr :: Either String J.StepInRequest of
      Left  err -> errRes jsonStr $ "stepIn parse error. [" ++ err ++ "]" 
      Right req -> stepInHandler cmdData mvarCtx req


    handle jsonStr "stepOut" = case J.eitherDecode jsonStr :: Either String J.StepOutRequest of
      Left  err -> errRes jsonStr $ "stepOut parse error. [" ++ err ++ "]" 
      Right req -> do
        resSeq <- incResSeq mvarCtx
        let res    = J.defaultStepOutResponse resSeq req
            resStr = J.encode $ res{J.successStepOutResponse = False, J.messageStepOutResponse = "unsupported command."}
        sendResponse resStr
 
        putStrLnStderr mvarCtx "stepout command is not supported."


    handle jsonStr "pause" = case J.eitherDecode jsonStr :: Either String J.PauseRequest of
      Left  err -> errRes jsonStr $ "pause parse error. [" ++ err ++ "]" 
      Right req -> do
        resSeq <- incResSeq mvarCtx
        let res    = J.defaultPauseResponse resSeq req
            resStr = J.encode $ res{J.successPauseResponse = False, J.messagePauseResponse = "unsupported command."}
        sendResponse resStr
 
        putStrLnStderr mvarCtx "pause command is not supported."


    handle jsonStr "stackTrace" = case J.eitherDecode jsonStr :: Either String J.StackTraceRequest of
      Left  err -> errRes jsonStr $ "stackTrace parse error. [" ++ err ++ "]" 
      Right req -> stackTraceHandler cmdData mvarCtx req


    handle jsonStr "scopes" = case J.eitherDecode jsonStr :: Either String J.ScopesRequest of
      Left  err -> errRes jsonStr $ "scopes parse error. [" ++ err ++ "]" 
      Right req -> scopesHandler cmdData mvarCtx req



    handle jsonStr "variables" = case J.eitherDecode jsonStr :: Either String J.VariablesRequest of
      Left  err -> errRes jsonStr $ "variables parse error. [" ++ err ++ "]" 
      Right req -> variablesHandler cmdData mvarCtx req


    handle jsonStr "source" = case J.eitherDecode jsonStr :: Either String J.SourceRequest of
      Left  err -> errRes jsonStr $ "source parse error. [" ++ err ++ "]" 
      Right req -> do
        resSeq <- incResSeq mvarCtx
        let res    = J.defaultSourceResponse resSeq req
            resStr = J.encode $ res{J.successSourceResponse = False, J.messageSourceResponse = "unsupported command."}
        sendResponse resStr
 
        putStrLnStderr mvarCtx "source command is not supported."


    handle jsonStr "threads" = case J.eitherDecode jsonStr :: Either String J.ThreadsRequest of
      Left  err -> errRes jsonStr $ "threads parse error. [" ++ err ++ "]" 
      Right req -> threadsHandler cmdData mvarCtx req


    handle jsonStr "evaluate" = case J.eitherDecode jsonStr :: Either String J.EvaluateRequest of
      Left  err -> errRes jsonStr $ "evaluate parse error. [" ++ err ++ "]" 
      Right req -> evaluateHandler cmdData mvarCtx req


    handle jsonStr cmd = do
      putStrLnStderr mvarCtx $ cmd ++ " command is not supported."
      putStrLnStderr mvarCtx $ lbs2str jsonStr ++ " is requested."


-- |
--
sendEvent :: BSL.ByteString -> IO ()
sendEvent str = do
  infoM _LOG_NAME $ "[EVENT] Content-Length: " ++ show (BSL.length str)
  infoM _LOG_NAME $ "[EVENT] " ++ lbs2str str

  sendResponseInternal str

-- |
--
sendResponse :: BSL.ByteString -> IO ()
sendResponse str = do
  infoM _LOG_NAME $ "[RESPONSE] Content-Length: " ++ show (BSL.length str)
  infoM _LOG_NAME $ "[RESPONSE] " ++ lbs2str str

  sendResponseInternal str

-- |
--
sendResponseInternal :: BSL.ByteString -> IO ()
sendResponseInternal str = do
  BSL.hPut stdout $ BSL.append "Content-Length: " $ str2lbs $ show (BSL.length str)
  BSL.hPut stdout $ str2lbs _TWO_CRLF
  BSL.hPut stdout str
  hFlush stdout


-- |=====================================================================
--
-- Handlers

-- |
--
initializeHandler :: MVar DebugContext -> J.InitializeRequest -> IO ()
initializeHandler mvarCtx (J.InitializeRequest seq _ _ _) = flip E.catches handlers $ do
  resSeq <- incResSeq mvarCtx
  let capa = J.InitializeResponseCapabilites False False True False []
      res  = J.InitializeResponse resSeq "response" seq True "initialize" "" capa

  sendResponse $ J.encode res

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = "initializeHandler:" ++ show e
      errorM _LOG_NAME msg

-- |
--
launchHandler :: DebugCommandData -> MVar DebugContext -> J.LaunchRequest -> IO ()
launchHandler cmdData mvarCtx req@(J.LaunchRequest _ _ _ args) = flip E.catches handlers $ do
  let ws = J.workspaceLaunchRequestArguments args
      su = J.startupLaunchRequestArguments args

  ctx <- takeMVar mvarCtx
  putMVar mvarCtx ctx {
      workspaceDebugContext = ws
    , startupDebugContext   = su
    }

  runGHCi cmdData mvarCtx ws

  loadHsFile cmdData mvarCtx su

  resSeq <- incResSeq mvarCtx
  sendResponse $ J.encode $ J.defaultLaunchResponse resSeq req

  resSeq <- incResSeq mvarCtx
  sendEvent $ J.encode $ J.defaultInitializedEvent resSeq

  watch cmdData mvarCtx

  let infoMsg = [
                ""
              , "  Now, ghci initialized."
              , "  Press F5 to start debugging."
              , "  Or modify source code. it will be loaded to debugger automatically."
              , ""
              ]
  putStrLnConsole mvarCtx $ L.intercalate "\n" infoMsg
  putStrStdout mvarCtx _PHOITYNE_GHCI_PROMPT

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = "launchHandler:" ++ show e
      errorM _LOG_NAME msg



-- |
--
-- 
watch :: DebugCommandData -> MVar DebugContext -> IO ()
watch cmdData mvarCtx = do
  _ <- forkIO $ watchFiles cmdData mvarCtx
  return ()

watchFiles :: DebugCommandData -> MVar DebugContext -> IO ()
watchFiles cmdData mvarCtx = do
  FSN.withManagerConf FSN.defaultConfig{FSN.confDebounce  = FSN.Debounce 1} $ \mgr -> do

    ctx <- readMVar mvarCtx
    let dir = workspaceDebugContext ctx
  
    infoM _LOG_NAME $ "start watch files in [" ++ dir ++ "]"
    _ <- FSN.watchTree mgr dir hsFilter action
  
    forever $ threadDelay 1000000

  return ()
  
  where
    hsFilter event = endswith _HS_FILE_EXT $ FSN.eventPath event

    action event = do

      ctx <- readMVar mvarCtx
      withDebugStarted event $ debugStartedDebugContext ctx

    withDebugStarted _ True = do
      resSeq <- incResSeq mvarCtx
      let terminatedEvt    = J.defaultTerminatedEvent resSeq
          terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True}
      sendEvent terminatedEvtStr

    withDebugStarted event False = do
      ctx <- takeMVar mvarCtx
      putMVar mvarCtx ctx{modifiedDebugContext = True}
      loadHsFile cmdData mvarCtx (FSN.eventPath event) >> return ()


-- |
--
disconnectHandler :: DebugCommandData -> MVar DebugContext -> J.DisconnectRequest -> IO ()
disconnectHandler cmdData mvarCtx req = flip E.catches handlers $ do

  let exitCmd     = stopDebugCommandData cmdData
      quitCmd     = quitDebugCommandData cmdData
      readWhile   = readWhileDebugCommandData cmdData

  cmdStr <- quitCmd
  infoM _LOG_NAME cmdStr
  putStrLnStdout mvarCtx cmdStr

  str <- readWhile $ const True 
  infoM _LOG_NAME str
  putStrLnStdout mvarCtx str

  code <- exitCmd

  infoM _LOG_NAME $ show code
  putStrLnStdout mvarCtx $ show code

  resSeq <- incResSeq mvarCtx
  sendResponse $ J.encode $ J.defaultDisconnectResponse resSeq req

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = "disconnectHandler:" ++ show e
      errorM _LOG_NAME msg
      putStrLnStderr mvarCtx msg

-- |
--
setBreakpointsHandler :: DebugCommandData -> MVar DebugContext -> J.SetBreakpointsRequest -> IO ()
setBreakpointsHandler cmdData mvarCtx req = flip E.catches handlers $ do

  ctx <- readMVar mvarCtx
  let cwd     = workspaceDebugContext ctx
      args    = J.argumentsSetBreakpointsRequest req
      source  = J.sourceSetBreakpointsRequestArguments args
      path    = J.pathSource source
      reqBps  = J.breakpointsSetBreakpointsRequestArguments args
      bps     = map (convBp cwd path) reqBps

  delete path
  resBody <- insert bps

  resSeq <- incResSeq mvarCtx
  let res = J.defaultSetBreakpointsResponse resSeq req
      resStr = J.encode res{J.bodySetBreakpointsResponse = J.SetBreakpointsResponseBody resBody}
  sendResponse resStr

  resSeq <- incResSeq mvarCtx
  let stopEvt    = J.defaultStoppedEvent resSeq
      stopEvtStr = J.encode stopEvt
  sendEvent stopEvtStr


  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = "setBreakpointsHandler:" ++ show e
      errorM _LOG_NAME msg

    convBp cwd path (J.SourceBreakpoint lineNo _ cond) =
      BreakPointData {
        moduleNameBreakPointData = src2mod cwd path
      , filePathBreakPointData   = path
      , lineNoBreakPointData     = lineNo
      , breakNoBreakPointData    = Nothing
      , conditionBreakPointData  = cond
      }

    delete path = do
      ctx <- takeMVar mvarCtx
      let bps = breakPointDatasDebugContext ctx
          newBps = MAP.filterWithKey (\(p,_) _-> path /= p) bps
          delBps = MAP.elems $ MAP.filterWithKey (\(p,_) _-> path == p) bps

      putMVar mvarCtx ctx{breakPointDatasDebugContext = newBps}

      debugM _LOG_NAME $ "del bps:" ++ show delBps

      mapM_ (deleteBreakPointOnCUI cmdData mvarCtx) delBps


    insert reqBps = do

      results <- mapM insertInternal reqBps
      let addBps  = filter (\(_, (J.Breakpoint _ verified _ _ _ _)) -> verified) results
          resData = map snd results

      debugM _LOG_NAME $ "add bps:" ++ show addBps
      debugM _LOG_NAME $ "response bps:" ++ show resData

      ctx <- takeMVar mvarCtx
      let bps    = breakPointDatasDebugContext ctx
          newBps = foldr (\v@(BreakPointData _ p l _ _)->MAP.insert (p,l) v) bps $ map fst results
      putMVar mvarCtx ctx{breakPointDatasDebugContext = newBps}

      return resData

    insertInternal reqBp@(BreakPointData modName filePath lineNo _ _) = do

      let src = J.Source (Just modName) filePath Nothing Nothing 

      addBreakPointOnCUI cmdData mvarCtx reqBp >>= \case
        Right no -> do
          --putStrLnStdout mvarCtx $ "set breakpoint on " ++ filePathBreakPointData reqBp ++ ":L" ++ show (lineNoBreakPointData reqBp) 
          return (reqBp{breakNoBreakPointData = Just no}, J.Breakpoint (Just no) True "" src lineNo 1)
        Left err -> return (reqBp, J.Breakpoint Nothing False err src lineNo 1)

-- |
--
--
threadsHandler :: DebugCommandData -> MVar DebugContext -> J.ThreadsRequest -> IO ()
threadsHandler _ mvarCtx req = flip E.catches handlers $ do
  resSeq <- incResSeq mvarCtx
  let resStr = J.encode $ J.defaultThreadsResponse resSeq req
  sendResponse resStr

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = "threadsHandler:" ++ show e
      errorM _LOG_NAME msg

-- |
--
--
scopesHandler :: DebugCommandData -> MVar DebugContext -> J.ScopesRequest -> IO ()
scopesHandler cmdData mvarCtx req = flip E.catches handlers $ do

  let args    = J.argumentsScopesRequest req
      traceId = J.frameIdScopesArguments args

  moveFrame cmdData mvarCtx traceId

  resSeq <- incResSeq mvarCtx
  let resStr = J.encode $ J.defaultScopesResponse resSeq req
  sendResponse resStr

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = "scopesHandler:" ++ show e
      errorM _LOG_NAME msg


-- |
--
--
moveFrame :: DebugCommandData -> MVar DebugContext -> Int -> IO ()
moveFrame cmdData mvarCtx traceId = do
  ctx <- readMVar mvarCtx
  let curTraceId = currentFrameIdDebugContext ctx
      moveCount  = curTraceId - traceId
      traceCmd   = if 0 > moveCount then traceForwardDebugCommandData cmdData
                     else traceBackDebugCommandData cmdData
      getResult  = readDebugCommandData cmdData

  _ <- foldM (go traceCmd getResult) (""::String) [1..(abs moveCount)]

  ctx <- takeMVar mvarCtx
  putMVar mvarCtx ctx{currentFrameIdDebugContext = traceId}

  where
    go traceCmd getResult _ _ = do

      cmdStr <- traceCmd
      infoM _LOG_NAME cmdStr
      putStrLnStdout mvarCtx cmdStr

      cmdStr <- getResult
      infoM _LOG_NAME cmdStr
      putStrStdout mvarCtx cmdStr

      return cmdStr

-- |
--
--
variablesHandler :: DebugCommandData -> MVar DebugContext -> J.VariablesRequest -> IO ()
variablesHandler cmdData mvarCtx req = flip E.catches handlers $ do

  vals <- currentBindings

  resSeq <- incResSeq mvarCtx
  let res = J.defaultVariablesResponse resSeq req
      resStr = J.encode $ res{J.bodyVariablesResponse = J.VariablesBody vals}
  sendResponse resStr

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = "scopesHandler:" ++ show e
      errorM _LOG_NAME msg

    currentBindings = do
      let bindings = bindingsDebugCommandData cmdData
          getResult = readDebugCommandData cmdData

      cmdStr <- bindings
      infoM _LOG_NAME cmdStr
      -- putStrLnStdout mvarCtx cmdStr

      bindStr <- getResult
      infoM _LOG_NAME bindStr
      -- putStrStdout mvarCtx bindStr

      case getBindingDataList bindStr of
        Left err   -> do 
          errorM _LOG_NAME $ show err
          putStrLnStderr mvarCtx $ show err
          return []

        Right dats -> return $ map convBind2Vals dats
    
    convBind2Vals (BindingData varName _ val) = J.Variable varName val 0


-- |
--
--
stackTraceHandler :: DebugCommandData -> MVar DebugContext -> J.StackTraceRequest -> IO ()
stackTraceHandler cmdData mvarCtx req = flip E.catches handlers $ do
  ctx <- readMVar mvarCtx
  case debugStoppedPosDebugContext ctx of
    Nothing -> do
      resSeq <- incResSeq mvarCtx
      let body = J.StackTraceBody [] 0
          res  = J.defaultStackTraceResponse resSeq req
          resStr = J.encode $ res{J.bodyStackTraceResponse = body}
      sendResponse resStr
    
    Just rangeData -> do
      resSeq <- incResSeq mvarCtx

      frames <- createStackFrames rangeData
      debugM _LOG_NAME $ show frames

      let body   = J.StackTraceBody (reverse frames) (length frames)
          res    = J.defaultStackTraceResponse resSeq req
          resStr = J.encode $ res{J.bodyStackTraceResponse = body}
      sendResponse resStr

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = "stackTraceHandler:" ++ show e
      errorM _LOG_NAME msg


    createStackFrames (HighlightTextRangeData file sl sc _ _) = do
      ctx <- readMVar mvarCtx
      let cwd = workspaceDebugContext ctx
          csf = J.StackFrame 0 "0" (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc

      let getResult = readDebugCommandData cmdData
          history   = traceHistDebugCommandData cmdData
    
      cmdStr <- history
      infoM _LOG_NAME cmdStr
      -- putStrLnStdout mvarCtx cmdStr

      traceStr <- getResult
      infoM _LOG_NAME traceStr
      -- putStrStdout mvarCtx traceStr
 
      case getTraceDataList traceStr of
        Left err   -> do
          errorM _LOG_NAME $ show err
          -- putStrLnStderr mvarCtx $ show err
          return [csf]

        Right dats -> foldM (convTrace2Frame cwd) [csf] dats

    convTrace2Frame cwd xs (TraceData traceId _ filePath) = case parse parseHighlightTextRange "getActivatePosFromLine" filePath of
      Left err -> do
        infoM _LOG_NAME $ show err
        return xs
      Right (HighlightTextRangeData file sl sc _ _) -> return $ 
        J.StackFrame (read traceId) traceId (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc : xs

-- |
--
--
evaluateHandler :: DebugCommandData -> MVar DebugContext -> J.EvaluateRequest -> IO ()
evaluateHandler cmdData mvarCtx req = flip E.catches handlers $ do

  let (J.EvaluateArguments exp frameId ctx) = J.argumentsEvaluateRequest req
      
  moveFrame cmdData mvarCtx $ if isJust frameId then fromJust frameId else 0
  eval ctx exp


  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = "continueHandler:" ++ show e
      errorM _LOG_NAME msg

    eval "watch" exp = do
      let forceVar = forceDebugCommandData cmdData
          getResult = readDebugCommandData cmdData

      cmdStr <- forceVar exp
      infoM _LOG_NAME cmdStr
      -- putStrLnStdout mvarCtx cmdStr
    
      cmdStr <- getResult
      infoM _LOG_NAME cmdStr
      -- putStrStdout mvarCtx cmdStr

      let result = L.intercalate " " . filter (not . null) . map strip . init . lines $ cmdStr

      resSeq <- incResSeq mvarCtx
      let body   = J.EvaluateBody result 0
          res    = J.defaultEvaluateResponse resSeq req
          resStr = J.encode res{J.bodyEvaluateResponse = body}
      sendResponse resStr


    eval "hover" exp = do
      let info      = infoDebugCommandData cmdData
          getResult = readDebugCommandData cmdData

      cmdStr <- info exp
      infoM _LOG_NAME cmdStr

      cmdStr <- getResult
      infoM _LOG_NAME cmdStr

      let result = L.intercalate " " . filter (not . null) . map strip . init . lines $ cmdStr

      resSeq <- incResSeq mvarCtx
      let body   = J.EvaluateBody result 0
          res    = J.defaultEvaluateResponse resSeq req
          resStr = J.encode res{J.bodyEvaluateResponse = body}
      sendResponse resStr


    eval _ exp = do
      let exec = execCommandData cmdData
          getResult = readDebugCommandData cmdData

      cmdStr <- exec exp
      infoM _LOG_NAME cmdStr
    
      cmdStr <- getResult
      infoM _LOG_NAME cmdStr

      let result = L.intercalate " " . filter (not . null) . map strip . init . lines $ cmdStr

      resSeq <- incResSeq mvarCtx
      let body   = J.EvaluateBody result 0
          res    = J.defaultEvaluateResponse resSeq req
          resStr = J.encode res{J.bodyEvaluateResponse = body}
      sendResponse resStr
    
      putStrStdout mvarCtx $ "\n" ++ _PHOITYNE_GHCI_PROMPT


    

-- |
--
--
continueHandler :: DebugCommandData -> MVar DebugContext -> J.ContinueRequest -> IO ()
continueHandler cmdData mvarCtx req = flip E.catches handlers $ do
  resSeq <- incResSeq mvarCtx
  let resStr = J.encode $ J.defaultContinueResponse resSeq req
  sendResponse resStr

  startDebug cmdData mvarCtx

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = "continueHandler:" ++ show e
      errorM _LOG_NAME msg


-- |
--
--
startDebug :: DebugCommandData -> MVar DebugContext -> IO ()
startDebug cmdData mvarCtx = do
  ctx <- readMVar mvarCtx
  let started = debugStartedDebugContext ctx
  
  startDebugInternal started


  where
    startDebugInternal True = do
      let continue  = continueDebugCommandData cmdData
          getResult = readDebugCommandData cmdData
    
      cmdStr <- continue True
      infoM _LOG_NAME cmdStr
      putStrLnStdout mvarCtx cmdStr

      cmdStr <- getResult
      infoM _LOG_NAME cmdStr
      putStrStdout mvarCtx cmdStr

      sendEventByDebugStopStatus cmdData mvarCtx cmdStr   

    startDebugInternal False = do
      ctx <- readMVar mvarCtx
      withModified $ modifiedDebugContext ctx

    withModified True = do
      resSeq <- incResSeq mvarCtx
      let terminatedEvt    = J.defaultTerminatedEvent resSeq
          terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True}
      sendEvent terminatedEvtStr
  
    withModified False = do
      let getResult  = readDebugCommandData cmdData
          runDebug   = runDebugCommandData cmdData
    
      cmdStr <- runDebug True
      infoM _LOG_NAME cmdStr
      putStrLnStdout mvarCtx cmdStr
    
      cmdStr <- getResult
      infoM _LOG_NAME cmdStr
      putStrStdout mvarCtx cmdStr


      ctx <- takeMVar mvarCtx
      putMVar mvarCtx ctx{currentFrameIdDebugContext = 0, debugStartedDebugContext = True}

      sendEventByDebugStopStatus cmdData mvarCtx cmdStr


-- |
--
--
sendEventByDebugStopStatus :: DebugCommandData -> MVar DebugContext -> String -> IO ()
sendEventByDebugStopStatus cmdData mvarCtx cmdStr = case getStoppedTextRangeData cmdStr of
  Left err  -> do
    infoM _LOG_NAME $ show err
    --putStrLnStdout mvarCtx $ show err

    resSeq <- incResSeq mvarCtx
    let terminatedEvt    = J.defaultTerminatedEvent resSeq
        terminatedEvtStr = J.encode terminatedEvt
    sendEvent terminatedEvtStr

  Right pos -> continueWithHighlightTextRangeData cmdData mvarCtx pos


-- |
--
--
continueWithHighlightTextRangeData :: DebugCommandData -> MVar DebugContext -> HighlightTextRangeData -> IO ()
continueWithHighlightTextRangeData cmdData mvarCtx pos = do
  ctx <- readMVar mvarCtx

  let bpKey = getKeyOfHighlightTextRangeData pos
      bpMap = breakPointDatasDebugContext ctx

  case MAP.lookup bpKey bpMap of
    Nothing -> do
      errorM _LOG_NAME $ "breakpoint not found." ++ show bpKey
      sendStopEvent
    Just condCmd -> continueWithCondCmd $ conditionBreakPointData condCmd

  where

    -- |
    --
    continueWithCondCmd Nothing = do
      infoM _LOG_NAME "no condition breakpoint"
      sendStopEvent
    continueWithCondCmd (Just condStr) = do
        
      let condition = execCommandData cmdData
          getResult = readDebugCommandData cmdData

      _ <- condition condStr
      infoM _LOG_NAME condStr
      putStrLnStdout mvarCtx condStr

      cmdStr <- getResult
      infoM _LOG_NAME cmdStr
      putStrStdout mvarCtx cmdStr

      condRes <- getConditionResult cmdStr

      continueWithCondResult condRes

    -- |
    --
    continueWithCondResult False = startDebug cmdData mvarCtx
    continueWithCondResult True  = sendStopEvent

    -- |
    --
    getConditionResult res
      | L.isPrefixOf "True"  res = return True
      | L.isPrefixOf "False" res = return False
      | otherwise = warningM _LOG_NAME ("invalid condition result. " ++ res) >> return True


    -- |
    --
    sendStopEvent = do
      infoM _LOG_NAME $ show pos
  
      ctx <- takeMVar mvarCtx
      putMVar mvarCtx ctx{debugStoppedPosDebugContext = Just pos}
  
      resSeq <- incResSeq mvarCtx
      let stopEvt    = J.defaultStoppedEvent resSeq
          stopEvtStr = J.encode stopEvt
      sendEvent stopEvtStr


-- |
--
--
stepOverHandler :: DebugCommandData -> MVar DebugContext -> J.NextRequest -> IO ()
stepOverHandler cmdData mvarCtx req = flip E.catches handlers $ do
  ctx <- readMVar mvarCtx
  case debugStoppedPosDebugContext ctx of
    Nothing -> do
      resSeq <- incResSeq mvarCtx
      let res    = J.defaultNextResponse resSeq req
          resStr = J.encode res{J.successNextResponse = False, J.messageNextResponse = "debug is initialized but not started yet. press F5(continue)."}
      sendResponse resStr
    Just _ -> stepOver

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = "continueHandler:" ++ show e
      errorM _LOG_NAME msg

    stepOver = do
      let step = stepOverDebugCommandData cmdData
          getResult = readDebugCommandData cmdData
       
      cmdStr <- step
      infoM _LOG_NAME cmdStr
      putStrLnStdout mvarCtx cmdStr
    
      cmdStr <- getResult
      infoM _LOG_NAME cmdStr
      putStrStdout mvarCtx cmdStr

      case getStoppedTextRangeData cmdStr of
        Left err  -> do
          infoM _LOG_NAME $ show err
          --putStrLnStdout mvarCtx $ show err
      
          resSeq <- incResSeq mvarCtx
          let terminatedEvt    = J.defaultTerminatedEvent resSeq
              terminatedEvtStr = J.encode terminatedEvt
          sendEvent terminatedEvtStr

        Right pos -> do
          ctx <- takeMVar mvarCtx
          putMVar mvarCtx ctx{debugStoppedPosDebugContext = Just pos}
    
          resSeq <- incResSeq mvarCtx
          let res    = J.defaultNextResponse resSeq req
              resStr = J.encode res
          sendResponse resStr
    
          resSeq <- incResSeq mvarCtx
          let stopEvt    = J.defaultStoppedEvent resSeq
              stopEvtStr = J.encode stopEvt
          sendEvent stopEvtStr


-- |
--
--
stepInHandler :: DebugCommandData -> MVar DebugContext -> J.StepInRequest -> IO ()
stepInHandler cmdData mvarCtx req = flip E.catches handlers $ do
  ctx <- readMVar mvarCtx
  case debugStoppedPosDebugContext ctx of
    Nothing -> do
      resSeq <- incResSeq mvarCtx
      let res    = J.defaultStepInResponse resSeq req
          resStr = J.encode res{J.successStepInResponse = False, J.messageStepInResponse = "debug is initialized but not started yet. press F5(continue)."}
      sendResponse resStr
    Just _ -> stepIn

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = "continueHandler:" ++ show e
      errorM _LOG_NAME msg

    stepIn = do
      let step = stepDebugCommandData cmdData
          getResult = readDebugCommandData cmdData
       
      cmdStr <- step
      infoM _LOG_NAME cmdStr
      putStrLnStdout mvarCtx cmdStr
    
      cmdStr <- getResult
      infoM _LOG_NAME cmdStr
      putStrStdout mvarCtx cmdStr

      case getStoppedTextRangeData cmdStr of
        Left err  -> do
          infoM _LOG_NAME $ show err
          --putStrLnStdout mvarCtx $ show err
      
          resSeq <- incResSeq mvarCtx
          let terminatedEvt    = J.defaultTerminatedEvent resSeq
              terminatedEvtStr = J.encode terminatedEvt
          sendEvent terminatedEvtStr

        Right pos -> do
          ctx <- takeMVar mvarCtx
          putMVar mvarCtx ctx{debugStoppedPosDebugContext = Just pos}
    
          resSeq <- incResSeq mvarCtx
          let res    = J.defaultStepInResponse resSeq req
              resStr = J.encode res
          sendResponse resStr
    
          resSeq <- incResSeq mvarCtx
          let stopEvt    = J.defaultStoppedEvent resSeq
              stopEvtStr = J.encode stopEvt
          sendEvent stopEvtStr




-- |=====================================================================
--
--  utility

-- |
--
--
putStrLnConsole :: MVar DebugContext -> String -> IO ()
putStrLnConsole mvarCtx msg = putStrConsole mvarCtx (msg ++ "\n")

-- |
--
--
putStrConsole :: MVar DebugContext -> String -> IO ()
putStrConsole mvarCtx msg = do
  resSeq <- incResSeq mvarCtx
  let outEvt  = J.defaultOutputEvent resSeq
      outEvtStr = J.encode outEvt{J.bodyOutputEvent = J.OutputEventBody "console" msg Nothing }
  sendEvent outEvtStr

-- |
--
--
putStrLnStdout :: MVar DebugContext -> String -> IO ()
putStrLnStdout mvarCtx msg = putStrStdout mvarCtx (msg ++ "\n")

-- |
--
--
putStrStdout :: MVar DebugContext -> String -> IO ()
putStrStdout mvarCtx msg = do
  resSeq <- incResSeq mvarCtx
  let outEvt    = J.defaultOutputEvent resSeq
      outEvtStr = J.encode outEvt{J.bodyOutputEvent = J.OutputEventBody "stdout" msg Nothing }
  sendEvent outEvtStr

-- |
--
--
putStrLnStderr :: MVar DebugContext -> String -> IO ()
putStrLnStderr mvarCtx msg = putStrStderr mvarCtx (msg ++ "\n")

-- |
--
--
putStrStderr :: MVar DebugContext -> String -> IO ()
putStrStderr mvarCtx msg = do
  resSeq <- incResSeq mvarCtx
  let outEvt    = J.defaultOutputEvent resSeq
      outEvtStr = J.encode outEvt{J.bodyOutputEvent = J.OutputEventBody "stderr" msg Nothing }
  sendEvent outEvtStr



-- |
--
--
src2mod :: FilePath -> FilePath -> String
src2mod cwd src 
  | length cwd >= length src = ""
  | otherwise = L.intercalate "."
      $ map takeBaseName
      $ reverse
      $ takeWhile startUpperCase
      $ reverse
      $ splitOneOf [_SEP_WIN, _SEP_UNIX]
      $ drop (length cwd) src

  where
    startUpperCase modName 
      | null modName = True
      | otherwise = isUpper $ head modName


-- |
--
--
incResSeq :: MVar DebugContext -> IO Int
incResSeq mvarCtx = do
  ctx <- takeMVar mvarCtx
  let resSec = 1 + resSeqDebugContext ctx
  putMVar mvarCtx ctx{resSeqDebugContext = resSec}
  return resSec

-- |
--
--
runGHCi :: DebugCommandData -> MVar DebugContext -> FilePath -> IO Bool
runGHCi cmdData mvarCtx cwd = do
  let startCmd  = startDebugCommandData cmdData
      readWhile = readWhileDebugCommandData cmdData

  infoM _LOG_NAME "% stack ghci --test --no-load --no-build \n"
  putStrLnStdout mvarCtx "% stack ghci --test --no-load --no-build \n"

  startCmd cwd

  str <- readWhile $ not . endswith _GHCI_PROMPT

  infoM _LOG_NAME str
  putStrStdout mvarCtx str

  withStarted $ endswith _GHCI_PROMPT str

  where
    withStarted False = return False
    withStarted True = do
      readAndSetPrompt
      return True

    readAndSetPrompt = do
      let setPrompt = promptDebugCommandData cmdData
          getResult = readDebugCommandData cmdData
          printEvld = printEvldDebugCommandData cmdData

      promptStr <- setPrompt
      putStrLnStdout mvarCtx promptStr
      infoM _LOG_NAME promptStr

      cmdStr <- getResult
      putStrStdout mvarCtx cmdStr
      infoM _LOG_NAME cmdStr

      cmdStr <- printEvld
      putStrLnStdout mvarCtx cmdStr
      infoM _LOG_NAME cmdStr

      cmdStr <- getResult
      putStrStdout mvarCtx cmdStr
      infoM _LOG_NAME cmdStr


-- |
--
--
loadHsFile :: DebugCommandData -> MVar DebugContext -> FilePath -> IO Bool
loadHsFile cmdData mvarCtx path
  | (False == endswith _HS_FILE_EXT path) = return False
  | otherwise = do
    let loadFile  = loadFileDebugCommandData cmdData
        readLines = readLinesDebugCommandData cmdData
        getResult = readDebugCommandData cmdData
  
    cmdStr <- loadFile path
    putStrLnStdout mvarCtx cmdStr
    infoM _LOG_NAME cmdStr
  
    cont <- readLines debugStartResultHandler
  
    if | null cont -> return False
       | startswith "Ok," (last cont) -> do
         cmdStr <- getResult
         putStrStdout mvarCtx cmdStr
         infoM _LOG_NAME cmdStr
         return True
       | startswith "Failed," (last cont) -> do
         cmdStr <- getResult
         putStrStdout mvarCtx cmdStr
         infoM _LOG_NAME cmdStr
         return False
       | otherwise -> do
         errorM _LOG_NAME $ "load file fail.["++ path ++"]"
         putStrLnStderr mvarCtx $ "load file fail.["++ path ++"]"
         return False

  where
    debugStartResultHandler :: [String] -> IO Bool
    debugStartResultHandler acc = putStrLnStdout mvarCtx curStr >> infoM _LOG_NAME curStr >> if
      | L.isPrefixOf "Ok," curStr -> return False
      | L.isPrefixOf "Failed," curStr -> return False
      | otherwise -> return True
      where
        curStr | null acc = ""
               | otherwise = last acc


-- |
--  ブレークポイントをGHCi上でdeleteする
--
deleteBreakPointOnCUI :: DebugCommandData -> MVar DebugContext -> BreakPointData -> IO ()
deleteBreakPointOnCUI cmdData _ (BreakPointData _ _ _ (Just breakNo) _) = do
  let deleteBreak = deleteBreakDebugCommandData cmdData
      getResult   = readDebugCommandData cmdData

  cmdStr <- deleteBreak breakNo
  -- putStrLnStdout mvarCtx cmdStr
  infoM _LOG_NAME cmdStr

  cmdStr <- getResult
  -- putStrStdout mvarCtx cmdStr
  infoM _LOG_NAME cmdStr

deleteBreakPointOnCUI _ mvarCtx bp = do
  let err = "invalid delete break point."  ++ show bp
  putStrLnStderr mvarCtx err
  errorM _LOG_NAME err


-- |
--  GHCi上でブレークポイントを追加する
--
addBreakPointOnCUI :: DebugCommandData -> MVar DebugContext -> BreakPointData -> IO (Either String Int)
addBreakPointOnCUI cmdData _ (BreakPointData modName _ lineNo _ _) = do

  let setBreak    = breakDebugCommandData cmdData
      getResult   = readDebugCommandData cmdData

  cmdStr <- setBreak modName lineNo
  -- putStrLnStdout mvarCtx cmdStr
  infoM _LOG_NAME cmdStr

  cmdStr <- getResult
  -- putStrStdout mvarCtx cmdStr
  infoM _LOG_NAME cmdStr

  case getBreakPointNo cmdStr of
    Right no  -> return $ Right no 
    Left  err -> if L.isPrefixOf _NO_BREAK_POINT_LOCATION cmdStr
                   then return $ Left _NO_BREAK_POINT_LOCATION
                   else do
                     let msg = "unexpected break set result. " ++ show err ++ cmdStr
                     errorM _LOG_NAME msg
                     return $ Left msg
  
  where
  
    -- |
    --  parser of
    --   Breakpoint 0 activated at src\Main.hs:(21,3)-(23,35)
    --
    getBreakPointNo :: String -> Either ParseError Int
    getBreakPointNo res = parse parser "getBreakPointNo" res
      where
        parser = do
          _ <- manyTill anyChar (string "Breakpoint ")
          no <- manyTill digit (string " activated at")
          return $ read no


-- |=====================================================================
--
--  パーサ
--

-- |
--
--
getStoppedTextRangeData :: String -> Either ParseError HighlightTextRangeData
getStoppedTextRangeData = parse parser "getStoppedTextRangeData"
  where
    parser = do
      _ <- manyTill anyChar (try (string "Stopped at "))
      parseHighlightTextRange


-- |
--
drive2lower :: FilePath -> FilePath
drive2lower (x : ':' : xs) = toLower x : ':' : xs
drive2lower xs = xs

-- |
--  parser of
--   A) src\Phoityne\IO\Main.hs:31:11-14
--   B) src\Main.hs:(17,3)-(19,35)
--   C) src\Phoityne\IO\Main.hs:31:11
--      src\Phoityne\IO\Main.hs:31:11:
--
parseHighlightTextRange :: forall u. ParsecT String u Identity HighlightTextRangeData
parseHighlightTextRange = do
  path <- manyTill anyChar (string (_HS_FILE_EXT ++ ":"))
  (sl, sn, el, en) <- try parseA <|> try parseB <|> try parseC
  return $ HighlightTextRangeData (drive2lower path ++ _HS_FILE_EXT) sl sn el en
  where
    parseA = do
      ln <- manyTill digit (char ':')
      sn <- manyTill digit (char '-')
      en <- try (manyTill digit endOfLine) <|> try (manyTill digit eof)
      return ((read ln), (read sn), (read ln), (read en))

    parseB = do
      _ <- char '('
      sl <- manyTill digit (char ',')
      sn <- manyTill digit (char ')')
      _ <- string "-("
      el <- manyTill digit (char ',')
      en <- manyTill digit (char ')')
      return ((read sl), (read sn), (read el), (read en))

    parseC = do
      ln <- manyTill digit (char ':')
      sn <- try (manyTill digit (char ':')) <|> try (manyTill digit endOfLine) <|> try (manyTill digit eof)
      return ((read ln), (read sn), (read ln), (read sn))

-- |
--  トレース情報のパーサ
--
--  parser of
--    Phoityne>>= :history
--    -1  : config:confB (src\Project\Argument.hs:85:17-28)
--    -2  : config:confB (src\Project\Argument.hs:87:17-36)
--                        src\Project\IO\Main.hs:(70,9)-(71,65)
--
--    -1  : main (D:\haskell\vsc-sample\app\Main.hs:6:8-15)
--
getTraceDataList :: String -> Either ParseError [TraceData]
getTraceDataList res = go [] $ reverse $ filter (L.isPrefixOf "-") $ lines res
  where
    go acc [] = Right acc
    go acc (x:xs) = case parse parser "getTraceDataList" x of
      Left err -> Left err
      Right dat -> go (dat:acc) xs

    parser = do
      traceId  <- manyTill anyChar (many1 space >> char ':' >> space)
      funcName <- manyTill anyChar (space >> char '(')
      filePath <- manyTill anyChar eof

      return $ TraceData (strip traceId) funcName (init (strip filePath))

-- |
--  バインディング値のパーサ
--
--  parser of
--   args :: Project.Argument.ArgData = _
--   _result :: IO Data.ConfigFile.Types.ConfigParser = _
--
getBindingDataList :: String -> Either ParseError [BindingData]
getBindingDataList res = parse parser "getBindingDataList" res
  where
    parser = manyTill parser1 (string _PHOITYNE_GHCI_PROMPT)

    parser1 = do
      varName <- manyTill anyChar (string "::")
      modName <- manyTill anyChar (try (string "="))
      valStr  <- manyTill anyChar lineSep <|> manyTill anyChar eof

      return $ BindingData (strip varName) (strip modName) valStr

    lineSep = try $ endOfLine >> notFollowedBy space