{-# 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 Phoityne.IO.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.Directory
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
import qualified System.Log.Logger as L
import qualified System.Log.Formatter as L
import qualified System.Log.Handler as LH
import qualified System.Log.Handler.Simple as LHS
import Safe

-- |
--
--
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        :: String -> [String] -> 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
  , typeDebugCommandData         :: String -> IO String
  , moduleDebugCommandData       :: String -> IO String
  , envSetPromptDebugCommandData :: String -> IO ()
  , envGetPromptDebugCommandData :: 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 = '/'

-- |
--
--
_TASKS_JSON_FILE_CONTENTS :: BSL.ByteString
_TASKS_JSON_FILE_CONTENTS = str2lbs $ Data.String.Utils.join "\n" $
  [
    "{"
  , "  // atuomatically created by phoityne-vscode"
  , "  "
  , "  \"version\": \"0.1.0\","
  , "  \"isShellCommand\": true,"
  , "  \"showOutput\": \"always\","
  , "  \"suppressTaskName\": true,"
  , "  \"windows\": {"
  , "    \"command\": \"cmd\","
  , "    \"args\": [\"/c\"]"
  , "  },"
  , "  \"linux\": {"
  , "    \"command\": \"sh\","
  , "    \"args\": [\"-c\"]"
  , "  },"
  , "  \"osx\": {"
  , "    \"command\": \"sh\","
  , "    \"args\": [\"-c\"]"
  , "  },"
  , "  \"tasks\": ["
  , "    {"
  , "       \"taskName\": \"stack build\","
  , "       \"args\": [ \"echo START_STACK_BUILD && cd ${workspaceRoot} && stack build && echo END_STACK_BUILD \" ]"
  , "    },"
  , "    { "
  , "       \"isBuildCommand\": true,"
  , "       \"taskName\": \"stack clean & build\","
  , "       \"args\": [ \"echo START_STACK_CLEAN_AND_BUILD && cd ${workspaceRoot} && stack clean && stack build && echo END_STACK_CLEAN_AND_BUILD \" ]"
  , "    },"
  , "    { "
  , "       \"isTestCommand\": true,"
  , "       \"taskName\": \"stack test\","
  , "       \"args\": [ \"echo START_STACK_TEST && cd ${workspaceRoot} && stack test && echo END_STACK_TEST \" ]"
  , "    },"
  , "    { "
  , "       \"isWatching\": true,"
  , "       \"taskName\": \"stack watch\","
  , "       \"args\": [ \"echo START_STACK_WATCH && cd ${workspaceRoot} && stack build --test --no-run-tests --file-watch && echo END_STACK_WATCH \" ]"
  , "    }"
  , "  ]"
  , "}"
  ]



-- |
--
--
_ERR_MSG_URL :: [String]
_ERR_MSG_URL = [ "`stack update` and install new phoityen-vscode."
               , "Or check information on https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode"
               ]



-- |
--
--
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 mvarCtx = 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
          cnt <- BSL.hGet stdin len
          handleRequest cmdData mvarCtx newBuf 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 -> BSL.ByteString -> IO ()
handleRequest cmdData mvarCtx contLenStr jsonStr = do
  case J.eitherDecode jsonStr :: Either String J.Request of
    Left  err -> do
      -- req_secが不明のため、エラー出力のみ行う。
      -- ただし、initializeが完了していない場合は、エラー出力イベントが受理されない。
      -- launchしていな場合はログ出力ができない。
      -- 無視して、次のリクエストを待つ。
      let msg =  L.intercalate " " [ "request request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
              ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL)
              ++ "\n"

      putStrLnStderr mvarCtx msg

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

    Right (J.Request cmd) -> handle contLenStr jsonStr cmd
    
  wait cmdData mvarCtx

  where

    handle contLenStr jsonStr "initialize" = case J.eitherDecode jsonStr :: Either String J.InitializeRequest of
      Right req -> initializeHandler mvarCtx req
      Left  err -> do
        -- initializeが完了していない場合は、エラー出力イベントが受理されない。
        -- responceをエラーで返す。メッセージは1行で作成する必要がある。
        -- launchしていな場合はログ出力ができない。
        -- res_seqは1固定とする。
        let msg = L.intercalate " " $ ["initialize request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err] ++ _ERR_MSG_URL
        resSeq <- incResSeq mvarCtx
        sendResponse $ J.encode $ J.parseErrorInitializeResponse resSeq msg


    handle contLenStr jsonStr "launch" = case J.eitherDecode jsonStr :: Either String J.LaunchRequest of
      Right req -> launchHandler cmdData mvarCtx req
      Left  err -> do
        -- launchしていな場合はログ出力ができない。
        -- req_secが不明のため、エラー出力のみ行う。
        let msg = L.intercalate " " ["launch request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg

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


    handle contLenStr jsonStr "disconnect" = case J.eitherDecode jsonStr :: Either String J.DisconnectRequest of
      Right req -> disconnectHandler cmdData mvarCtx req
      Left  err -> do
        let msg = L.intercalate " " ["disconnect request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr "setBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetBreakpointsRequest of
      Right req -> setBreakpointsHandler cmdData mvarCtx req
      Left  err -> do
        let msg = L.intercalate " " ["setBreakpoints request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr "continue" = case J.eitherDecode jsonStr :: Either String J.ContinueRequest of
      Right req -> continueHandler cmdData mvarCtx req
      Left  err -> do
        let msg = L.intercalate " " ["continue request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr "next" = case J.eitherDecode jsonStr :: Either String J.NextRequest of
      Right req -> stepOverHandler cmdData mvarCtx req
      Left  err -> do
        let msg = L.intercalate " " ["next request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr "stepIn" = case J.eitherDecode jsonStr :: Either String J.StepInRequest of
      Right req -> stepInHandler cmdData mvarCtx req
      Left  err -> do
        let msg = L.intercalate " " ["stepIn request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr "stepOut" = case J.eitherDecode jsonStr :: Either String J.StepOutRequest of
      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."

      Left  err -> do
        let msg = L.intercalate " " ["stepOut request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr "pause" = case J.eitherDecode jsonStr :: Either String J.PauseRequest of
      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."

      Left  err -> do
        let msg = L.intercalate " " ["pause request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr "stackTrace" = case J.eitherDecode jsonStr :: Either String J.StackTraceRequest of
      Right req -> stackTraceHandler cmdData mvarCtx req
      Left  err -> do
        let msg = L.intercalate " " ["stackTrace request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr "scopes" = case J.eitherDecode jsonStr :: Either String J.ScopesRequest of
      Right req -> scopesHandler cmdData mvarCtx req
      Left  err -> do
        let msg = L.intercalate " " ["scopes request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr "variables" = case J.eitherDecode jsonStr :: Either String J.VariablesRequest of
      Right req -> variablesHandler cmdData mvarCtx req
      Left  err -> do
        let msg = L.intercalate " " ["variables request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr "source" = case J.eitherDecode jsonStr :: Either String J.SourceRequest of
      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."

      Left  err -> do
        let msg = L.intercalate " " ["source request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr "threads" = case J.eitherDecode jsonStr :: Either String J.ThreadsRequest of
      Right req -> threadsHandler cmdData mvarCtx req
      Left  err -> do
        let msg = L.intercalate " " ["threads request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr "evaluate" = case J.eitherDecode jsonStr :: Either String J.EvaluateRequest of
      Right req -> evaluateHandler cmdData mvarCtx req
      Left  err -> do
        let msg = L.intercalate " " ["evaluate request parce error.", lbs2str contLenStr, lbs2str jsonStr, show err]
                ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL) ++ "\n"
        putStrLnStderr mvarCtx msg


    handle contLenStr jsonStr cmd = do
      let msg = L.intercalate " " ["unknown request command.", cmd, lbs2str contLenStr, lbs2str jsonStr]
      putStrLnStderr mvarCtx msg


-- |
--
sendEvent :: BSL.ByteString -> IO ()
sendEvent str = sendResponseInternal str

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


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


-- |
--
sendResponse :: BSL.ByteString -> IO ()
sendResponse 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 req@(J.InitializeRequest seq _ _ _) = flip E.catches handlers $ do
  resSeq <- incResSeq mvarCtx
  let capa = J.InitializeResponseCapabilites False False True True [] False 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 = L.intercalate " " ["initialize request error.", show req, show e]
      resSeq <- incResSeq mvarCtx
      sendResponse $ J.encode $ J.errorInitializeResponse resSeq req msg 
      putStrLnStderr mvarCtx 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
      logFile     = J.logFileLaunchRequestArguments args
      logLevelStr = J.logLevelLaunchRequestArguments args
      prmptStr    = J.ghciPromptLaunchRequestArguments args
      cmdStr      = J.ghciCmdLaunchRequestArguments args

  -- コンテキストデータの保持
  ctx <- takeMVar mvarCtx
  putMVar mvarCtx ctx {
      workspaceDebugContext = ws
    , startupDebugContext   = su
    }

  envSetPromptDebugCommandData cmdData $ prmptStr

  -- ロギング設定
  logLevel <- case readMay logLevelStr of
    Just lv -> return lv
    Nothing -> do
      putStrLnStderr mvarCtx $ "log priority is invalid. WARNING set. [" ++ logLevelStr ++ "]"
      return WARNING

  setupLogger logFile logLevel

  logRequest $ show req

  -- tasks.jsonファイルの準備
  prepareTasksJsonFile mvarCtx ws


  -- ghciのランチ
  runGHCi cmdData mvarCtx cmdStr ws >>= ghciLaunched 

    
  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = L.intercalate " " ["launch request error.", show req, show e]
      resSeq <- incResSeq mvarCtx
      sendResponse $ J.encode $ J.errorLaunchResponse resSeq req msg 
      putStrLnStderr mvarCtx msg


    -- |
    -- 
    prepareTasksJsonFile :: MVar DebugContext -> FilePath -> IO ()
    prepareTasksJsonFile mvarCtx ws = do
      let jsonFile = ws </> ".vscode" </> "tasks.json"
    
      doesFileExist jsonFile >>= \case
        True  -> infoM _LOG_NAME $ "tasks.json file exists. " ++ jsonFile 
        False -> do
          putStrLnConsole mvarCtx $ "create tasks.json file. " ++ jsonFile
          saveFileLBS jsonFile _TASKS_JSON_FILE_CONTENTS

    -- |
    -- 
    ghciLaunched False = do
      let msg = L.intercalate " " ["ghci launch error."]
      resSeq <- incResSeq mvarCtx
      sendResponse $ J.encode $ J.errorLaunchResponse resSeq req msg 
      putStrLnStderr mvarCtx msg

    ghciLaunched True = do
      startupRes <- loadHsFile cmdData mvarCtx (J.startupLaunchRequestArguments args)

      when (False == startupRes) $ do
        let msg = L.intercalate " " ["startup load error.", J.startupLaunchRequestArguments args]
        putStrLnStderr mvarCtx msg

      -- レスポンスとinitializedイベント送信
      resSeq <- incResSeq mvarCtx
      sendResponseL $ J.encode $ J.defaultLaunchResponse resSeq req
    
      resSeq <- incResSeq mvarCtx
      sendEventL $ J.encode $ J.defaultInitializedEvent resSeq
    
      -- ファイル変更ウォッチの開始
      watch cmdData mvarCtx
    
      putStrLnConsole mvarCtx $ L.intercalate "\n" infoMsg
      putStrStdout mvarCtx $ J.ghciPromptLaunchRequestArguments args
    
    -- ランチ完了後のメッセージ出力
    infoMsg = [
              ""
            , "  Now, ghci initialized."
            , "  Press F5 to start debugging."
            , "  Or modify source code. it will be loaded to ghci automatically."
            , ""
            ]

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

  logRequest $ show req

  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
  sendResponseL $ J.encode $ J.defaultDisconnectResponse resSeq req

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = L.intercalate " " ["disconnect request error.", show req, show e]
      resSeq <- incResSeq mvarCtx
      sendResponseL $ J.encode $ J.errorDisconnectResponse resSeq req msg 
      putStrLnStderr mvarCtx msg


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

  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}
  sendResponseL resStr

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


  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = L.intercalate " " ["setBreakpoints request error.", show req, show e]
      resSeq <- incResSeq mvarCtx
      sendResponseL $ J.encode $ J.errorSetBreakpointsResponse resSeq req msg 
      putStrLnStderr mvarCtx 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
  logRequest $ show req

  resSeq <- incResSeq mvarCtx
  let resStr = J.encode $ J.defaultThreadsResponse resSeq req
  sendResponseL resStr

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = L.intercalate " " ["threads request error.", show req, show e]
      resSeq <- incResSeq mvarCtx
      sendResponseL $ J.encode $ J.errorThreadsResponse resSeq req msg 
      putStrLnStderr mvarCtx msg

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

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

  moveFrame cmdData mvarCtx traceId

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

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = L.intercalate " " ["scopes request error.", show req, show e]
      resSeq <- incResSeq mvarCtx
      sendResponseL $ J.encode $ J.errorScopesResponse resSeq req msg 
      putStrLnStderr mvarCtx msg


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

  vals <- currentBindings

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

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = L.intercalate " " ["variables request error.", show req, show e]
      resSeq <- incResSeq mvarCtx
      sendResponseL $ J.encode $ J.errorVariablesResponse resSeq req msg 
      putStrLnStderr mvarCtx msg

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

      prmpt <- envGetPromptDebugCommandData cmdData

      cmdStr <- bindings
      infoM _LOG_NAME cmdStr

      bindStr <- getResult
      infoM _LOG_NAME bindStr

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

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


-- |
--
--
stackTraceHandler :: DebugCommandData -> MVar DebugContext -> J.StackTraceRequest -> IO ()
stackTraceHandler cmdData mvarCtx req = flip E.catches handlers $ do
  logRequest $ show req

  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}
      sendResponseL 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}
      sendResponseL resStr

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = L.intercalate " " ["stackTrace request error.", show req, show e]
      resSeq <- incResSeq mvarCtx
      sendResponseL $ J.encode $ J.errorStackTraceResponse resSeq req msg 
      putStrLnStderr mvarCtx msg


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

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

      traceStr <- getResult
      infoM _LOG_NAME 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 funcName filePath) = case parse parseHighlightTextRange "getActivatePosFromLine" filePath of
      Left err -> do
        errorM _LOG_NAME $ show err
        putStrLnStderr mvarCtx $ show err
        return xs
      Right (HighlightTextRangeData file sl sc el ec) -> return $ 
        J.StackFrame (read traceId) funcName (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc el ec : xs

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

  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 = L.intercalate " " ["evaluate request error.", show req, show e]
      resSeq <- incResSeq mvarCtx
      sendResponseL $ J.encode $ J.errorEvaluateResponse resSeq req msg 
      putStrLnStderr mvarCtx msg


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

      cmdStr <- forceVar exp
      infoM _LOG_NAME cmdStr
    
      cmdStr <- getResult
      infoM _LOG_NAME cmdStr

      let result = normalizeResult cmdStr

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


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

      cmdStr <- info exp
      putStrLnStdout mvarCtx cmdStr
      infoM _LOG_NAME cmdStr

      cmdStr <- getResult
      putStrStdout mvarCtx cmdStr
      infoM _LOG_NAME cmdStr

      let result = normalizeResult cmdStr

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


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

      prmpt <- envGetPromptDebugCommandData cmdData

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

      -- promptを消す
      let result = unlines . init . lines $ cmdStr

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

    normalizeResult = L.intercalate " " . filter (not . startswith "***"). filter (not . null) . map (replace "\t" "") . map strip . init . lines
    

-- |
--
--
continueHandler :: DebugCommandData -> MVar DebugContext -> J.ContinueRequest -> IO ()
continueHandler cmdData mvarCtx req = flip E.catches handlers $ do
  logRequest $ show req

  resSeq <- incResSeq mvarCtx
  let resStr = J.encode $ J.defaultContinueResponse resSeq req
  sendResponseL resStr

  startDebug cmdData mvarCtx

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = L.intercalate " " ["continue request error.", show req, show e]
      resSeq <- incResSeq mvarCtx
      sendResponseL $ J.encode $ J.errorContinueResponse resSeq req msg 
      putStrLnStderr mvarCtx msg


-- |
--
--
stepOverHandler :: DebugCommandData -> MVar DebugContext -> J.NextRequest -> IO ()
stepOverHandler cmdData mvarCtx req = flip E.catches handlers $ do
  logRequest $ show req

  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)."}
      sendResponseL resStr
    Just _ -> stepOver

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = L.intercalate " " ["stepOver request error.", show req, show e]
      resSeq <- incResSeq mvarCtx
      sendResponseL $ J.encode $ J.errorNextResponse resSeq req msg 
      putStrLnStderr mvarCtx 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
          sendResponseL resStr
    
          resSeq <- incResSeq mvarCtx
          let stopEvt    = J.defaultStoppedEvent resSeq
              stopEvtStr = J.encode stopEvt
          sendEventL stopEvtStr


-- |
--
--
stepInHandler :: DebugCommandData -> MVar DebugContext -> J.StepInRequest -> IO ()
stepInHandler cmdData mvarCtx req = flip E.catches handlers $ do
  logRequest $ show req

  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)."}
      sendResponseL resStr
    Just _ -> stepIn

  where
    handlers = [ E.Handler someExcept ]
    someExcept (e :: E.SomeException) = do
      let msg = L.intercalate " " ["stepIn request error.", show req, show e]
      resSeq <- incResSeq mvarCtx
      sendResponseL $ J.encode $ J.errorStepInResponse resSeq req msg 
      putStrLnStderr mvarCtx 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
          sendEventL 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
          sendResponseL resStr
    
          resSeq <- incResSeq mvarCtx
          let stopEvt    = J.defaultStoppedEvent resSeq
              stopEvtStr = J.encode stopEvt
          sendEventL 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


-- |
--
--
logRequest :: String -> IO ()
logRequest reqStr = do
  let msg = L.intercalate " " ["[REQUEST]", reqStr]
  infoM _LOG_NAME msg



-- |
--
--
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 -> String -> FilePath -> IO Bool
runGHCi cmdData mvarCtx cmdStr cwd = do
  let startCmd  = startDebugCommandData cmdData
      readWhile = readWhileDebugCommandData cmdData
      cmdList = filter (not.null) $ Data.String.Utils.split " " cmdStr
      cmd  = head cmdList
      opts = tail cmdList
      cmdLogStr = L.intercalate " " $ cmd : opts
  infoM _LOG_NAME $ cmdLogStr ++ "\n"
  putStrLnStdout mvarCtx $ cmdLogStr ++ "\n"

  startCmd cmd opts cwd

  str <- readWhile $ not . endsWithPrompt

  infoM _LOG_NAME str
  putStrStdout mvarCtx str

  withStarted $ endsWithPrompt 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

    endsWithPrompt str =
      if endswith _GHCI_PROMPT str then True
        else isEndsWithPrompt $ last $ lines str
    
    


-- |
--
--
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
         
         loadModule (last cont)
         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

    -- | 
    --   Ok, modules loaded: Lib, Main, LibSpec.
    --    ->  : module +Lib Main LibSpec
    loadModule str = do
      let loadModule = moduleDebugCommandData cmdData
          getResult  = readDebugCommandData cmdData
          args = replace "," "" $ replace "Ok, modules loaded: " "+" $ init $ strip str
 
      cmdStr <- loadModule args
      putStrLnStdout mvarCtx cmdStr
      infoM _LOG_NAME cmdStr

      cmdStr <- getResult
      putStrStdout mvarCtx cmdStr
      infoM _LOG_NAME cmdStr
  
-- |
--  ブレークポイントを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


-- |
--  Loggerのセットアップ
-- 
setupLogger :: FilePath -> Priority -> IO ()
setupLogger logFile level = do
--  level <- case readMay logLevel of
--    Just a  -> return a
--    Nothing -> E.throwIO . E.userError $ "invalid log level[" ++ logLevel ++ "]"

  logStream <- openFile logFile AppendMode
  hSetEncoding logStream utf8

  logH <- LHS.streamHandler logStream level
  
  let logHandle  = logH {LHS.closeFunc = hClose}
      logFormat  = L.tfLogFormatter _LOG_FORMAT_DATE _LOG_FORMAT
      logHandler = LH.setFormatter logHandle logFormat

  L.updateGlobalLogger L.rootLoggerName $ L.setHandlers ([] :: [LHS.GenericHandler Handle])
  L.updateGlobalLogger _LOG_NAME $ L.setHandlers [logHandler]
  L.updateGlobalLogger _LOG_NAME $ L.setLevel level


-- |
--
-- 
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 ()


-- |
--
--
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


-- |
--
--
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






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

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

    parse8 = do
      _ <- manyTill anyChar (try (string "Stopped in "))
      _ <- manyTill anyChar (try (string ", "))
      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) (removeColorCode funcName) (init (strip filePath))

-- |
--
removeColorCode :: String -> String
removeColorCode str = case parse parser "removeColorCode" str of
  Right res -> res
  Left _    -> str
  where
    parser = do
      let _esc_code = chr 27
      char _esc_code >> char '[' >> anyChar >> char 'm' 
      funcName <- manyTill anyChar (char _esc_code)
      return funcName

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

    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


-- |
--
isEndsWithPrompt :: String -> Bool
isEndsWithPrompt str = case parse parser "isEndsWithPrompt" str of
  Right res -> res
  Left _    -> False
  where
    parser = do
      char '*'
      manyTill anyChar $ char '>'
      space
      eof
      return True