diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,4 +1,10 @@ +20170816 phoityne-vscode-0.0.15.0 + * [ADD] supported break-on-exception and break-on-error. + * [ADD] [5](https://github.com/phoityne/phoityne-vscode/issues/5) :adding ghci run enviroment variable setting. + * [MODIFY] [21](https://github.com/phoityne/phoityne-vscode/issues/21) : support evaluateName attribute for watch variable. + + 20170507 phoityne-vscode-0.0.14.0 * [ADD] [15](https://github.com/phoityne/phoityne-vscode/issues/15) : adding main args setting to launch.json * [FIX] [16](https://github.com/phoityne/phoityne-vscode/issues/16) : Exit on stdin eof diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,22 +7,27 @@ ## Information -* [2017/05/07] phoityne-vscode released. - * Marketplace [phoityne-vscode-0.0.12](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode) - * hackage [phoityne-vscode-0.0.14.0](https://hackage.haskell.org/package/phoityne-vscode) +* [2017/08/16] phoityne-vscode released. + * Marketplace [phoityne-vscode-0.0.13](https://marketplace.visualstudio.com/items?itemName=phoityne.phoityne-vscode) + * hackage [phoityne-vscode-0.0.15.0](https://hackage.haskell.org/package/phoityne-vscode) + __Need update from hackage !!.__ * Release Summary - * ADD [15](https://github.com/phoityne/phoityne-vscode/issues/15) : adding main args setting to launch.json - * FIX [16](https://github.com/phoityne/phoityne-vscode/issues/16) : Exit on stdin eof + * [ADD] supported break-on-exception and break-on-error. + * [ADD] [5](https://github.com/phoityne/phoityne-vscode/issues/5) : adding ghci run enviroment variable setting. + __Check!! that there is a ""ghciEnv": {}," setting in the launch.json.__ + * [MODIFY] [21](https://github.com/phoityne/phoityne-vscode/issues/21) : support evaluateName attribute for watch variable. -![01_debug.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/01_debug.gif) +![10_quick_start.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/10_quick_start.gif) +(This sample project is available from [here](https://github.com/phoityne/stack-project-template).) ## Important -* Limitation. Breakpoint can be set in a .hs file which defineds "module ... where". -* Limitation. Source file extension must be ".hs" -* Limitation. Can not use STDIN handle while debugging. +* __LIMITATION__: Breakpoint can be set in a .hs file which defineds "module ... where". +* __LIMITATION__: Source file extension must be ".hs" +* __LIMITATION__: Can not use STDIN handle while debugging. +* __LIMITATION__: Changing ghci prompt is not allowed in the .ghci file. * When you start debugging for the first time, .vscode/tasks.json will be created automatically. Then you can use F6, F7, F8 shortcut key. * F5 : start debug * F6 : show command menu (for stack watch) @@ -54,7 +59,7 @@ C:\Users\[user name]\AppData\Roaming\local\bin\phoityne-vscode.exe % phoityne-vscode --version - phoityne-vscode-0.0.14.0 + phoityne-vscode-0.0.15.0 % % code @@ -104,24 +109,29 @@ ![07_hit_count.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/07_hit_count.gif) +### Break on Exception + +![08_exception.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/08_exception.gif) + + ### Repl & Completions ![06_repl.gif](https://raw.githubusercontent.com/phoityne/phoityne-vscode/master/docs/06_repl.gif) ## Capabilites -* supportsConfigurationDoneRequest : yes -* supportsFunctionBreakpoints : yes -* supportsConditionalBreakpoints : yes -* supportsHitConditionalBreakpoints : yes -* supportsEvaluateForHovers : yes -* exceptionBreakpointFilters : no +* supportsConfigurationDoneRequest : **yes** +* supportsFunctionBreakpoints : **yes** +* supportsConditionalBreakpoints : **yes** +* supportsHitConditionalBreakpoints : **yes** +* supportsEvaluateForHovers : **yes** +* exceptionBreakpointFilters : **yes** * supportsStepBack : no * supportsSetVariable : no * supportsRestartFrame : no * supportsGotoTargetsRequest : no * supportsStepInTargetsRequest : no -* supportsCompletionsRequest : yes +* supportsCompletionsRequest : **yes** * supportsModulesRequest : no * additionalModuleColumns : no * supportedChecksumAlgorithms : no @@ -129,6 +139,9 @@ * supportsExceptionOptions : no * supportsValueFormattingOptions : no * supportsExceptionInfoRequest : no +* supportTerminateDebuggee : no +* supportsDelayedStackTraceLoading : no + ## Configuration diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -3,7 +3,7 @@ module Main where -import qualified Phoityne.VSCode.IO.Main as M +import qualified Phoityne.VSCode.Main as M import System.Exit -- | diff --git a/app/Phoityne/GHCi.hs b/app/Phoityne/GHCi.hs --- a/app/Phoityne/GHCi.hs +++ b/app/Phoityne/GHCi.hs @@ -1,8 +1,8 @@ module Phoityne.GHCi ( - module Phoityne.GHCi.IO.Process -, module Phoityne.GHCi.IO.Command + module Phoityne.GHCi.Process +, module Phoityne.GHCi.Command ) where -import Phoityne.GHCi.IO.Process -import Phoityne.GHCi.IO.Command +import Phoityne.GHCi.Process +import Phoityne.GHCi.Command diff --git a/app/Phoityne/GHCi/Command.hs b/app/Phoityne/GHCi/Command.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/GHCi/Command.hs @@ -0,0 +1,639 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} + + +module Phoityne.GHCi.Command ( + SourcePosition(..) + , StackFrame(..) + , BindingData(..) + , start + , quit + , set + , loadFile + , loadModule + , setBreak + , setFuncBreak + , delete + , traceMain + , trace + , step + , stepLocal + , history + , back + , forward + , bindings + , force + , info + , showType + , showKind + , execBool + , exec + , complete + ) where + +import Phoityne.GHCi.Process +import Text.Parsec +import Data.Functor.Identity +import Data.Char +import qualified Data.List as L +import qualified Data.Map as M +import qualified System.Exit as S +import qualified Data.String.Utils as U + + +-- | +-- +_HS_FILE_EXT :: String +_HS_FILE_EXT = ".hs" + +-- | +-- +_GHCI_PROMPT :: String +_GHCI_PROMPT = "Prelude> " + + +-- | +-- +type OutputHandler = String -> IO () + +-- | +-- +type GHCiCommand = String + +-- | +-- +type GHCiOption = String + +-- | +-- +type ModuleName = String + +-- | +-- +type LineNo = Int + +-- | +-- +type ColNo = Int + +-- | +-- +type BreakId = Int + +-- | +-- +data SourcePosition = SourcePosition { + filePathSourcePosition :: FilePath + , startLineNoSourcePosition :: Int + , startColNoSourcePosition :: Int + , endLineNoSourcePosition :: Int + , endColNoSourcePosition :: Int + } deriving (Show, Read, Eq, Ord) + +-- | +-- +data StackFrame = StackFrame { + idStackFrame :: Int + , functionStackFrame :: String + , positionStackFrame :: SourcePosition + } deriving (Show, Read, Eq, Ord) + + +-- | +-- +data BindingData = BindingData { + nameBindingData :: String + , typeBindingData :: String + , valueBindingData :: String + } deriving (Show, Read, Eq, Ord) + + +-- | +-- +start :: OutputHandler + -> GHCiCommand + -> [GHCiOption] + -> FilePath + -> String + -> M.Map String String + -> IO (Either ErrorData GHCiProcess) +start outHdl cmd opts cwd pmt envs = do + outHdl $ L.intercalate " " $ (cmd : opts) ++ ["in " ++ cwd, "\n"] + runProcess cmd opts cwd pmt envs >>= withProcess + where + withProcess (Left err) = return $ Left err + withProcess (Right ghci) = readCharWhile ghci (not.endOfStartMsg) >>= setupGHCi ghci + + setupGHCi _ (Left err) = return $ Left err + setupGHCi ghci (Right msg) = do + outHdl msg + setPrompt ghci + + setPrompt ghci@(GHCiProcess _ _ _ _ pmt) = set ghci outHdl ("prompt \"" ++ pmt ++ "\"") >>= \case + Left err -> return $ Left err + Right _ -> setPrompt2 ghci + + setPrompt2 ghci@(GHCiProcess _ _ _ _ pmt) = set ghci outHdl ("prompt2 \"" ++ pmt ++ "\"") >>= \case + Left err -> return $ Left err + Right _ -> return $ Right ghci + + endOfStartMsg msg + | U.endswith _GHCI_PROMPT msg = True + | endOfModLoadPrompt (last (lines msg)) = True + | otherwise = False + + endOfModLoadPrompt str = case parse endOfModLoadPromptParser "endOfModLoadPrompt" str of + Right _ -> True + Left _ -> False + + endOfModLoadPromptParser = do + char '*' >> manyTill anyChar (char '>') >> space >> eof + return True + +-- | +-- +quit :: GHCiProcess -> OutputHandler -> IO (Either ErrorData S.ExitCode) +quit ghci outHdl = do + let cmd = ":quit" + outHdl $ cmd ++ "\n" + + writeLine ghci cmd >>= \case + Left err -> return $ Left err + Right _ -> readTillEOF ghci >>= \case + Left err -> return $ Left err + Right msg -> do + outHdl msg + exitProcess ghci + + +-- | +-- +set :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData ()) +set ghci outHdl cmdArg = do + let cmd = ":set " ++ cmdArg + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right _ -> return $ Right () + +-- | +-- +loadFile :: GHCiProcess + -> OutputHandler + -> FilePath + -> IO (Either ErrorData [ModuleName]) +loadFile ghci outHdl cmdArg = do + let cmd = ":load " ++ cmdArg + outHdl $ cmd ++ "\n" + writeLine ghci cmd >>= \case + Left err -> return $ Left err + Right _ -> readLineWhileIO ghci endOfLoadFile >>= withLoadResult + + where + endOfLoadFile acc = do + let curStr = takeLastMsg acc + outHdl $ curStr ++ "\n" + if| U.startswith "Ok," curStr -> return False + | U.startswith "Failed," curStr -> return False + | otherwise -> return True + + takeLastMsg [] = "" + takeLastMsg xs = last xs + + withLoadResult (Left err ) = return $ Left err + withLoadResult (Right msges) = readTillPrompt ghci >>= \case + Left err -> return $ Left err + Right msg -> do + outHdl msg + withLoadResultMsg (takeLastMsg msges) + + -- | + -- Ok, modules loaded: Lib, Main, LibSpec. -> [Lib, Main, LibSpec] + -- Failed, modules loaded: none. + -- + withLoadResultMsg msg + | U.startswith "Ok," msg = + return $ Right + $ U.split ", " + $ U.replace "Ok, modules loaded: " "" + $ init + $ U.strip + $ msg + | otherwise = return $ Left $ "file load error. '" ++ cmdArg ++ "'" + + +-- | +-- +loadModule :: GHCiProcess -> OutputHandler -> [ModuleName] -> IO (Either ErrorData ()) +loadModule ghci outHdl mods = do + let cmd = ":module + *" ++ U.join " *" mods + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right _ -> return $ Right () + +-- | +-- +setBreak :: GHCiProcess + -> OutputHandler + -> ModuleName + -> LineNo + -> ColNo + -> IO (Either ErrorData (BreakId, SourcePosition)) +setBreak ghci outHdl modName lineNo col = do + let cmd = ":break " ++ modName ++ " " ++ show lineNo ++ (if (-1) == col then "" else " " ++ show col) + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> getBreakId msg + + where + getBreakId msg = case parse getBreakIdParser "getBreakId" msg of + Right no -> return $ Right no + Left err -> return $ Left $ "unexpected break set result. " ++ show err ++ msg + + getBreakIdParser = do + _ <- manyTill anyChar (string "Breakpoint ") + no <- manyTill digit (string " activated at ") + pos <- parsePosition + return (read no, pos) + +-- | +-- +setFuncBreak :: GHCiProcess + -> OutputHandler + -> String + -> IO (Either ErrorData (BreakId, SourcePosition)) +setFuncBreak ghci outHdl name = do + let cmd = ":break " ++ name + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> getBreakId msg + + where + getBreakId msg = case parse getBreakIdParser "getBreakId" msg of + Right no -> return $ Right no + Left err -> return $ Left $ "unexpected break set result. " ++ show err ++ msg + + getBreakIdParser = do + _ <- manyTill anyChar (string "Breakpoint ") + no <- manyTill digit (string " activated at ") + pos <- parsePosition + return (read no, pos) + +-- | +-- +delete :: GHCiProcess -> OutputHandler -> BreakId -> IO (Either ErrorData ()) +delete ghci outHdl bid = do + let cmd = ":delete " ++ show bid + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right _ -> return $ Right () + +-- | +-- +traceMain :: GHCiProcess -> OutputHandler -> IO (Either ErrorData (Maybe SourcePosition)) +traceMain ghci outHdl = do + let cmd = ":trace main" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ mayException msg + +-- | +-- +trace :: GHCiProcess -> OutputHandler -> IO (Either ErrorData (Maybe SourcePosition)) +trace ghci outHdl = do + let cmd = ":trace" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ mayException msg + +-- | +-- +step :: GHCiProcess -> OutputHandler -> IO (Either ErrorData (Maybe SourcePosition)) +step ghci outHdl = do + let cmd = ":step" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ mayException msg + +-- | +-- +stepLocal :: GHCiProcess -> OutputHandler -> IO (Either ErrorData (Maybe SourcePosition)) +stepLocal ghci outHdl = do + let cmd = ":steplocal" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ mayException msg + + +-- | +-- +mayException :: String -> Either ErrorData (Maybe SourcePosition) +mayException msg + | L.isInfixOf "Stopped in " msg = Right Nothing + | otherwise = case extractSourcePosition msg of + Left err -> Left err + Right pos -> Right $ Just pos + +-- | +-- +history :: GHCiProcess -> OutputHandler -> IO (Either ErrorData [StackFrame]) +history ghci outHdl = do + let cmd = ":history" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractStackFrame msg + +-- | +-- +back :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData SourcePosition) +back ghci outHdl _ = do + -- let cmd = ":back " ++ show val + exec ghci outHdl ":back" >>= \case + Left err -> return $ Left err + Right msg -> return $ extractTracePosition msg + +-- | +-- +forward :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData SourcePosition) +forward ghci outHdl _ = do + -- let cmd = ":forward " ++ show val + exec ghci outHdl ":forward" >>= \case + Left err -> return $ Left err + Right msg -> return $ extractTracePosition msg + +-- | +-- +bindings :: GHCiProcess -> OutputHandler -> IO (Either ErrorData [BindingData]) +bindings ghci outHdl = do + let cmd = ":show bindings" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> do + let msgs = lines msg + if 1 == length msgs then return $ Right [] + else return $ extractBindingBindingDatas $ unlines $ init $ msgs + + +-- | +-- +force :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) +force ghci outHdl target = do + let cmd = ":force " ++ target + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) + +-- | +-- +info :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) +info ghci outHdl target = do + let cmd = ":info " ++ target + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) + +-- | +-- +showType :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) +showType ghci outHdl target = do + let cmd = ":type " ++ target + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) + +-- | +-- +showKind :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) +showKind ghci outHdl target = do + let cmd = ":kind " ++ target + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) + +-- | +-- +execBool :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData Bool) +execBool ghci outHdl cmd = exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ getConditionResult msg + + where + getConditionResult :: String -> Either ErrorData Bool + getConditionResult res + | U.startswith "True" res = Right True + | U.startswith "False" res = Right False + | otherwise = Left $ "invalid condition result. " ++ res + +-- | +-- run command and return result string. +-- +exec :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) +exec ghci outHdl cmd = do + outHdl $ cmd ++ "\n" + + writeLine ghci cmd >>= \case + Left err -> return $ Left err + Right _ -> readTillPrompt ghci >>= \case + Left err -> return $ Left err + Right msg -> do + outHdl msg + return $ Right msg + +-- | +-- +complete :: GHCiProcess -> OutputHandler -> String -> Int -> IO (Either ErrorData [String]) +complete ghci outHdl key size = do + let cmd = ":complete repl 0-" ++ (show size) ++ " \"" ++ key ++ "\"" + exec ghci outHdl cmd >>= \case + Left err -> return $ Left err + Right msg -> return $ Right $ map normalize $ extracCompleteList $ lines msg + + where + extracCompleteList [] = [] + extracCompleteList (_:[]) = [] + extracCompleteList (_:_:[]) = [] + extracCompleteList xs = tail . init $ xs + + normalize xs + | 2 < length xs = tail . init $ xs + | otherwise = xs + +-- | +-- Private Utility +-- + +-- | +-- +extractSourcePosition :: String -> (Either ErrorData SourcePosition) +extractSourcePosition src = case parse sourcePositionParser "extractSourcePosition" src of + Right pos -> Right pos + Left err -> Left $ show err ++ " [INPUT]" ++ src + + where + sourcePositionParser = try parse7 <|> try parse8 + + parse7 = do + _ <- manyTill anyChar (try (string "Stopped at ")) + parsePosition + + parse8 = do + _ <- manyTill anyChar (try (string "Stopped in ")) + _ <- manyTill anyChar (try (string ", ")) + parsePosition + +-- | +-- parser for +-- 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: +-- +parsePosition :: forall u. ParsecT String u Identity SourcePosition +parsePosition = do + path <- manyTill anyChar (try (string (_HS_FILE_EXT ++ ":"))) + (sl, sn, el, en) <- try parseA <|> try parseB <|> try parseC + return $ SourcePosition (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)) + + -- | + -- to lowercase Windows drive letter + drive2lower :: FilePath -> FilePath + drive2lower (x : ':' : xs) = toLower x : ':' : xs + drive2lower xs = xs + +-- | +-- +-- parser of +-- Phoityne>>= :history +-- -6 : spec (D:\haskell\unit-testing\test\LibSpec.hs:20:9-25) +-- -7 : spec (D:\haskell\unit-testing\test\LibSpec.hs:(34,7)-(35,26)) +-- +-- +extractStackFrame :: String -> (Either ErrorData [StackFrame]) +extractStackFrame src = go [] $ reverse $ filter (U.startswith "-") $ lines src + where + go acc [] = Right acc + go acc (x:xs) = case parse stackFrameParser "extractStackFrame" (init x) of + Left err -> Left $ show err ++ " " ++ x + Right dat -> go (dat:acc) xs + + stackFrameParser = do + char '-' + traceId <- manyTill digit (many1 space >> char ':' >> space) + funcName <- manyTill anyChar (space >> char '(') + pos <- parsePosition + + return $ StackFrame (read traceId) (removeColorCode funcName) pos + + removeColorCode str = case parse removeColorCodeParser "removeColorCode" str of + Right res -> res + Left _ -> str + + removeColorCodeParser = do + let _esc_code = chr 27 + char _esc_code >> char '[' >> anyChar >> char 'm' + funcName <- manyTill anyChar (char _esc_code) + return funcName + +-- | +-- +-- parser of +-- Phoityne>>= :back 10 +-- Logged breakpoint at D:\haskell\unit-testing8\test\LibSpec.hs:(30,7)-(31,25) +-- Stopped at D:\haskell\unit-testing8\test\LibSpec.hs:31:9-25 +-- +extractTracePosition :: String -> (Either ErrorData SourcePosition) +extractTracePosition src = case parse extractTracePositionParser "extractTracePosition" src of + Right pos -> Right pos + Left err -> Left $ show err ++ " [INPUT]" ++ src + + where + extractTracePositionParser = try stopPos <|> try loggedPos + + stopPos = do + _ <- manyTill anyChar (try (string "Stopped at ")) + parsePosition + + loggedPos = do + _ <- manyTill anyChar (try (string "Logged breakpoint at ")) + parsePosition + +-- | +-- +-- parser of +-- Phoityne>>= :show bindings +-- _result :: +-- hspec-expectations-0.7.2:Test.Hspec.Expectations.Expectation = _ +-- it :: [String] = [] +-- Phoityne>>= +-- +extractBindingBindingDatas :: String -> Either ErrorData [BindingData] +extractBindingBindingDatas src = case parse bindingBindingDatasParser "extractBindingBindingDatas" src of + Right vals -> Right . reverse $ vals + Left err -> Left $ show err ++ " [INPUT]" ++ src + + where + bindingBindingDatasParser = do + varName <- manyTill anyChar (try (string " ::")) + bindingBindingDatasParser' (U.strip varName) [] + + bindingBindingDatasParser' varName acc = do + typeName <- manyTill anyChar (try (string " =")) + try (hasMore varName (U.strip typeName) acc) <|> lastItem varName (U.strip typeName) acc + + hasMore varName typeName acc = do + str <- manyTill anyChar (try (string " ::")) + let strs = lines str + if 1 == length strs then return $ BindingData varName typeName (U.strip str) : acc + else bindingBindingDatasParser' (U.strip (last strs)) + $ BindingData varName typeName (U.strip (U.join " " (init strs))) : acc + + lastItem varName typeName acc = do + valStr <- manyTill anyChar eof + return $ BindingData varName typeName (U.strip valStr) : acc + +-- | +-- +normalizeConsoleOut :: String -> String +normalizeConsoleOut = U.join " " . filter (not . U.startswith "***") . map U.strip . init . lines + + +-- | +-- Phoityne>>= :info IO xx +-- +-- :1:1: error: Not in scope: ‘xx’ +-- Phoityne>>= +-- +extractErrorResult :: String -> Either ErrorData String +extractErrorResult str = case parse errorResultParser "extractErrorResult" str of + Right errMsg -> Left errMsg + Left _ -> Right str + where + errorResultParser = do + _ <- manyTill anyChar (try (string "")) + _ <- manyTill anyChar (char ' ') + manyTill anyChar eof diff --git a/app/Phoityne/GHCi/IO/Command.hs b/app/Phoityne/GHCi/IO/Command.hs deleted file mode 100644 --- a/app/Phoityne/GHCi/IO/Command.hs +++ /dev/null @@ -1,627 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} - - -module Phoityne.GHCi.IO.Command ( - SourcePosition(..) - , StackFrame(..) - , BindingData(..) - , start - , quit - , set - , loadFile - , loadModule - , setBreak - , setFuncBreak - , delete - , traceMain - , trace - , step - , stepLocal - , history - , back - , forward - , bindings - , force - , info - , showType - , showKind - , execBool - , exec - , complete - ) where - -import Phoityne.GHCi.IO.Process -import Text.Parsec -import Data.Functor.Identity -import Data.Char -import qualified Data.List as L -import qualified System.Exit as S -import qualified Data.String.Utils as U - - --- | --- -_HS_FILE_EXT :: String -_HS_FILE_EXT = ".hs" - --- | --- -_GHCI_PROMPT :: String -_GHCI_PROMPT = "Prelude> " - - --- | --- -type OutputHandler = String -> IO () - --- | --- -type GHCiCommand = String - --- | --- -type GHCiOption = String - --- | --- -type ModuleName = String - --- | --- -type LineNo = Int - --- | --- -type ColNo = Int - --- | --- -type BreakId = Int - --- | --- -data SourcePosition = SourcePosition { - filePathSourcePosition :: FilePath - , startLineNoSourcePosition :: Int - , startColNoSourcePosition :: Int - , endLineNoSourcePosition :: Int - , endColNoSourcePosition :: Int - } deriving (Show, Read, Eq, Ord) - --- | --- -data StackFrame = StackFrame { - idStackFrame :: Int - , functionStackFrame :: String - , positionStackFrame :: SourcePosition - } deriving (Show, Read, Eq, Ord) - - --- | --- -data BindingData = BindingData { - nameBindingData :: String - , typeBindingData :: String - , valueBindingData :: String - } deriving (Show, Read, Eq, Ord) - - --- | --- -start :: OutputHandler - -> GHCiCommand - -> [GHCiOption] - -> FilePath - -> String - -> IO (Either ErrorData GHCiProcess) -start outHdl cmd opts cwd pmt = do - outHdl $ L.intercalate " " $ (cmd : opts) ++ ["in " ++ cwd, "\n"] - runProcess cmd opts cwd pmt >>= withProcess - where - withProcess (Left err) = return $ Left err - withProcess (Right ghci) = readCharWhile ghci (not.endOfStartMsg) >>= setupGHCi ghci - - setupGHCi _ (Left err) = return $ Left err - setupGHCi ghci (Right msg) = do - outHdl msg - setPrompt ghci - - setPrompt ghci@(GHCiProcess _ _ _ _ pmt) = set ghci outHdl ("prompt \"" ++ pmt ++ "\"") >>= \case - Left err -> return $ Left err - Right _ -> setPrompt2 ghci - - setPrompt2 ghci@(GHCiProcess _ _ _ _ pmt) = set ghci outHdl ("prompt2 \"" ++ pmt ++ "\"") >>= \case - Left err -> return $ Left err - Right _ -> return $ Right ghci - - endOfStartMsg msg - | U.endswith _GHCI_PROMPT msg = True - | endOfModLoadPrompt (last (lines msg)) = True - | otherwise = False - - endOfModLoadPrompt str = case parse endOfModLoadPromptParser "endOfModLoadPrompt" str of - Right _ -> True - Left _ -> False - - endOfModLoadPromptParser = do - char '*' >> manyTill anyChar (char '>') >> space >> eof - return True - --- | --- -quit :: GHCiProcess -> OutputHandler -> IO (Either ErrorData S.ExitCode) -quit ghci outHdl = do - let cmd = ":quit" - outHdl $ cmd ++ "\n" - - writeLine ghci cmd >>= \case - Left err -> return $ Left err - Right _ -> readTillEOF ghci >>= \case - Left err -> return $ Left err - Right msg -> do - outHdl msg - exitProcess ghci - - --- | --- -set :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData ()) -set ghci outHdl cmdArg = do - let cmd = ":set " ++ cmdArg - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right _ -> return $ Right () - --- | --- -loadFile :: GHCiProcess - -> OutputHandler - -> FilePath - -> IO (Either ErrorData [ModuleName]) -loadFile ghci outHdl cmdArg = do - let cmd = ":load " ++ cmdArg - outHdl $ cmd ++ "\n" - writeLine ghci cmd >>= \case - Left err -> return $ Left err - Right _ -> readLineWhileIO ghci endOfLoadFile >>= withLoadResult - - where - endOfLoadFile acc = do - let curStr = takeLastMsg acc - outHdl $ curStr ++ "\n" - if| U.startswith "Ok," curStr -> return False - | U.startswith "Failed," curStr -> return False - | otherwise -> return True - - takeLastMsg [] = "" - takeLastMsg xs = last xs - - withLoadResult (Left err ) = return $ Left err - withLoadResult (Right msges) = readTillPrompt ghci >>= \case - Left err -> return $ Left err - Right msg -> do - outHdl msg - withLoadResultMsg (takeLastMsg msges) - - -- | - -- Ok, modules loaded: Lib, Main, LibSpec. -> [Lib, Main, LibSpec] - -- Failed, modules loaded: none. - -- - withLoadResultMsg msg - | U.startswith "Ok," msg = - return $ Right - $ U.split ", " - $ U.replace "Ok, modules loaded: " "" - $ init - $ U.strip - $ msg - | otherwise = return $ Left $ "file load error. '" ++ cmdArg ++ "'" - - --- | --- -loadModule :: GHCiProcess -> OutputHandler -> [ModuleName] -> IO (Either ErrorData ()) -loadModule ghci outHdl mods = do - let cmd = ":module + *" ++ U.join " *" mods - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right _ -> return $ Right () - --- | --- -setBreak :: GHCiProcess - -> OutputHandler - -> ModuleName - -> LineNo - -> ColNo - -> IO (Either ErrorData (BreakId, SourcePosition)) -setBreak ghci outHdl modName lineNo col = do - let cmd = ":break " ++ modName ++ " " ++ show lineNo ++ (if (-1) == col then "" else " " ++ show col) - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> getBreakId msg - - where - getBreakId msg = case parse getBreakIdParser "getBreakId" msg of - Right no -> return $ Right no - Left err -> return $ Left $ "unexpected break set result. " ++ show err ++ msg - - getBreakIdParser = do - _ <- manyTill anyChar (string "Breakpoint ") - no <- manyTill digit (string " activated at ") - pos <- parsePosition - return (read no, pos) - --- | --- -setFuncBreak :: GHCiProcess - -> OutputHandler - -> String - -> IO (Either ErrorData (BreakId, SourcePosition)) -setFuncBreak ghci outHdl name = do - let cmd = ":break " ++ name - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> getBreakId msg - - where - getBreakId msg = case parse getBreakIdParser "getBreakId" msg of - Right no -> return $ Right no - Left err -> return $ Left $ "unexpected break set result. " ++ show err ++ msg - - getBreakIdParser = do - _ <- manyTill anyChar (string "Breakpoint ") - no <- manyTill digit (string " activated at ") - pos <- parsePosition - return (read no, pos) - --- | --- -delete :: GHCiProcess -> OutputHandler -> BreakId -> IO (Either ErrorData ()) -delete ghci outHdl bid = do - let cmd = ":delete " ++ show bid - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right _ -> return $ Right () - --- | --- -traceMain :: GHCiProcess -> OutputHandler -> IO (Either ErrorData SourcePosition) -traceMain ghci outHdl = do - let cmd = ":trace main" - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> return $ extractSourcePosition msg - --- | --- -trace :: GHCiProcess -> OutputHandler -> IO (Either ErrorData SourcePosition) -trace ghci outHdl = do - let cmd = ":trace" - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> return $ extractSourcePosition msg - --- | --- -step :: GHCiProcess -> OutputHandler -> IO (Either ErrorData SourcePosition) -step ghci outHdl = do - let cmd = ":step" - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> return $ extractSourcePosition msg - --- | --- -stepLocal :: GHCiProcess -> OutputHandler -> IO (Either ErrorData SourcePosition) -stepLocal ghci outHdl = do - let cmd = ":steplocal" - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> return $ extractSourcePosition msg - --- | --- -history :: GHCiProcess -> OutputHandler -> IO (Either ErrorData [StackFrame]) -history ghci outHdl = do - let cmd = ":history" - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> return $ extractStackFrame msg - --- | --- -back :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData SourcePosition) -back ghci outHdl _ = do - -- let cmd = ":back " ++ show val - exec ghci outHdl ":back" >>= \case - Left err -> return $ Left err - Right msg -> return $ extractTracePosition msg - --- | --- -forward :: GHCiProcess -> OutputHandler -> Int -> IO (Either ErrorData SourcePosition) -forward ghci outHdl _ = do - -- let cmd = ":forward " ++ show val - exec ghci outHdl ":forward" >>= \case - Left err -> return $ Left err - Right msg -> return $ extractTracePosition msg - --- | --- -bindings :: GHCiProcess -> OutputHandler -> IO (Either ErrorData [BindingData]) -bindings ghci outHdl = do - let cmd = ":show bindings" - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> do - let msgs = lines msg - if 1 == length msgs then return $ Right [] - else return $ extractBindingBindingDatas $ unlines $ init $ msgs - - --- | --- -force :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) -force ghci outHdl target = do - let cmd = ":force " ++ target - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) - --- | --- -info :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) -info ghci outHdl target = do - let cmd = ":info " ++ target - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) - --- | --- -showType :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) -showType ghci outHdl target = do - let cmd = ":type " ++ target - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) - --- | --- -showKind :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) -showKind ghci outHdl target = do - let cmd = ":kind " ++ target - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> return $ extractErrorResult (normalizeConsoleOut msg) - --- | --- -execBool :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData Bool) -execBool ghci outHdl cmd = exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> return $ getConditionResult msg - - where - getConditionResult :: String -> Either ErrorData Bool - getConditionResult res - | U.startswith "True" res = Right True - | U.startswith "False" res = Right False - | otherwise = Left $ "invalid condition result. " ++ res - --- | --- run command and return result string. --- -exec :: GHCiProcess -> OutputHandler -> String -> IO (Either ErrorData String) -exec ghci outHdl cmd = do - outHdl $ cmd ++ "\n" - - writeLine ghci cmd >>= \case - Left err -> return $ Left err - Right _ -> readTillPrompt ghci >>= \case - Left err -> return $ Left err - Right msg -> do - outHdl msg - return $ Right msg - --- | --- -complete :: GHCiProcess -> OutputHandler -> String -> Int -> IO (Either ErrorData [String]) -complete ghci outHdl key size = do - let cmd = ":complete repl 0-" ++ (show size) ++ " \"" ++ key ++ "\"" - exec ghci outHdl cmd >>= \case - Left err -> return $ Left err - Right msg -> return $ Right $ map normalize $ extracCompleteList $ lines msg - - where - extracCompleteList [] = [] - extracCompleteList (_:[]) = [] - extracCompleteList (_:_:[]) = [] - extracCompleteList xs = tail . init $ xs - - normalize xs - | 2 < length xs = tail . init $ xs - | otherwise = xs - --- | --- Private Utility --- - --- | --- -extractSourcePosition :: String -> (Either ErrorData SourcePosition) -extractSourcePosition src = case parse sourcePositionParser "extractSourcePosition" src of - Right pos -> Right pos - Left err -> Left $ show err ++ " [INPUT]" ++ src - - where - sourcePositionParser = try parse7 <|> try parse8 - - parse7 = do - _ <- manyTill anyChar (try (string "Stopped at ")) - parsePosition - - parse8 = do - _ <- manyTill anyChar (try (string "Stopped in ")) - _ <- manyTill anyChar (try (string ", ")) - parsePosition - --- | --- parser for --- 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: --- -parsePosition :: forall u. ParsecT String u Identity SourcePosition -parsePosition = do - path <- manyTill anyChar (string (_HS_FILE_EXT ++ ":")) - (sl, sn, el, en) <- try parseA <|> try parseB <|> try parseC - return $ SourcePosition (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)) - - -- | - -- to lowercase Windows drive letter - drive2lower :: FilePath -> FilePath - drive2lower (x : ':' : xs) = toLower x : ':' : xs - drive2lower xs = xs - --- | --- --- parser of --- Phoityne>>= :history --- -6 : spec (D:\haskell\unit-testing\test\LibSpec.hs:20:9-25) --- -7 : spec (D:\haskell\unit-testing\test\LibSpec.hs:(34,7)-(35,26)) --- --- -extractStackFrame :: String -> (Either ErrorData [StackFrame]) -extractStackFrame src = go [] $ reverse $ filter (U.startswith "-") $ lines src - where - go acc [] = Right acc - go acc (x:xs) = case parse stackFrameParser "extractStackFrame" (init x) of - Left err -> Left $ show err ++ " " ++ x - Right dat -> go (dat:acc) xs - - stackFrameParser = do - char '-' - traceId <- manyTill digit (many1 space >> char ':' >> space) - funcName <- manyTill anyChar (space >> char '(') - pos <- parsePosition - - return $ StackFrame (read traceId) (removeColorCode funcName) pos - - removeColorCode str = case parse removeColorCodeParser "removeColorCode" str of - Right res -> res - Left _ -> str - - removeColorCodeParser = do - let _esc_code = chr 27 - char _esc_code >> char '[' >> anyChar >> char 'm' - funcName <- manyTill anyChar (char _esc_code) - return funcName - --- | --- --- parser of --- Phoityne>>= :back 10 --- Logged breakpoint at D:\haskell\unit-testing8\test\LibSpec.hs:(30,7)-(31,25) --- Stopped at D:\haskell\unit-testing8\test\LibSpec.hs:31:9-25 --- -extractTracePosition :: String -> (Either ErrorData SourcePosition) -extractTracePosition src = case parse extractTracePositionParser "extractTracePosition" src of - Right pos -> Right pos - Left err -> Left $ show err ++ " [INPUT]" ++ src - - where - extractTracePositionParser = try stopPos <|> try loggedPos - - stopPos = do - _ <- manyTill anyChar (try (string "Stopped at ")) - parsePosition - - loggedPos = do - _ <- manyTill anyChar (try (string "Logged breakpoint at ")) - parsePosition - --- | --- --- parser of --- Phoityne>>= :show bindings --- _result :: --- hspec-expectations-0.7.2:Test.Hspec.Expectations.Expectation = _ --- it :: [String] = [] --- Phoityne>>= --- -extractBindingBindingDatas :: String -> Either ErrorData [BindingData] -extractBindingBindingDatas src = case parse bindingBindingDatasParser "extractBindingBindingDatas" src of - Right vals -> Right . reverse $ vals - Left err -> Left $ show err ++ " [INPUT]" ++ src - - where - bindingBindingDatasParser = do - varName <- manyTill anyChar (try (string " :: ")) - bindingBindingDatasParser' (U.strip varName) [] - - bindingBindingDatasParser' varName acc = do - typeName <- manyTill anyChar (try (string " = ")) - try (hasMore varName (U.strip typeName) acc) <|> lastItem varName (U.strip typeName) acc - - hasMore varName typeName acc = do - str <- manyTill anyChar (try (string " :: ")) - let strs = lines str - if 1 == length strs then return $ BindingData varName typeName (U.strip str) : acc - else bindingBindingDatasParser' (U.strip (last strs)) - $ BindingData varName typeName (U.strip (U.join " " (init strs))) : acc - - lastItem varName typeName acc = do - valStr <- manyTill anyChar eof - return $ BindingData varName typeName (U.strip valStr) : acc - --- | --- -normalizeConsoleOut :: String -> String -normalizeConsoleOut = U.join " " . filter (not . U.startswith "***") . map U.strip . init . lines - - --- | --- Phoityne>>= :info IO xx --- --- :1:1: error: Not in scope: ‘xx’ --- Phoityne>>= --- -extractErrorResult :: String -> Either ErrorData String -extractErrorResult str = case parse errorResultParser "extractErrorResult" str of - Right errMsg -> Left errMsg - Left _ -> Right str - where - errorResultParser = do - _ <- manyTill anyChar (try (string "")) - _ <- manyTill anyChar (char ' ') - manyTill anyChar eof diff --git a/app/Phoityne/GHCi/IO/Process.hs b/app/Phoityne/GHCi/IO/Process.hs deleted file mode 100644 --- a/app/Phoityne/GHCi/IO/Process.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module Phoityne.GHCi.IO.Process ( - ErrorData - , GHCiProcess (..) - , runProcess - , exitProcess - , writeLine - , readTillPrompt - , readTillEOF - , readCharWhile - , readCharWhileIO - , readLineWhile - , readLineWhileIO - ) where - -import GHC.IO.Encoding -import Distribution.System -import qualified System.Process as S -import qualified System.IO as S -import qualified System.Exit as S -import qualified Control.Exception as E -import qualified Data.String.Utils as U - --- | --- command error message. --- -type ErrorData = String - --- | --- GHCi process data. --- -data GHCiProcess = GHCiProcess - { - inGHCiProcess :: S.Handle - , outGHCiProcess :: S.Handle - , errGHCiProcess :: S.Handle - , procGHCiProcess :: S.ProcessHandle - , promptGHCiProcess :: String - } - --- | --- run ghci. --- -runProcess :: String - -> [String] - -> FilePath - -> String - -> IO (Either ErrorData GHCiProcess) -runProcess cmd opts cwd pmt = flip E.catches handlers $ do - - (fromPhoityneHandle, toGHCiHandle) <- S.createPipe - (fromGHCiHandle, toPhoityneHandle) <- S.createPipe - - osEnc <- getReadHandleEncoding - - S.hSetBuffering toPhoityneHandle S.NoBuffering - S.hSetEncoding toPhoityneHandle osEnc - S.hSetNewlineMode toPhoityneHandle $ S.NewlineMode S.CRLF S.LF - - S.hSetBuffering fromPhoityneHandle S.NoBuffering - S.hSetEncoding fromPhoityneHandle S.utf8 - S.hSetNewlineMode fromPhoityneHandle $ S.NewlineMode S.LF S.LF - - S.hSetBuffering toGHCiHandle S.NoBuffering - S.hSetEncoding toGHCiHandle S.utf8 - S.hSetNewlineMode toGHCiHandle $ S.NewlineMode S.LF S.LF - - S.hSetBuffering fromGHCiHandle S.NoBuffering - S.hSetEncoding fromGHCiHandle osEnc - S.hSetNewlineMode fromGHCiHandle $ S.NewlineMode S.CRLF S.LF - - ghciProc <- S.runProcess cmd opts (Just cwd) Nothing (Just fromPhoityneHandle) (Just toPhoityneHandle) (Just toPhoityneHandle) - - return . Right $ GHCiProcess toGHCiHandle fromGHCiHandle fromGHCiHandle ghciProc pmt - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = return . Left . show $ e - - -- | - -- - -- - getReadHandleEncoding :: IO TextEncoding - getReadHandleEncoding = if - | Windows == buildOS -> mkTextEncoding "CP932//TRANSLIT" - | otherwise -> mkTextEncoding "UTF-8//TRANSLIT" - - --- | --- exit ghci. --- -exitProcess :: GHCiProcess -> IO (Either ErrorData S.ExitCode) -exitProcess (GHCiProcess _ _ _ proc _) = flip E.catches handlers $ do - code <- S.waitForProcess proc - return . Right $ code - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = return . Left . show $ e - --- | --- write to ghci. --- -writeLine :: GHCiProcess -> String -> IO (Either ErrorData ()) -writeLine (GHCiProcess ghciIn _ _ _ _) writeData = flip E.catches handlers $ S.hIsOpen ghciIn >>= \case - True -> do - S.hPutStrLn ghciIn writeData - return $ Right () - False -> return $ Left "handle not open." - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = return . Left . show $ e - --- | --- read char till prompt. --- -readTillPrompt :: GHCiProcess -> IO (Either ErrorData String) -readTillPrompt proc@(GHCiProcess _ _ _ _ pmt) = readCharWhile proc (not . U.endswith pmt) - --- | --- read char till EOF. --- -readTillEOF :: GHCiProcess -> IO (Either ErrorData String) -readTillEOF proc = readCharWhile proc (const True) - - --- | --- read char from ghci. --- -readCharWhile :: GHCiProcess -> (String -> Bool) -> IO (Either ErrorData String) -readCharWhile (GHCiProcess _ ghciOut _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case - True -> go [] - False -> return . Left $ "handle not open." - where - go acc = S.hIsEOF ghciOut >>= \case - True -> return . Right $ acc - False -> do - c <- S.hGetChar ghciOut - let acc' = acc ++ [c] - if condProc acc' then go acc' - else return . Right $ acc' - - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = return . Left . show $ e - --- | --- read char from ghci. --- -readCharWhileIO :: GHCiProcess -> (String -> IO Bool) -> IO (Either ErrorData String) -readCharWhileIO (GHCiProcess _ ghciOut _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case - True -> go [] - False -> return . Left $ "handle not open." - where - go acc = S.hIsEOF ghciOut >>= \case - True -> return . Right $ acc - False -> do - c <- S.hGetChar ghciOut - let acc' = acc ++ [c] - condProc acc' >>= \case - True -> go acc' - False -> return . Right $ acc' - - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = return . Left . show $ e - --- | --- read line from ghci. --- -readLineWhile :: GHCiProcess -> ([String] -> Bool) -> IO (Either ErrorData [String]) -readLineWhile (GHCiProcess _ ghciOut _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case - True -> go [] - False -> return . Left $ "handle not open." - where - go acc = S.hIsEOF ghciOut >>= \case - True -> return . Right $ acc - False -> do - l <- S.hGetLine ghciOut - let acc' = acc ++ [l] - if condProc acc' then go acc' - else return . Right $ acc' - - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = return . Left . show $ e - - --- | --- read line from ghci. --- -readLineWhileIO :: GHCiProcess -> ([String] -> IO Bool) -> IO (Either ErrorData [String]) -readLineWhileIO (GHCiProcess _ ghciOut _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case - True -> go [] - False -> return . Left $ "handle not open." - where - go acc = S.hIsEOF ghciOut >>= \case - True -> return . Right $ acc - False -> do - l <- S.hGetLine ghciOut - let acc' = acc ++ [l] - condProc acc' >>= \case - True -> go acc' - False -> return . Right $ acc' - - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = return . Left . show $ e diff --git a/app/Phoityne/GHCi/Process.hs b/app/Phoityne/GHCi/Process.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/GHCi/Process.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Phoityne.GHCi.Process ( + ErrorData + , GHCiProcess (..) + , runProcess + , exitProcess + , writeLine + , readTillPrompt + , readTillEOF + , readCharWhile + , readCharWhileIO + , readLineWhile + , readLineWhileIO + ) where + +import GHC.IO.Encoding +import Distribution.System +import qualified System.Process as S +import qualified System.IO as S +import qualified System.Exit as S +import qualified System.Environment as S +import qualified Control.Exception as E +import qualified Data.String.Utils as U +import qualified Data.Map as M + +-- | +-- command error message. +-- +type ErrorData = String + +-- | +-- GHCi process data. +-- +data GHCiProcess = GHCiProcess + { + inGHCiProcess :: S.Handle + , outGHCiProcess :: S.Handle + , errGHCiProcess :: S.Handle + , procGHCiProcess :: S.ProcessHandle + , promptGHCiProcess :: String + } + +-- | +-- run ghci. +-- +runProcess :: String + -> [String] + -> FilePath + -> String + -> M.Map String String + -> IO (Either ErrorData GHCiProcess) +runProcess cmd opts cwd pmt envs = flip E.catches handlers $ do + + (fromPhoityneHandle, toGHCiHandle) <- S.createPipe + (fromGHCiHandle, toPhoityneHandle) <- S.createPipe + + osEnc <- getReadHandleEncoding + + S.hSetBuffering toPhoityneHandle S.NoBuffering + S.hSetEncoding toPhoityneHandle osEnc + S.hSetNewlineMode toPhoityneHandle $ S.NewlineMode S.CRLF S.LF + + S.hSetBuffering fromPhoityneHandle S.NoBuffering + S.hSetEncoding fromPhoityneHandle S.utf8 + S.hSetNewlineMode fromPhoityneHandle $ S.NewlineMode S.LF S.LF + + S.hSetBuffering toGHCiHandle S.NoBuffering + S.hSetEncoding toGHCiHandle S.utf8 + S.hSetNewlineMode toGHCiHandle $ S.NewlineMode S.LF S.LF + + S.hSetBuffering fromGHCiHandle S.NoBuffering + S.hSetEncoding fromGHCiHandle osEnc + S.hSetNewlineMode fromGHCiHandle $ S.NewlineMode S.CRLF S.LF + + runEnvs <- getRunEnv + + ghciProc <- S.runProcess cmd opts (Just cwd) runEnvs (Just fromPhoityneHandle) (Just toPhoityneHandle) (Just toPhoityneHandle) + + return . Right $ GHCiProcess toGHCiHandle fromGHCiHandle fromGHCiHandle ghciProc pmt + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e + + -- | + -- + -- + getReadHandleEncoding :: IO TextEncoding + getReadHandleEncoding = if + | Windows == buildOS -> mkTextEncoding "CP932//TRANSLIT" + | otherwise -> mkTextEncoding "UTF-8//TRANSLIT" + + -- | + -- + -- + getRunEnv + | null envs = return Nothing + | otherwise = do + curEnvs <- S.getEnvironment + return $ Just $ M.toList envs ++ curEnvs + +-- | +-- exit ghci. +-- +exitProcess :: GHCiProcess -> IO (Either ErrorData S.ExitCode) +exitProcess (GHCiProcess _ _ _ proc _) = flip E.catches handlers $ do + code <- S.waitForProcess proc + return . Right $ code + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e + +-- | +-- write to ghci. +-- +writeLine :: GHCiProcess -> String -> IO (Either ErrorData ()) +writeLine (GHCiProcess ghciIn _ _ _ _) writeData = flip E.catches handlers $ S.hIsOpen ghciIn >>= \case + True -> do + S.hPutStrLn ghciIn writeData + return $ Right () + False -> return $ Left "handle not open." + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e + +-- | +-- read char till prompt. +-- +readTillPrompt :: GHCiProcess -> IO (Either ErrorData String) +readTillPrompt proc@(GHCiProcess _ _ _ _ pmt) = readCharWhile proc (not . U.endswith pmt) + +-- | +-- read char till EOF. +-- +readTillEOF :: GHCiProcess -> IO (Either ErrorData String) +readTillEOF proc = readCharWhile proc (const True) + + +-- | +-- read char from ghci. +-- +readCharWhile :: GHCiProcess -> (String -> Bool) -> IO (Either ErrorData String) +readCharWhile (GHCiProcess _ ghciOut _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case + True -> go [] + False -> return . Left $ "handle not open." + where + go acc = S.hIsEOF ghciOut >>= \case + True -> return . Right $ acc + False -> do + c <- S.hGetChar ghciOut + let acc' = acc ++ [c] + if condProc acc' then go acc' + else return . Right $ acc' + + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e + +-- | +-- read char from ghci. +-- +readCharWhileIO :: GHCiProcess -> (String -> IO Bool) -> IO (Either ErrorData String) +readCharWhileIO (GHCiProcess _ ghciOut _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case + True -> go [] + False -> return . Left $ "handle not open." + where + go acc = S.hIsEOF ghciOut >>= \case + True -> return . Right $ acc + False -> do + c <- S.hGetChar ghciOut + let acc' = acc ++ [c] + condProc acc' >>= \case + True -> go acc' + False -> return . Right $ acc' + + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e + +-- | +-- read line from ghci. +-- +readLineWhile :: GHCiProcess -> ([String] -> Bool) -> IO (Either ErrorData [String]) +readLineWhile (GHCiProcess _ ghciOut _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case + True -> go [] + False -> return . Left $ "handle not open." + where + go acc = S.hIsEOF ghciOut >>= \case + True -> return . Right $ acc + False -> do + l <- S.hGetLine ghciOut + let acc' = acc ++ [l] + if condProc acc' then go acc' + else return . Right $ acc' + + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e + + +-- | +-- read line from ghci. +-- +readLineWhileIO :: GHCiProcess -> ([String] -> IO Bool) -> IO (Either ErrorData [String]) +readLineWhileIO (GHCiProcess _ ghciOut _ _ _) condProc = flip E.catches handlers $ S.hIsOpen ghciOut >>= \case + True -> go [] + False -> return . Left $ "handle not open." + where + go acc = S.hIsEOF ghciOut >>= \case + True -> return . Right $ acc + False -> do + l <- S.hGetLine ghciOut + let acc' = acc ++ [l] + condProc acc' >>= \case + True -> go acc' + False -> return . Right $ acc' + + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = return . Left . show $ e diff --git a/app/Phoityne/VSCode/Control.hs b/app/Phoityne/VSCode/Control.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/Control.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Phoityne.VSCode.Control where + +import Phoityne.VSCode.Constant +import Phoityne.VSCode.Utility +import qualified Phoityne.VSCode.Argument as A +import qualified Phoityne.VSCode.Core as GUI +import qualified Data.ByteString.Lazy as BSL + +import System.IO +import Control.Concurrent +import Text.Parsec +import qualified Data.ConfigFile as C +import qualified System.Log.Logger as L + +-- | +-- +run :: A.ArgData + -> C.ConfigParser + -> IO Int +run _ _ = do + + hSetBuffering stdin NoBuffering + hSetEncoding stdin utf8 + + hSetBuffering stdout NoBuffering + hSetEncoding stdout utf8 + + mvarDat <- newMVar GUI.defaultDebugContextData {GUI.responseHandlerDebugContextData = sendResponse} + + wait mvarDat + + return 1 + +-- | +-- +-- +wait :: MVar GUI.DebugContextData -> IO () +wait mvarDat = go BSL.empty + where + go buf = BSL.hGet stdin 1 >>= withC buf + + withC buf c + | c == BSL.empty = unexpectedEOF + | otherwise = withBuf $ BSL.append buf c + + withBuf buf = case parse parser "readContentLength" (lbs2str buf) of + Left _ -> go buf + Right len -> BSL.hGet stdin len >>= withCnt buf + + withCnt buf cnt + | cnt == BSL.empty = unexpectedEOF + | otherwise = do + GUI.handleRequest mvarDat buf cnt + wait mvarDat + + parser = do + string "Content-Length: " + len <- manyTill digit (string _TWO_CRLF) + return . read $ len + + unexpectedEOF = do + L.criticalM _LOG_NAME "unexpected EOF on stdin." + return () + + + +-- | +-- +sendResponse :: BSL.ByteString -> IO () +sendResponse 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 + diff --git a/app/Phoityne/VSCode/Core.hs b/app/Phoityne/VSCode/Core.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/Core.hs @@ -0,0 +1,1857 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Phoityne.VSCode.Core ( + handleRequest +, DebugContextData(..) +, defaultDebugContextData +, initializeRequestHandler +) where + + +import qualified Phoityne.GHCi as G + +import Control.Concurrent +import Control.Monad +import Data.List.Split +import Data.Char +import Safe +import System.IO +import System.Exit +import System.FilePath +import System.Directory +import System.Log.Logger +import Text.Parsec +import qualified Control.Exception as E +import qualified Data.Aeson as J +import qualified Data.ByteString.Lazy as BSL +import qualified Data.String.Utils as U +import qualified Data.List as L +import qualified Data.Map as M +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 Phoityne.VSCode.Constant +import Phoityne.VSCode.Utility +import qualified Phoityne.VSCode.TH.BreakpointJSON as J +import qualified Phoityne.VSCode.TH.CompletionsItemJSON as J +import qualified Phoityne.VSCode.TH.CompletionsArgumentsJSON as J +import qualified Phoityne.VSCode.TH.CompletionsResponseBodyJSON as J +import qualified Phoityne.VSCode.TH.CompletionsRequestJSON as J +import qualified Phoityne.VSCode.TH.CompletionsResponseJSON as J +import qualified Phoityne.VSCode.TH.ConfigurationDoneRequestJSON as J +import qualified Phoityne.VSCode.TH.ConfigurationDoneResponseJSON as J +import qualified Phoityne.VSCode.TH.ContinueRequestJSON as J +import qualified Phoityne.VSCode.TH.ContinueResponseJSON as J +import qualified Phoityne.VSCode.TH.DisconnectRequestJSON as J +import qualified Phoityne.VSCode.TH.DisconnectResponseJSON as J +import qualified Phoityne.VSCode.TH.EvaluateArgumentsJSON as J +import qualified Phoityne.VSCode.TH.EvaluateBodyJSON as J +import qualified Phoityne.VSCode.TH.EvaluateRequestJSON as J +import qualified Phoityne.VSCode.TH.EvaluateResponseJSON as J +import qualified Phoityne.VSCode.TH.ExceptionBreakpointsFilterJSON as J +import qualified Phoityne.VSCode.TH.InitializedEventJSON as J +import qualified Phoityne.VSCode.TH.InitializeRequestJSON as J +import qualified Phoityne.VSCode.TH.InitializeResponseCapabilitesJSON as J +import qualified Phoityne.VSCode.TH.InitializeResponseJSON as J +import qualified Phoityne.VSCode.TH.LaunchRequestArgumentsJSON as J +import qualified Phoityne.VSCode.TH.LaunchRequestJSON as J +import qualified Phoityne.VSCode.TH.LaunchResponseJSON as J +import qualified Phoityne.VSCode.TH.NextRequestJSON as J +import qualified Phoityne.VSCode.TH.NextResponseJSON as J +import qualified Phoityne.VSCode.TH.OutputEventJSON as J +import qualified Phoityne.VSCode.TH.OutputEventBodyJSON as J +import qualified Phoityne.VSCode.TH.PauseRequestJSON as J +import qualified Phoityne.VSCode.TH.PauseResponseJSON as J +import qualified Phoityne.VSCode.TH.RequestJSON as J +import qualified Phoityne.VSCode.TH.ScopesArgumentsJSON as J +import qualified Phoityne.VSCode.TH.ScopesRequestJSON as J +import qualified Phoityne.VSCode.TH.ScopesResponseJSON as J +import qualified Phoityne.VSCode.TH.SetBreakpointsRequestArgumentsJSON as J +import qualified Phoityne.VSCode.TH.SetBreakpointsRequestJSON as J +import qualified Phoityne.VSCode.TH.SetBreakpointsResponseBodyJSON as J +import qualified Phoityne.VSCode.TH.SetBreakpointsResponseJSON as J +import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsRequestArgumentsJSON as J +import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsRequestJSON as J +import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsResponseBodyJSON as J +import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsResponseJSON as J +import qualified Phoityne.VSCode.TH.SetExceptionBreakpointsRequestArgumentsJSON as J +import qualified Phoityne.VSCode.TH.SetExceptionBreakpointsRequestJSON as J +import qualified Phoityne.VSCode.TH.SetExceptionBreakpointsResponseJSON as J +import qualified Phoityne.VSCode.TH.SourceBreakpointJSON as J +import qualified Phoityne.VSCode.TH.FunctionBreakpointJSON as J +import qualified Phoityne.VSCode.TH.SourceJSON as J +import qualified Phoityne.VSCode.TH.SourceRequestJSON as J +import qualified Phoityne.VSCode.TH.SourceResponseJSON as J +import qualified Phoityne.VSCode.TH.StackFrameJSON as J +import qualified Phoityne.VSCode.TH.StackTraceBodyJSON as J +import qualified Phoityne.VSCode.TH.StackTraceRequestJSON as J +import qualified Phoityne.VSCode.TH.StackTraceResponseJSON as J +import qualified Phoityne.VSCode.TH.StepInRequestJSON as J +import qualified Phoityne.VSCode.TH.StepInResponseJSON as J +import qualified Phoityne.VSCode.TH.StepOutRequestJSON as J +import qualified Phoityne.VSCode.TH.StepOutResponseJSON as J +import qualified Phoityne.VSCode.TH.StoppedEventJSON as J +import qualified Phoityne.VSCode.TH.StoppedEventBodyJSON as J +import qualified Phoityne.VSCode.TH.TerminatedEventJSON as J +import qualified Phoityne.VSCode.TH.TerminatedEventBodyJSON as J +import qualified Phoityne.VSCode.TH.ThreadsRequestJSON as J +import qualified Phoityne.VSCode.TH.ThreadsResponseJSON as J +import qualified Phoityne.VSCode.TH.VariableJSON as J +import qualified Phoityne.VSCode.TH.VariablesBodyJSON as J +import qualified Phoityne.VSCode.TH.VariablesRequestJSON as J +import qualified Phoityne.VSCode.TH.VariablesResponseJSON as J + +-- | +-- +-- +data DebugContextData = + DebugContextData { + resSeqDebugContextData :: Int + , functionBreakPointDatasDebugContextData :: BreakPointDatas + , breakPointDatasDebugContextData :: BreakPointDatas + , workspaceDebugContextData :: FilePath + , startupDebugContextData :: FilePath + , debugStartedDebugContextData :: Bool + , debugStoppedPosDebugContextData :: Maybe G.SourcePosition + , currentFrameIdDebugContextData :: Int + , modifiedDebugContextData :: Bool + , ghciProcessDebugContextData :: Maybe G.GHCiProcess + , responseHandlerDebugContextData :: BSL.ByteString -> IO () + , stopOnEntryDebugContextData :: Bool + } + + +-- | +-- +-- +data BreakPointData = + BreakPointData { + nameBreakPointData :: String + , srcPosBreakPointData :: G.SourcePosition + , breakNoBreakPointData :: Maybe Int + , conditionBreakPointData :: Maybe String + , hitConditionBreakPointData :: Maybe String + , hitCountBreakPointData :: Int + } deriving (Show, Read, Eq, Ord) + + +-- | +-- +-- +type BreakPointDataKey = G.SourcePosition + +-- | +-- +-- +type BreakPointDatas = M.Map BreakPointDataKey BreakPointData + +-- | +-- +-- +getBreakPointKey :: BreakPointData -> BreakPointDataKey +getBreakPointKey = srcPosBreakPointData + + +-- | +-- +incrementBreakPointHitCount :: BreakPointData -> BreakPointData +incrementBreakPointHitCount bp = bp{hitCountBreakPointData = 1 + hitCountBreakPointData bp} + + + +-- | +-- +-- +_INITIAL_RESPONSE_SEQUENCE :: Int +_INITIAL_RESPONSE_SEQUENCE = 0 + + +-- | +-- +-- +_SEP_WIN :: Char +_SEP_WIN = '\\' + +-- | +-- +-- +_SEP_UNIX :: Char +_SEP_UNIX = '/' + +-- | +-- +-- +_TASKS_JSON_FILE_CONTENTS :: BSL.ByteString +_TASKS_JSON_FILE_CONTENTS = str2lbs $ U.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 \" ]" + , " }," + , " { " + , " \"isBackground\": 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" + ] + + +-- | +-- +-- +_DEBUG_START_MSG :: [String] +_DEBUG_START_MSG = [ + "" + , " Now, ghci launched and configuration done." + , " Press F5 to start debugging." + , " Or modify source code. it will be loaded to ghci automatically." + , " " + ] + +-- | +-- +-- +_NOT_PERMIT_REPL_COMMANDS :: [String] +_NOT_PERMIT_REPL_COMMANDS = [ + ":{" + , ":abandon", ":back", ":break", ":continue", ":delete", ":force", ":forward" + , ":history", ":list", ":print", ":sprint", ":step", ":steplocal", ":stepmodule", ":trace" + ] + +-- | +-- +-- +defaultDebugContextData :: DebugContextData +defaultDebugContextData = DebugContextData { + resSeqDebugContextData = _INITIAL_RESPONSE_SEQUENCE + , functionBreakPointDatasDebugContextData = M.fromList [] + , breakPointDatasDebugContextData = M.fromList [] + , workspaceDebugContextData = "" + , startupDebugContextData = "" + , debugStartedDebugContextData = False + , debugStoppedPosDebugContextData = Nothing + , currentFrameIdDebugContextData = 0 + , modifiedDebugContextData = False + , ghciProcessDebugContextData = Nothing + , responseHandlerDebugContextData = BSL.putStr + , stopOnEntryDebugContextData = False + } + + +-- |===================================================================== +-- Request / Response / Event +-- + + +-- | +-- +-- +logRequest :: String -> IO () +logRequest reqStr = infoM _LOG_NAME $ "[REQUEST] " ++ reqStr + + +-- | +-- +isLoggingStarted :: MVar DebugContextData -> IO Bool +isLoggingStarted mvarCtx = do + ctx <- readMVar mvarCtx + return . not . null $ workspaceDebugContextData ctx + +-- | +-- +sendResponse :: MVar DebugContextData -> BSL.ByteString -> IO () +sendResponse mvarCtx str = do + doLog <- isLoggingStarted mvarCtx + when doLog $ infoM _LOG_NAME $ "[RESPONSE]" ++ lbs2str str + + ctx <- readMVar mvarCtx + responseHandlerDebugContextData ctx str + + +-- | +-- +-- +sendConsoleEvent :: MVar DebugContextData -> String -> IO () +sendConsoleEvent mvarCtx msg = sendOutputEventWithType mvarCtx msg "console" + + +-- | +-- +-- +sendStdoutEvent :: MVar DebugContextData -> String -> IO () +sendStdoutEvent mvarCtx msg = sendOutputEventWithType mvarCtx msg "stdout" + + +-- | +-- +-- +sendErrorEvent :: MVar DebugContextData -> String -> IO () +sendErrorEvent mvarCtx msg = do + doLog <- isLoggingStarted mvarCtx + when doLog $ errorM _LOG_NAME msg + sendOutputEventWithType mvarCtx msg "stderr" + + +-- | +-- +-- +sendOutputEventWithType :: MVar DebugContextData -> String -> String -> IO () +sendOutputEventWithType mvarCtx msg msgType= do + resSeq <- getIncreasedResponseSequence mvarCtx + let outEvt = J.defaultOutputEvent resSeq + outEvtStr = J.encode outEvt{J.bodyOutputEvent = J.OutputEventBody msgType msg Nothing } + sendEvent mvarCtx outEvtStr + + +-- | +-- +sendEvent :: MVar DebugContextData -> BSL.ByteString -> IO () +sendEvent mvarCtx str = do + doLog <- isLoggingStarted mvarCtx + when doLog $ infoM _LOG_NAME $ "[EVENT]" ++ lbs2str str + + ctx <- readMVar mvarCtx + responseHandlerDebugContextData ctx str + + +-- | +-- +sendTerminateEvent :: MVar DebugContextData -> IO () +sendTerminateEvent mvarDat = do + resSeq <- getIncreasedResponseSequence mvarDat + let terminatedEvt = J.defaultTerminatedEvent resSeq + terminatedEvtStr = J.encode terminatedEvt + sendEvent mvarDat terminatedEvtStr + +-- | +-- +sendRestartEvent :: MVar DebugContextData -> IO () +sendRestartEvent mvarCtx = do + resSeq <- getIncreasedResponseSequence mvarCtx + let terminatedEvt = J.defaultTerminatedEvent resSeq + terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True} + sendEvent mvarCtx terminatedEvtStr + + +-- |===================================================================== +-- Handlers + +-- | +-- +-- +handleRequest :: MVar DebugContextData -> BSL.ByteString -> BSL.ByteString -> IO () +handleRequest mvarDat contLenStr jsonStr = do + case J.eitherDecode jsonStr :: Either String J.Request of + Right (J.Request cmd) -> handle cmd + Left err -> sendParseErrorAndTerminate err "request" + + where + sendParseErrorAndTerminate err typ = do + let msg = L.intercalate "\n" + $ [ "[CRITICAL]"++"<"++typ++">"++" request parce error." + , lbs2str contLenStr + , lbs2str jsonStr + , show err, "" + ] ++ _ERR_MSG_URL ++ ["", ""] + sendErrorEvent mvarDat msg + sendTerminateEvent mvarDat + + handle "initialize" = case J.eitherDecode jsonStr :: Either String J.InitializeRequest of + Right req -> initializeRequestHandler mvarDat req + Left err -> do + let cont = L.intercalate " " $ map U.strip $ lines $ lbs2str contLenStr + json = L.intercalate " " $ map U.strip $ lines $ lbs2str jsonStr + er = L.intercalate " " $ map U.strip $ lines $ show err + msg = L.intercalate " " $ ["[CRITICAL] request parce error.", cont, json, er] ++ _ERR_MSG_URL + resSeq <- getIncreasedResponseSequence mvarDat + sendResponse mvarDat $ J.encode $ J.parseErrorInitializeResponse resSeq msg + sendParseErrorAndTerminate err "initialize" + + handle "launch" = case J.eitherDecode jsonStr :: Either String J.LaunchRequest of + Right req -> launchRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "launch" + + handle "configurationDone" = case J.eitherDecode jsonStr :: Either String J.ConfigurationDoneRequest of + Right req -> configurationDoneRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "configurationDone" + + handle "disconnect" = case J.eitherDecode jsonStr :: Either String J.DisconnectRequest of + Right req -> disconnectRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "disconnect" + + handle "setBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetBreakpointsRequest of + Right req -> setBreakpointsRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "setBreakpoints" + + handle "setFunctionBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetFunctionBreakpointsRequest of + Right req -> setFunctionBreakpointsRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "setFunctionBreakpoints" + + handle "setExceptionBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetExceptionBreakpointsRequest of + Right req -> setExceptionBreakpointsRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "setExceptionBreakpoints" + + handle "continue" = case J.eitherDecode jsonStr :: Either String J.ContinueRequest of + Right req -> continueRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "continue" + + handle "next" = case J.eitherDecode jsonStr :: Either String J.NextRequest of + Right req -> nextRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "next" + + handle "stepIn" = case J.eitherDecode jsonStr :: Either String J.StepInRequest of + Right req -> stepInRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "stepIn" + + handle "stackTrace" = case J.eitherDecode jsonStr :: Either String J.StackTraceRequest of + Right req -> stackTraceRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "stackTrace" + + handle "scopes" = case J.eitherDecode jsonStr :: Either String J.ScopesRequest of + Right req -> scopesRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "scopes" + + handle "variables" = case J.eitherDecode jsonStr :: Either String J.VariablesRequest of + Right req -> variablesRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "variables" + + handle "threads" = case J.eitherDecode jsonStr :: Either String J.ThreadsRequest of + Right req -> threadsRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "threads" + + handle "evaluate" = case J.eitherDecode jsonStr :: Either String J.EvaluateRequest of + Right req -> evaluateRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "evaluate" + + handle "completions" = case J.eitherDecode jsonStr :: Either String J.CompletionsRequest of + Right req -> completionsRequestHandler mvarDat req + Left err -> sendParseErrorAndTerminate err "completions" + + -- | + -- not supported. + -- + handle "stepOut" = case J.eitherDecode jsonStr :: Either String J.StepOutRequest of + Left err -> sendParseErrorAndTerminate err "stepOut" + Right req -> do + resSeq <- getIncreasedResponseSequence mvarDat + let res = J.defaultStepOutResponse resSeq req + resStr = J.encode $ res{J.successStepOutResponse = False, J.messageStepOutResponse = "unsupported command."} + sendResponse mvarDat resStr + sendErrorEvent mvarDat "[WARN] stepOut command is not supported. ignored." + + handle "pause" = case J.eitherDecode jsonStr :: Either String J.PauseRequest of + Left err -> sendParseErrorAndTerminate err "pause" + Right req -> do + resSeq <- getIncreasedResponseSequence mvarDat + let res = J.defaultPauseResponse resSeq req + resStr = J.encode $ res{J.successPauseResponse = False, J.messagePauseResponse = "unsupported command."} + sendResponse mvarDat resStr + + sendErrorEvent mvarDat "[WARN] pause command is not supported. ignored." + + handle "source" = case J.eitherDecode jsonStr :: Either String J.SourceRequest of + Left err -> sendParseErrorAndTerminate err "source" + Right req -> do + resSeq <- getIncreasedResponseSequence mvarDat + let res = J.defaultSourceResponse resSeq req + resStr = J.encode $ res{J.successSourceResponse = False, J.messageSourceResponse = "unsupported command."} + sendResponse mvarDat resStr + + sendErrorEvent mvarDat "[WARN] source command is not supported. ignored." + + handle cmd = do + let msg = L.intercalate " " ["[WARN] unknown request command. ignored.", cmd, lbs2str contLenStr, lbs2str jsonStr] + sendErrorEvent mvarDat msg + + +-- | +-- +initializeRequestHandler :: MVar DebugContextData -> J.InitializeRequest -> IO () +initializeRequestHandler mvarCtx req@(J.InitializeRequest seq _ _ _) = flip E.catches handlers $ do + resSeq <- getIncreasedResponseSequence mvarCtx + let capa = J.InitializeResponseCapabilites { + J.supportsConfigurationDoneRequestInitializeResponseCapabilites = True + , J.supportsFunctionBreakpointsInitializeResponseCapabilites = True + , J.supportsConditionalBreakpointsInitializeResponseCapabilites = True + , J.supportsHitConditionalBreakpointsInitializeResponseCapabilites = True + , J.supportsEvaluateForHoversInitializeResponseCapabilites = True + , J.exceptionBreakpointFiltersInitializeResponseCapabilites = [ + J.ExceptionBreakpointsFilter "break-on-error" "break-on-error" False + , J.ExceptionBreakpointsFilter "break-on-exception" "break-on-exception" False + ] + , J.supportsStepBackInitializeResponseCapabilites = False + , J.supportsSetVariableInitializeResponseCapabilites = False + , J.supportsRestartFrameInitializeResponseCapabilites = False + , J.supportsGotoTargetsRequestInitializeResponseCapabilites = False + , J.supportsStepInTargetsRequestInitializeResponseCapabilites = False + , J.supportsCompletionsRequestInitializeResponseCapabilites = True + } + res = J.InitializeResponse resSeq "response" seq True "initialize" "" capa + + sendResponse mvarCtx $ 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 <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorInitializeResponse resSeq req msg + sendErrorEvent mvarCtx msg + + +-- | +-- +launchRequestHandler :: MVar DebugContextData -> J.LaunchRequest -> IO () +launchRequestHandler mvarCtx req@(J.LaunchRequest _ _ _ args) = flip E.catches handlers $ do + + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx { + workspaceDebugContextData = J.workspaceLaunchRequestArguments args + , startupDebugContextData = J.startupLaunchRequestArguments args + , stopOnEntryDebugContextData = J.stopOnEntryLaunchRequestArguments args + } + + let logLevelStr = J.logLevelLaunchRequestArguments args + logLevel <- case readMay logLevelStr of + Just lv -> return lv + Nothing -> do + sendErrorEvent mvarCtx $ "log priority is invalid. WARNING set. [" ++ logLevelStr ++ "]\n" + return WARNING + + setupLogger (J.logFileLaunchRequestArguments args) logLevel + + logRequest $ show req + + prepareTasksJsonFile + + + runGHCi mvarCtx + (J.ghciCmdLaunchRequestArguments args) + (J.ghciPromptLaunchRequestArguments args) + (J.ghciEnvLaunchRequestArguments args) + >>= ghciLaunched + + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["launch request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorLaunchResponse resSeq req msg + sendErrorEvent mvarCtx $ msg ++ "\n" + + -- | + -- + prepareTasksJsonFile = do + ctx <- readMVar mvarCtx + let jsonFile = workspaceDebugContextData ctx ".vscode" "tasks.json" + + doesFileExist jsonFile >>= \case + True -> debugM _LOG_NAME $ "tasks.json file exists. " ++ jsonFile + False -> do + sendConsoleEvent mvarCtx $ "create tasks.json file. " ++ jsonFile ++ "\n" + saveFileLBS jsonFile _TASKS_JSON_FILE_CONTENTS + + -- | + -- + ghciLaunched (Left err) = do + let msg = L.intercalate " " ["ghci launch error.", err] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorLaunchResponse resSeq req msg + sendErrorEvent mvarCtx $ msg ++ "\n" + + sendTerminateEvent mvarCtx + + + ghciLaunched (Right ghciProc) = do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{ghciProcessDebugContextData = Just ghciProc} + + startupRes <- loadHsFile mvarCtx (J.startupLaunchRequestArguments args) + + when (False == startupRes) $ do + let msg = L.intercalate " " ["startup load error.", J.startupLaunchRequestArguments args] + sendErrorEvent mvarCtx $ msg ++ "\n" + + setMainArgs ghciProc (J.mainArgsLaunchRequestArguments args) >>= \case + Right _ -> return () + Left err -> do + let msg = L.intercalate " " ["set args error.", err, show (J.mainArgsLaunchRequestArguments args)] + sendErrorEvent mvarCtx $ msg ++ "\n" + + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.defaultLaunchResponse resSeq req + + resSeq <- getIncreasedResponseSequence mvarCtx + sendEvent mvarCtx $ J.encode $ J.defaultInitializedEvent resSeq + + watch mvarCtx + + setMainArgs _ Nothing = return . Right $ () + setMainArgs ghciProc (Just argsStr) + | null (U.strip argsStr) = return . Right $ () + | otherwise = G.set ghciProc (sendStdoutEvent mvarCtx) ("args " ++ argsStr) + + +-- | +-- +configurationDoneRequestHandler :: MVar DebugContextData -> J.ConfigurationDoneRequest -> IO () +configurationDoneRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["configurationDone request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorConfigurationDoneResponse resSeq req msg + sendErrorEvent mvarCtx msg + + withProcess Nothing = sendErrorEvent mvarCtx "[withProcess] ghci not started." + + withProcess (Just ghciProc) = do + sendConsoleEvent mvarCtx $ L.intercalate "\n" _DEBUG_START_MSG + sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc + + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.defaultConfigurationDoneResponse resSeq req + + stopOnEntryDebugContextData <$> (readMVar mvarCtx) >>= stopOnEntry + + stopOnEntry False = proceedDebug mvarCtx + stopOnEntry True = do + resSeq <- getIncreasedResponseSequence mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent mvarCtx stopEvtStr + + +-- | +-- +disconnectRequestHandler :: MVar DebugContextData -> J.DisconnectRequest -> IO () +disconnectRequestHandler mvarCtx req = do + logRequest $ show req + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + exitSuccess + + where + withProcess Nothing = do + sendErrorEvent mvarCtx "[disconnectRequestHandler] ghci not started." + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.defaultDisconnectResponse resSeq req + + withProcess (Just ghciProc) = G.quit ghciProc outHdl >>= withExitCode + + withExitCode (Left err) = do + sendErrorEvent mvarCtx $ "[disconnectRequestHandler] ghci quit error. " ++ err + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.defaultDisconnectResponse resSeq req + + withExitCode (Right code) = do + sendStdoutEvent mvarCtx $ show code + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.defaultDisconnectResponse resSeq req + + outHdl = sendStdoutEvent mvarCtx + +-- | +-- +setBreakpointsRequestHandler :: MVar DebugContextData -> J.SetBreakpointsRequest -> IO () +setBreakpointsRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + ctx <- readMVar mvarCtx + let cwd = workspaceDebugContextData 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 <- getIncreasedResponseSequence mvarCtx + let res = J.defaultSetBreakpointsResponse resSeq req + resStr = J.encode res{J.bodySetBreakpointsResponse = J.SetBreakpointsResponseBody resBody} + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["setBreakpoints request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorSetBreakpointsResponse resSeq req msg + sendErrorEvent mvarCtx msg + + convBp cwd path (J.SourceBreakpoint lineNo colNo cond hitCond) = + BreakPointData { + nameBreakPointData = src2mod cwd path + , srcPosBreakPointData = G.SourcePosition path lineNo (maybe (-1) id colNo) (-1) (-1) + , breakNoBreakPointData = Nothing + , conditionBreakPointData = normalizeCond cond + , hitConditionBreakPointData = hitCond + , hitCountBreakPointData = 0 + } + + normalizeCond Nothing = Nothing + normalizeCond (Just c) + | null (U.strip c) = Nothing + | otherwise = Just c + + delete path = do + ctx <- takeMVar mvarCtx + let bps = breakPointDatasDebugContextData ctx + newBps = M.filterWithKey (\(G.SourcePosition p _ _ _ _) _-> path /= p) bps + delBps = M.elems $ M.filterWithKey (\(G.SourcePosition p _ _ _ _) _-> path == p) bps + + putMVar mvarCtx ctx{breakPointDatasDebugContextData = newBps} + + debugM _LOG_NAME $ "del bps:" ++ show delBps + + mapM_ (deleteBreakPointOnGHCi 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 = breakPointDatasDebugContextData ctx + newBps = foldr (\v@(BreakPointData _ s _ _ _ _)->M.insert s v) bps $ map fst results + putMVar mvarCtx ctx{breakPointDatasDebugContextData = newBps} + + return resData + + + insertInternal reqBp@(BreakPointData modName (G.SourcePosition filePath lineNo _ _ _) _ _ _ _) = + addBreakPointOnGHCi mvarCtx reqBp >>= \case + Right (no, srcPos@(G.SourcePosition path sl sc el ec)) -> + return (reqBp{ breakNoBreakPointData = Just no + , srcPosBreakPointData = srcPos + }, + J.Breakpoint (Just no) True "" + (J.Source (Just modName) path Nothing Nothing) sl sc el ec) + Left err -> + return (reqBp, + J.Breakpoint Nothing False err + (J.Source (Just modName) filePath Nothing Nothing) + lineNo (-1) lineNo (-1)) + +-- | +-- +setFunctionBreakpointsRequestHandler :: MVar DebugContextData -> J.SetFunctionBreakpointsRequest -> IO () +setFunctionBreakpointsRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + let args = J.argumentsSetFunctionBreakpointsRequest req + reqBps = J.breakpointsSetFunctionBreakpointsRequestArguments args + bps = map convBp reqBps + + delete + resBody <- insert bps + + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultSetFunctionBreakpointsResponse resSeq req + resStr = J.encode res{J.bodySetFunctionBreakpointsResponse = J.SetFunctionBreakpointsResponseBody resBody} + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["setFunctionBreakpoints request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorSetFunctionBreakpointsResponse resSeq req msg + sendErrorEvent mvarCtx msg + + convBp (J.FunctionBreakpoint name cond hitCond) = + BreakPointData { + nameBreakPointData = name + , srcPosBreakPointData = G.SourcePosition "" (-1) (-1) (-1) (-1) + , breakNoBreakPointData = Nothing + , conditionBreakPointData = normalizeCond cond + , hitConditionBreakPointData = hitCond + , hitCountBreakPointData = 0 + } + + normalizeCond Nothing = Nothing + normalizeCond (Just c) + | null (U.strip c) = Nothing + | otherwise = Just c + + delete = do + ctx <- takeMVar mvarCtx + let bps = functionBreakPointDatasDebugContextData ctx + delBps = M.elems bps + + putMVar mvarCtx ctx{functionBreakPointDatasDebugContextData = M.fromList []} + + debugM _LOG_NAME $ "del bps:" ++ show delBps + + mapM_ (deleteBreakPointOnGHCi 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 funBPs:" ++ show addBps + debugM _LOG_NAME $ "response funBPs:" ++ show resData + + ctx <- takeMVar mvarCtx + let bps = functionBreakPointDatasDebugContextData ctx + newBps = foldr (\v@(BreakPointData _ s _ _ _ _)->M.insert s v) bps $ map fst results + putMVar mvarCtx ctx{functionBreakPointDatasDebugContextData = newBps} + + return resData + + + insertInternal reqBp@(BreakPointData funcName _ _ _ _ _) = do + addFunctionBreakPointOnGHCi mvarCtx reqBp >>= \case + Right (no, srcPos@(G.SourcePosition path sl sc el ec)) -> do + return ( reqBp{ breakNoBreakPointData = Just no + , srcPosBreakPointData = srcPos + } + , J.Breakpoint (Just no) True "" (J.Source (Just funcName) path Nothing Nothing) sl sc el ec) + Left err -> return (reqBp, J.Breakpoint Nothing False err (J.Source (Just funcName) "" Nothing Nothing) (-1) (-1) (-1) (-1)) + +-- | +-- +setExceptionBreakpointsRequestHandler :: MVar DebugContextData -> J.SetExceptionBreakpointsRequest -> IO () +setExceptionBreakpointsRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + let args = J.argumentsSetExceptionBreakpointsRequest req + filters = J.filtersSetExceptionBreakpointsRequestArguments args + + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess filters + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["setExceptionBreakpoints request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorSetExceptionBreakpointsResponse resSeq req msg + sendErrorEvent mvarCtx msg + + withProcess _ Nothing = sendErrorEvent mvarCtx "[setExceptionBreakpointsRequestHandler] ghci not started." + withProcess filters (Just ghciProc) + | null filters = withCommands ghciProc ["-fno-break-on-exception", "-fno-break-on-error"] + | filters == ["break-on-error"] = withCommands ghciProc ["-fno-break-on-exception", "-fbreak-on-error"] + | filters == ["break-on-exception"] = withCommands ghciProc ["-fbreak-on-exception", "-fno-break-on-error"] + | otherwise = withCommands ghciProc ["-fbreak-on-exception", "-fbreak-on-error" ] + + withCommands _ [] = do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultSetExceptionBreakpointsResponse resSeq req + resStr = J.encode res + sendResponse mvarCtx resStr + + withCommands ghciProc (x:xs) = G.set ghciProc outHdl x >>= \case + Right _ -> withCommands ghciProc xs + Left err -> do + let msg = L.intercalate " " ["setExceptionBreakpoints request error.", show req, show err] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorSetExceptionBreakpointsResponse resSeq req msg + sendErrorEvent mvarCtx msg + + outHdl = sendStdoutEvent mvarCtx + +-- | +-- +-- +continueRequestHandler :: MVar DebugContextData -> J.ContinueRequest -> IO () +continueRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + resSeq <- getIncreasedResponseSequence mvarCtx + let resStr = J.encode $ J.defaultContinueResponse resSeq req + sendResponse mvarCtx resStr + + proceedDebug mvarCtx + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["continue request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorContinueResponse resSeq req msg + sendErrorEvent mvarCtx msg + + +-- | +-- +-- +nextRequestHandler :: MVar DebugContextData -> J.NextRequest -> IO () +nextRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + ctx <- readMVar mvarCtx + case debugStoppedPosDebugContextData ctx of + Nothing -> do + resSeq <- getIncreasedResponseSequence 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 mvarCtx resStr + Just _ -> next + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["stepOver request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorNextResponse resSeq req msg + sendErrorEvent mvarCtx msg + + next = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + + withProcess Nothing = sendErrorEvent mvarCtx "[nextRequestHandler] ghci not started." + + withProcess (Just ghciProc) = G.stepLocal ghciProc outHdl >>= \case + Left err -> do + sendErrorEvent mvarCtx $ show err + sendTerminateEvent mvarCtx + + Right Nothing -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultNextResponse resSeq req + resStr = J.encode res + sendResponse mvarCtx resStr + + breakByException mvarCtx + + Right (Just pos) -> do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} + + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultNextResponse resSeq req + resStr = J.encode res + sendResponse mvarCtx resStr + + resSeq <- getIncreasedResponseSequence mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent mvarCtx stopEvtStr + + outHdl = sendStdoutEvent mvarCtx + + +-- | +-- +-- +stepInRequestHandler :: MVar DebugContextData -> J.StepInRequest -> IO () +stepInRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + ctx <- readMVar mvarCtx + case debugStoppedPosDebugContextData ctx of + Nothing -> do + resSeq <- getIncreasedResponseSequence 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 mvarCtx 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 <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorStepInResponse resSeq req msg + sendErrorEvent mvarCtx msg + + stepIn = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + + withProcess Nothing = sendErrorEvent mvarCtx "[stepInRequestHandler] ghci not started." + + withProcess (Just ghciProc) = G.step ghciProc outHdl >>= \case + Left err -> do + sendErrorEvent mvarCtx $ show err + sendTerminateEvent mvarCtx + + Right Nothing -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultStepInResponse resSeq req + resStr = J.encode res + sendResponse mvarCtx resStr + + breakByException mvarCtx + + Right (Just pos) -> do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} + + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultStepInResponse resSeq req + resStr = J.encode res + sendResponse mvarCtx resStr + + resSeq <- getIncreasedResponseSequence mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent mvarCtx stopEvtStr + + outHdl = sendStdoutEvent mvarCtx + + +-- | +-- +-- +stackTraceRequestHandler :: MVar DebugContextData -> J.StackTraceRequest -> IO () +stackTraceRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + ctx <- readMVar mvarCtx + case debugStoppedPosDebugContextData ctx of + Nothing -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let body = J.StackTraceBody [] 0 + res = J.defaultStackTraceResponse resSeq req + resStr = J.encode $ res{J.bodyStackTraceResponse = body} + sendResponse mvarCtx resStr + + Just rangeData -> do + frames <- createStackFrames rangeData + debugM _LOG_NAME $ show frames + + resSeq <- getIncreasedResponseSequence mvarCtx + let body = J.StackTraceBody (reverse frames) (length frames) + res = J.defaultStackTraceResponse resSeq req + resStr = J.encode $ res{J.bodyStackTraceResponse = body} + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["stackTrace request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorStackTraceResponse resSeq req msg + sendErrorEvent mvarCtx msg + + createStackFrames pos = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess pos + + withProcess pos Nothing = do + sendErrorEvent mvarCtx "[stackTraceRequestHandler] ghci not started." + defaultFrame pos + + withProcess pos (Just ghciProc) = G.history ghciProc outHdl >>= \case + Left err -> do + sendErrorEvent mvarCtx $ show err + defaultFrame pos + + Right dats -> do + cwd <- workspaceDebugContextData <$> readMVar mvarCtx + cfs <- defaultFrame pos + foldM (convTrace2Frame cwd) cfs dats + + convTrace2Frame cwd xs (G.StackFrame traceId funcName (G.SourcePosition file sl sc el ec)) = return $ + J.StackFrame traceId funcName (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc el ec : xs + + defaultFrame (G.SourcePosition file sl sc el ec) = do + ctx <- readMVar mvarCtx + let cwd = workspaceDebugContextData ctx + csf = J.StackFrame 0 "[BP]" (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc el ec + return [csf] + + outHdl = debugM _LOG_NAME + + +-- | +-- +-- +scopesRequestHandler :: MVar DebugContextData -> J.ScopesRequest -> IO () +scopesRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + let args = J.argumentsScopesRequest req + traceId = J.frameIdScopesArguments args + + moveFrame mvarCtx traceId + + resSeq <- getIncreasedResponseSequence mvarCtx + let resStr = J.encode $ J.defaultScopesResponse resSeq req + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["scopes request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorScopesResponse resSeq req msg + sendErrorEvent mvarCtx msg + +-- | +-- +-- +variablesRequestHandler :: MVar DebugContextData -> J.VariablesRequest -> IO () +variablesRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + vals <- currentBindings + + resSeq <- getIncreasedResponseSequence mvarCtx + let res = J.defaultVariablesResponse resSeq req + resStr = J.encode $ res{J.bodyVariablesResponse = J.VariablesBody vals} + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["variables request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorVariablesResponse resSeq req msg + sendErrorEvent mvarCtx msg + + currentBindings = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + + withProcess Nothing = do + sendErrorEvent mvarCtx "[variablesRequestHandler] ghci not started." + return [] + + withProcess (Just ghciProc) = G.bindings ghciProc outHdl >>= \case + Left err -> do + sendErrorEvent mvarCtx $ show err + return [] + + Right dats -> return $ map convBind2Vals dats + + convBind2Vals (G.BindingData varName modName val) = J.Variable varName modName val (Just varName) 0 + + outHdl = debugM _LOG_NAME + + +-- | +-- +-- +threadsRequestHandler :: MVar DebugContextData -> J.ThreadsRequest -> IO () +threadsRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + resSeq <- getIncreasedResponseSequence mvarCtx + let resStr = J.encode $ J.defaultThreadsResponse resSeq req + sendResponse mvarCtx resStr + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["threads request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorThreadsResponse resSeq req msg + sendErrorEvent mvarCtx msg + + +-- | +-- +-- +evaluateRequestHandler :: MVar DebugContextData -> J.EvaluateRequest -> IO () +evaluateRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + let (J.EvaluateArguments exp _ ctx) = J.argumentsEvaluateRequest req + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess ctx exp + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["evaluate request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorEvaluateResponse resSeq req msg + sendErrorEvent mvarCtx msg + + withProcess _ _ Nothing = sendErrorEvent mvarCtx "[evaluateRequestHandler] ghci not started." + + withProcess "watch" exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case + Left err -> do + errorM _LOG_NAME $ show err + evaluateResponse err "" + + Right typeStr -> case isFunction typeStr of + True -> evaluateResponse "" (getOnlyType typeStr) + False -> G.force ghciProc outHdl exp >>= \case + Right valStr -> evaluateResponse (getOnlyValue valStr) (getOnlyType typeStr) + Left _ -> evaluateResponse "" (getOnlyType typeStr) + + withProcess "hover" exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case + Left err -> do + errorM _LOG_NAME $ show err + evaluateResponse err "" + Right typeStr -> evaluateResponse typeStr (getOnlyType typeStr) + + withProcess _ exp (Just ghciProc) + | null (U.strip exp) = do + evaluateResponse "" "" + sendStdoutEvent mvarCtx (G.promptGHCiProcess ghciProc) + | otherwise = replHandler ghciProc $ map U.rstrip (lines exp) + + replHandler _ [] = do + errorM _LOG_NAME "[replHandler] invalid inputs." + evaluateResponse "" "" + + replHandler ghciProc (exp:[]) + | isPermitCmd (U.strip exp) = G.exec ghciProc outHdl exp >>= \case + Left err -> do + errorM _LOG_NAME $ show err + evaluateResponse "" "" + sendErrorEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n" ++ show err + sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc + Right cmdStr -> do + evaluateResponse "" "" + sendStdoutEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n" ++ cmdStr + | otherwise = do + evaluateResponse "" "" + sendErrorEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n can not use these commands.\n" ++ show _NOT_PERMIT_REPL_COMMANDS ++ "\n" + sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc + + replHandler ghciProc exps = G.exec ghciProc outHdl ":{" >>= \case + Left err -> do + errorM _LOG_NAME $ show err + evaluateResponse "" "" + sendErrorEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ ":{\n" ++ show err + Right cmdStr -> replsHandler ghciProc (exps ++ [":}"]) $ (G.promptGHCiProcess ghciProc) ++ ":{\n" ++ cmdStr + + replsHandler _ [] acc = do + evaluateResponse "" "" + sendStdoutEvent mvarCtx acc + + replsHandler ghciProc (x:xs) acc + | isPermitCmd (U.strip x) = G.exec ghciProc outHdl x >>= \case + Left err -> do + evaluateResponse "" "" + sendErrorEvent mvarCtx $ acc ++ x ++ "\n" ++ show err + sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc + + Right cmdStr -> replsHandler ghciProc xs $ acc ++ x ++ "\n" ++ cmdStr + | otherwise = do + evaluateResponse "" "" + sendErrorEvent mvarCtx $ acc ++ x ++ "\n can not use these commands.\n" ++ show _NOT_PERMIT_REPL_COMMANDS ++ "\n" + sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc + + isPermitCmd c = 0 == (length ( filter (flip U.startswith c) _NOT_PERMIT_REPL_COMMANDS)) + + outHdl = debugM _LOG_NAME + + isFunction str = case parse isFunctionParser "isFunction" str of + Right _ -> True + Left _ -> False + + isFunctionParser = manyTill anyChar (string "->") + + evaluateResponse msg typeStr = do + resSeq <- getIncreasedResponseSequence mvarCtx + let body = J.EvaluateBody msg typeStr 0 + res = J.defaultEvaluateResponse resSeq req + resStr = J.encode res{J.bodyEvaluateResponse = body} + sendResponse mvarCtx resStr + + -- | + -- force result parser + -- + -- parser of + -- Phoityne>>= :force x + -- x = 8 + -- Phoityne>>= + -- + getOnlyValue :: String -> String + getOnlyValue str = case parse getOnlyValueParser "getOnlyValue" str of + Right vals -> vals + Left _ -> str + where + getOnlyValueParser = do + _ <- manyTill anyChar (string " = ") + manyTill anyChar eof + + -- | + -- type result parser + -- + -- parser of + -- Phoityne>>= :type x + -- x :: Int -> Int + -- Phoityne>>= + -- + getOnlyType :: String -> String + getOnlyType str = case parse getOnlyTypeParser "getOnlyType" str of + Right vals -> vals + Left _ -> str + where + getOnlyTypeParser = do + _ <- manyTill anyChar (string " :: ") + manyTill anyChar eof + + +-- | +-- +-- +completionsRequestHandler :: MVar DebugContextData -> J.CompletionsRequest -> IO () +completionsRequestHandler mvarCtx req = flip E.catches handlers $ do + logRequest $ show req + + let (J.CompletionsArguments _ key _ _) = J.argumentsCompletionsRequest req + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess key + + where + handlers = [ E.Handler someExcept ] + someExcept (e :: E.SomeException) = do + let msg = L.intercalate " " ["completions request error.", show req, show e] + resSeq <- getIncreasedResponseSequence mvarCtx + sendResponse mvarCtx $ J.encode $ J.errorCompletionsResponse resSeq req msg + sendErrorEvent mvarCtx msg + + withProcess _ Nothing = sendErrorEvent mvarCtx "[completionsRequestHandler] ghci not started." + + withProcess key (Just ghciProc) = G.complete ghciProc outHdl key 50 >>= \case + Left err -> do + errorM _LOG_NAME $ show err + resSeq <- getIncreasedResponseSequence mvarCtx + let resStr = J.encode $ J.errorCompletionsResponse resSeq req $ show err + sendResponse mvarCtx resStr + + Right xs -> do + resSeq <- getIncreasedResponseSequence mvarCtx + let bd = J.CompletionsResponseBody $ map createItem xs + res = J.defaultCompletionsResponse resSeq req + + let resStr = J.encode $ res {J.bodyCompletionsResponse = bd} + sendResponse mvarCtx resStr + + createItem (':':xs) = J.CompletionsItem xs + createItem xs = J.CompletionsItem xs + + outHdl = debugM _LOG_NAME + + +-- |===================================================================== +-- +-- Utility + +-- | +-- +-- +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 = False + | otherwise = isUpper $ head modName + + +-- | +-- +-- +getIncreasedResponseSequence :: MVar DebugContextData -> IO Int +getIncreasedResponseSequence mvarCtx = do + ctx <- takeMVar mvarCtx + let resSec = 1 + resSeqDebugContextData ctx + putMVar mvarCtx ctx{resSeqDebugContextData = resSec} + return resSec + + +-- | +-- +-- +runGHCi :: MVar DebugContextData + -> String + -> String + -> M.Map String String + -> IO (Either G.ErrorData G.GHCiProcess) +runGHCi mvarCtx cmdStr pmt envs = do + ctx <- readMVar mvarCtx + let cmdList = filter (not.null) $ U.split " " cmdStr + cmd = head cmdList + opts = tail cmdList + cwd = workspaceDebugContextData ctx + + G.start outHdl cmd opts cwd pmt envs + + where + outHdl = sendStdoutEvent mvarCtx + + +-- | +-- +-- +loadHsFile :: MVar DebugContextData -> FilePath -> IO Bool +loadHsFile mvarCtx path = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case + Nothing -> do + sendErrorEvent mvarCtx $ "load file fail.[" ++ path ++ "]" ++ " ghci not started." + return False + Just ghciProc -> G.loadFile ghciProc outHdl path >>= withFileLoadResult ghciProc + + where + outHdl msg = do + sendStdoutEvent mvarCtx msg + + withFileLoadResult _ (Left err) = do + sendErrorEvent mvarCtx $ "load file fail.[" ++ path ++ "]" ++ " " ++ err + return False + + withFileLoadResult ghciProc (Right mods) = G.loadModule ghciProc outHdl mods >>= \case + Left err -> do + sendErrorEvent mvarCtx $ "load module fail. " ++ show mods ++ " " ++ err + return False + Right _ -> return True + + +-- | +-- ブレークポイントをGHCi上でdeleteする +-- +deleteBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO () +deleteBreakPointOnGHCi mvarCtx bp@(BreakPointData _ _ (Just breakNo) _ _ _) = + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case + Nothing -> sendErrorEvent mvarCtx $ "[deleteBreakPointOnGHCi] ghci not started. " ++ show bp + Just ghciProc -> G.delete ghciProc outHdl breakNo >>= withResult + + where + outHdl = sendStdoutEvent mvarCtx + + withResult (Left err) = sendErrorEvent mvarCtx $ "[deleteBreakPointOnGHCi] " ++ err ++ " " ++ show bp + withResult (Right _) = return () + +deleteBreakPointOnGHCi mvarCtx bp = sendErrorEvent mvarCtx $ "[deleteBreakPointOnGHCi] invalid delete break point. " ++ show bp + +-- | +-- GHCi上でブレークポイントを追加する +-- +addBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO (Either String (Int, G.SourcePosition)) +addBreakPointOnGHCi mvarCtx bp@(BreakPointData modName (G.SourcePosition _ lineNo col _ _) _ _ _ _) = + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case + Nothing -> do + errorM _LOG_NAME $ "[addBreakPointOnGHCi] ghci not started. " ++ show bp + return $ Left $ "[addBreakPointOnGHCi] ghci not started. " ++ show bp + Just ghciProc -> G.setBreak ghciProc outHdl modName lineNo col + + where + outHdl = sendStdoutEvent mvarCtx + +-- | +-- GHCi上で関数ブレークポイントを追加する +-- +addFunctionBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO (Either String (Int, G.SourcePosition)) +addFunctionBreakPointOnGHCi mvarCtx bp@(BreakPointData name _ _ _ _ _) = + ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case + Nothing -> do + errorM _LOG_NAME $ "[addFunctionBreakPointOnGHCi] ghci not started. " ++ show bp + return $ Left $ "[addFunctionBreakPointOnGHCi] ghci not started. " ++ show bp + Just ghciProc -> G.setFuncBreak ghciProc outHdl name + + where + outHdl = sendStdoutEvent mvarCtx + + +-- | +-- Loggerのセットアップ +-- +setupLogger :: FilePath -> Priority -> IO () +setupLogger logFile level = do + 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 :: MVar DebugContextData -> IO () +watch mvarCtx = do + _ <- forkIO $ watchFiles mvarCtx + return () + +watchFiles :: MVar DebugContextData -> IO () +watchFiles mvarCtx = do + FSN.withManagerConf FSN.defaultConfig{FSN.confDebounce = FSN.Debounce 1} $ \mgr -> do + + ctx <- readMVar mvarCtx + let dir = workspaceDebugContextData ctx + + debugM _LOG_NAME $ "start watch files in [" ++ dir ++ "]" + _ <- FSN.watchTree mgr dir hsFilter action + + forever $ threadDelay 1000000 + + return () + + where + hsFilter event = U.endswith _HS_FILE_EXT $ FSN.eventPath event + + action event = do + + ctx <- readMVar mvarCtx + withDebugStarted event $ debugStartedDebugContextData ctx + + withDebugStarted _ True = sendRestartEvent mvarCtx + withDebugStarted event False = do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{modifiedDebugContextData = True} + loadHsFile mvarCtx (FSN.eventPath event) >> return () + + +-- | +-- +-- +moveFrame :: MVar DebugContextData -> Int -> IO () +moveFrame mvarCtx traceId = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + where + withProcess Nothing = sendErrorEvent mvarCtx "[moveFrame] ghci not started." + withProcess (Just ghciProc) = do + ctx <- readMVar mvarCtx + let curTraceId = currentFrameIdDebugContextData ctx + moveCount = curTraceId - traceId + traceCmd = if 0 > moveCount then G.back ghciProc outHdl + else G.forward ghciProc outHdl + + -- _ <- traceCmd (abs moveCount) + mapM_ traceCmd [1..(abs moveCount)] + + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{currentFrameIdDebugContextData = traceId} + + outHdl = sendStdoutEvent mvarCtx + +-- | +-- +-- +breakByException :: MVar DebugContextData -> IO () +breakByException mvarCtx = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + where + withProcess Nothing = do + sendErrorEvent mvarCtx "[breakByException] ghci not started." + sendTerminateEvent mvarCtx + + withProcess (Just ghciProc) = do + debugM _LOG_NAME $ "exception occured." + G.exec ghciProc outHdl ":force _exception" >>= withExceptionMsg ghciProc + + withExceptionMsg _ (Left err) = do + sendErrorEvent mvarCtx $ "[breakByException] can't get exception message. " ++ err + sendTerminateEvent mvarCtx + + withExceptionMsg ghciProc (Right msg) = G.history ghciProc outHdl >>= \case + Left err -> do + sendErrorEvent mvarCtx $ show err + sendTerminateEvent mvarCtx + + Right [] -> do + sendErrorEvent mvarCtx "[breakByException] invalid exception history." + sendTerminateEvent mvarCtx + + Right ((G.StackFrame _ _ pos):_) -> do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} + + resSeq <- getIncreasedResponseSequence mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt{J.bodyStoppedEvent = J.exceptionStoppedEventBody (unlines (init (lines msg)))} + sendEvent mvarCtx stopEvtStr + + -- | + -- + outHdl = debugM _LOG_NAME + -- outHdl = sendStdoutEvent mvarCtx + + +-- | +-- +-- +proceedDebug :: MVar DebugContextData -> IO () +proceedDebug mvarCtx = do + ctx <- readMVar mvarCtx + let started = debugStartedDebugContextData ctx + proc = ghciProcessDebugContextData ctx + + proceed started proc + + where + -- | + -- + proceed _ Nothing = sendErrorEvent mvarCtx "[proceedDebug] ghci not started." + proceed True (Just ghciProc) = G.trace ghciProc outHdl >>= \case + Left err -> do + -- end of debugging successfully. + debugM _LOG_NAME $ show err + sendTerminateEvent mvarCtx + Right (Just pos) -> breakOrContinue pos + Right Nothing -> breakByException mvarCtx + + proceed False (Just ghciProc) = do + ctx <- readMVar mvarCtx + withModified (modifiedDebugContextData ctx) ghciProc + + -- | + -- + withModified True _ = sendRestartEvent mvarCtx + withModified False ghciProc = G.traceMain ghciProc outHdl >>= \case + Left err -> do + -- end of debugging successfully. + debugM _LOG_NAME $ show err + sendTerminateEvent mvarCtx + + Right Nothing -> do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{currentFrameIdDebugContextData = 0, debugStartedDebugContextData = True} + breakByException mvarCtx + + Right (Just pos) -> do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{currentFrameIdDebugContextData = 0, debugStartedDebugContextData = True} + breakOrContinue pos + + breakOrContinue pos = findBreakPointType mvarCtx pos >>= \case + UnknownBreakPoint -> do + sendErrorEvent mvarCtx $ "[proceedDebug] invalid break point status. " ++ show pos + sendTerminateEvent mvarCtx + + SourceBreakPoint bp -> do + breakOrContinueSourceBreakPoint mvarCtx bp >>= \case + DoBreak -> sendStopEvent pos + DoContinue -> proceedDebug mvarCtx + DoError m -> do + sendErrorEvent mvarCtx m + sendTerminateEvent mvarCtx + + FunctionBreakPoint bp -> do + breakOrContinueFunctionBreakPoint mvarCtx bp >>= \case + DoBreak -> sendStopEvent pos + DoContinue -> proceedDebug mvarCtx + DoError m -> do + sendErrorEvent mvarCtx m + sendTerminateEvent mvarCtx + + -- | + -- + outHdl = sendStdoutEvent mvarCtx + + -- | + -- + sendStopEvent pos = do + debugM _LOG_NAME $ show pos + + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} + + resSeq <- getIncreasedResponseSequence mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent mvarCtx stopEvtStr + + +-- | +-- +data BreakPointType = + SourceBreakPoint BreakPointData + | FunctionBreakPoint BreakPointData + | UnknownBreakPoint deriving (Show, Read, Eq) + + +-- | +-- +data BreakOrContinueType = DoBreak | DoContinue | DoError String deriving (Show, Read, Eq) + + +-- | +-- +findBreakPointType :: MVar DebugContextData -> G.SourcePosition -> IO BreakPointType +findBreakPointType mvarCtx pos = do + ctx <- readMVar mvarCtx + + let bpMap = breakPointDatasDebugContextData ctx + funcMap = functionBreakPointDatasDebugContextData ctx + + case M.lookup pos bpMap of + Just bp -> return $ SourceBreakPoint bp + Nothing -> case M.lookup pos funcMap of + Just bp -> return $ FunctionBreakPoint bp + Nothing -> return UnknownBreakPoint + + +-- | +-- +breakOrContinueSourceBreakPoint :: MVar DebugContextData -> BreakPointData -> IO BreakOrContinueType +breakOrContinueSourceBreakPoint mvarCtx bp = do + ctx <- takeMVar mvarCtx + let bpMap = breakPointDatasDebugContextData ctx + newMap = M.adjust incrementBreakPointHitCount (getBreakPointKey bp) bpMap + putMVar mvarCtx ctx{breakPointDatasDebugContextData = newMap} + + breakOrContinueByCondition mvarCtx $ incrementBreakPointHitCount bp + + +-- | +-- +breakOrContinueFunctionBreakPoint :: MVar DebugContextData -> BreakPointData -> IO BreakOrContinueType +breakOrContinueFunctionBreakPoint mvarCtx bp = do + ctx <- takeMVar mvarCtx + let bpMap = functionBreakPointDatasDebugContextData ctx + newMap = M.adjust incrementBreakPointHitCount (getBreakPointKey bp) bpMap + putMVar mvarCtx ctx{functionBreakPointDatasDebugContextData = newMap} + + breakOrContinueByCondition mvarCtx $ incrementBreakPointHitCount bp + +-- | +-- +breakOrContinueByCondition :: MVar DebugContextData -> BreakPointData -> IO BreakOrContinueType +breakOrContinueByCondition _ (BreakPointData _ _ _ Nothing Nothing _) = return DoBreak +breakOrContinueByCondition _ (BreakPointData _ _ _ Nothing (Just hitCond) hitCount) = breakOrContinueByHitCount hitCond hitCount +breakOrContinueByCondition mvarCtx (BreakPointData _ _ _ (Just condStr) Nothing _) = breakOrContinueByOpCond mvarCtx condStr +breakOrContinueByCondition mvarCtx (BreakPointData _ _ _ (Just condStr) (Just hitCond) hitCount) = + breakOrContinueByHitCount hitCond hitCount >>= \case + DoError m -> return $ DoError m + DoContinue -> return DoContinue + DoBreak -> breakOrContinueByOpCond mvarCtx condStr + +-- | +-- +breakOrContinueByOpCond :: MVar DebugContextData -> String -> IO BreakOrContinueType +breakOrContinueByOpCond mvarCtx condStr = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess + where + -- | + -- + withProcess Nothing = return $ DoError "[breakOrContinueByOpCond] ghci not started." + withProcess (Just ghciProc) = do + forceBindings ghciProc outHdl + G.execBool ghciProc outHdl condStr >>= \case + Left err -> return . DoError $ "[breakOrContinueByCondition] " ++ err ++ ". '" ++ condStr ++ "'" + Right False -> do + debugM _LOG_NAME $ "continued because condition False. " ++ condStr + return DoContinue + Right True -> do + debugM _LOG_NAME $ "stopped because condition not False. " ++ condStr + return DoBreak + + -- | + -- + outHdl msg = do + sendStdoutEvent mvarCtx msg + debugM _LOG_NAME msg + + -- | + -- + forceBindings ghciProc outHdl = G.bindings ghciProc outHdl >>= \case + Left err -> sendErrorEvent mvarCtx $ "[forceBindings] " ++ err + Right bs -> mapM_ (forceBind ghciProc outHdl . G.nameBindingData) bs + + forceBind ghciProc outHdl name = G.force ghciProc outHdl name >>= \case + Left err -> sendErrorEvent mvarCtx $ "[forceBindings] " ++ err + Right _ -> return () + + +-- | +-- +breakOrContinueByHitCount :: String -> Int -> IO BreakOrContinueType +breakOrContinueByHitCount hitCondStr hitCount = case parse hitCondParser "Hit count condition parser" (U.strip hitCondStr) of + Left msg -> return . DoError $ show msg ++ ". '" ++ hitCondStr ++ "'" + Right func -> if func hitCount + then do + debugM _LOG_NAME $ "stopped because satisfy hit count. " ++ hitCondStr ++ ", " ++ show hitCount + return DoBreak + else do + debugM _LOG_NAME $ "continued because not satisfy hit count. " ++ hitCondStr ++ ", " ++ show hitCount + return DoContinue + + where + -- | + -- + hitCondParser = try digitCondParser <|> opCondParser + + -- | + -- + digitCondParser = do + valStr <- manyTill digit eof + return $ (<=) (read valStr) + + -- | + -- + opCondParser = do + op <- manyTill anyChar (space <|> lookAhead digit) + many space + valStr <- manyTill digit eof + let val = read valStr + case op of + "==" -> return $ (==) val + "/=" -> return $ (/=) val + "<" -> return $ flip (<) val + ">" -> return $ flip (>) val + "<=" -> return $ flip (<=) val + ">=" -> return $ flip (>=) val + "%" -> return $ modInternal val + "mod" -> return $ modInternal val + other -> fail other + + -- | + -- + modInternal :: Int -> Int -> Bool + modInternal a b = mod b a == 0 + diff --git a/app/Phoityne/VSCode/IO/Control.hs b/app/Phoityne/VSCode/IO/Control.hs deleted file mode 100644 --- a/app/Phoityne/VSCode/IO/Control.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module Phoityne.VSCode.IO.Control where - -import Phoityne.VSCode.Constant -import Phoityne.VSCode.Utility -import qualified Phoityne.VSCode.Argument as A -import qualified Phoityne.VSCode.IO.Core as GUI -import qualified Data.ByteString.Lazy as BSL - -import System.IO -import Control.Concurrent -import Text.Parsec -import qualified Data.ConfigFile as C -import qualified System.Log.Logger as L - --- | --- -run :: A.ArgData - -> C.ConfigParser - -> IO Int -run _ _ = do - - hSetBuffering stdin NoBuffering - hSetEncoding stdin utf8 - - hSetBuffering stdout NoBuffering - hSetEncoding stdout utf8 - - mvarDat <- newMVar GUI.defaultDebugContextData {GUI.responseHandlerDebugContextData = sendResponse} - - wait mvarDat - - return 1 - --- | --- --- -wait :: MVar GUI.DebugContextData -> IO () -wait mvarDat = go BSL.empty - where - go buf = BSL.hGet stdin 1 >>= withC buf - - withC buf c - | c == BSL.empty = unexpectedEOF - | otherwise = withBuf $ BSL.append buf c - - withBuf buf = case parse parser "readContentLength" (lbs2str buf) of - Left _ -> go buf - Right len -> BSL.hGet stdin len >>= withCnt buf - - withCnt buf cnt - | cnt == BSL.empty = unexpectedEOF - | otherwise = do - GUI.handleRequest mvarDat buf cnt - wait mvarDat - - parser = do - string "Content-Length: " - len <- manyTill digit (string _TWO_CRLF) - return . read $ len - - unexpectedEOF = do - L.criticalM _LOG_NAME "unexpected EOF on stdin." - return () - - - --- | --- -sendResponse :: BSL.ByteString -> IO () -sendResponse 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 - diff --git a/app/Phoityne/VSCode/IO/Core.hs b/app/Phoityne/VSCode/IO/Core.hs deleted file mode 100644 --- a/app/Phoityne/VSCode/IO/Core.hs +++ /dev/null @@ -1,1728 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module Phoityne.VSCode.IO.Core ( - handleRequest -, DebugContextData(..) -, defaultDebugContextData -, initializeRequestHandler -) where - - -import qualified Phoityne.GHCi as G - -import Control.Concurrent -import Control.Monad -import Data.List.Split -import Data.Char -import Safe -import System.IO -import System.Exit -import System.FilePath -import System.Directory -import System.Log.Logger -import Text.Parsec -import qualified Control.Exception as E -import qualified Data.Aeson as J -import qualified Data.ByteString.Lazy as BSL -import qualified Data.String.Utils as U -import qualified Data.List as L -import qualified Data.Map as MAP -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 Phoityne.VSCode.Constant -import Phoityne.VSCode.Utility -import Phoityne.VSCode.IO.Utility -import qualified Phoityne.VSCode.TH.BreakpointJSON as J -import qualified Phoityne.VSCode.TH.CompletionsItemJSON as J -import qualified Phoityne.VSCode.TH.CompletionsArgumentsJSON as J -import qualified Phoityne.VSCode.TH.CompletionsResponseBodyJSON as J -import qualified Phoityne.VSCode.TH.CompletionsRequestJSON as J -import qualified Phoityne.VSCode.TH.CompletionsResponseJSON as J -import qualified Phoityne.VSCode.TH.ConfigurationDoneRequestJSON as J -import qualified Phoityne.VSCode.TH.ConfigurationDoneResponseJSON as J -import qualified Phoityne.VSCode.TH.ContinueRequestJSON as J -import qualified Phoityne.VSCode.TH.ContinueResponseJSON as J -import qualified Phoityne.VSCode.TH.DisconnectRequestJSON as J -import qualified Phoityne.VSCode.TH.DisconnectResponseJSON as J -import qualified Phoityne.VSCode.TH.EvaluateArgumentsJSON as J -import qualified Phoityne.VSCode.TH.EvaluateBodyJSON as J -import qualified Phoityne.VSCode.TH.EvaluateRequestJSON as J -import qualified Phoityne.VSCode.TH.EvaluateResponseJSON as J -import qualified Phoityne.VSCode.TH.InitializedEventJSON as J -import qualified Phoityne.VSCode.TH.InitializeRequestJSON as J -import qualified Phoityne.VSCode.TH.InitializeResponseCapabilitesJSON as J -import qualified Phoityne.VSCode.TH.InitializeResponseJSON as J -import qualified Phoityne.VSCode.TH.LaunchRequestArgumentsJSON as J -import qualified Phoityne.VSCode.TH.LaunchRequestJSON as J -import qualified Phoityne.VSCode.TH.LaunchResponseJSON as J -import qualified Phoityne.VSCode.TH.NextRequestJSON as J -import qualified Phoityne.VSCode.TH.NextResponseJSON as J -import qualified Phoityne.VSCode.TH.OutputEventJSON as J -import qualified Phoityne.VSCode.TH.OutputEventBodyJSON as J -import qualified Phoityne.VSCode.TH.PauseRequestJSON as J -import qualified Phoityne.VSCode.TH.PauseResponseJSON as J -import qualified Phoityne.VSCode.TH.RequestJSON as J -import qualified Phoityne.VSCode.TH.ScopesArgumentsJSON as J -import qualified Phoityne.VSCode.TH.ScopesRequestJSON as J -import qualified Phoityne.VSCode.TH.ScopesResponseJSON as J -import qualified Phoityne.VSCode.TH.SetBreakpointsRequestArgumentsJSON as J -import qualified Phoityne.VSCode.TH.SetBreakpointsRequestJSON as J -import qualified Phoityne.VSCode.TH.SetBreakpointsResponseBodyJSON as J -import qualified Phoityne.VSCode.TH.SetBreakpointsResponseJSON as J -import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsRequestArgumentsJSON as J -import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsRequestJSON as J -import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsResponseBodyJSON as J -import qualified Phoityne.VSCode.TH.SetFunctionBreakpointsResponseJSON as J -import qualified Phoityne.VSCode.TH.SourceBreakpointJSON as J -import qualified Phoityne.VSCode.TH.FunctionBreakpointJSON as J -import qualified Phoityne.VSCode.TH.SourceJSON as J -import qualified Phoityne.VSCode.TH.SourceRequestJSON as J -import qualified Phoityne.VSCode.TH.SourceResponseJSON as J -import qualified Phoityne.VSCode.TH.StackFrameJSON as J -import qualified Phoityne.VSCode.TH.StackTraceBodyJSON as J -import qualified Phoityne.VSCode.TH.StackTraceRequestJSON as J -import qualified Phoityne.VSCode.TH.StackTraceResponseJSON as J -import qualified Phoityne.VSCode.TH.StepInRequestJSON as J -import qualified Phoityne.VSCode.TH.StepInResponseJSON as J -import qualified Phoityne.VSCode.TH.StepOutRequestJSON as J -import qualified Phoityne.VSCode.TH.StepOutResponseJSON as J -import qualified Phoityne.VSCode.TH.StoppedEventJSON as J -import qualified Phoityne.VSCode.TH.TerminatedEventJSON as J -import qualified Phoityne.VSCode.TH.TerminatedEventBodyJSON as J -import qualified Phoityne.VSCode.TH.ThreadsRequestJSON as J -import qualified Phoityne.VSCode.TH.ThreadsResponseJSON as J -import qualified Phoityne.VSCode.TH.VariableJSON as J -import qualified Phoityne.VSCode.TH.VariablesBodyJSON as J -import qualified Phoityne.VSCode.TH.VariablesRequestJSON as J -import qualified Phoityne.VSCode.TH.VariablesResponseJSON as J - --- | --- --- -data DebugContextData = - DebugContextData { - resSeqDebugContextData :: Int - , functionBreakPointDatasDebugContextData :: BreakPointDatas - , breakPointDatasDebugContextData :: BreakPointDatas - , workspaceDebugContextData :: FilePath - , startupDebugContextData :: FilePath - , debugStartedDebugContextData :: Bool - , debugStoppedPosDebugContextData :: Maybe G.SourcePosition - , currentFrameIdDebugContextData :: Int - , modifiedDebugContextData :: Bool - , ghciProcessDebugContextData :: Maybe G.GHCiProcess - , responseHandlerDebugContextData :: BSL.ByteString -> IO () - , stopOnEntryDebugContextData :: Bool - } - - --- | --- --- -data BreakPointData = - BreakPointData { - nameBreakPointData :: String - , srcPosBreakPointData :: G.SourcePosition - , breakNoBreakPointData :: Maybe Int - , conditionBreakPointData :: Maybe String - , hitConditionBreakPointData :: Maybe String - , hitCountBreakPointData :: Int - } deriving (Show, Read, Eq, Ord) - - --- | --- --- -type BreakPointDataKey = G.SourcePosition - --- | --- --- -type BreakPointDatas = MAP.Map BreakPointDataKey BreakPointData - --- | --- --- -getBreakPointKey :: BreakPointData -> BreakPointDataKey -getBreakPointKey = srcPosBreakPointData - - --- | --- -incrementBreakPointHitCount :: BreakPointData -> BreakPointData -incrementBreakPointHitCount bp = bp{hitCountBreakPointData = 1 + hitCountBreakPointData bp} - - - --- | --- --- -_INITIAL_RESPONSE_SEQUENCE :: Int -_INITIAL_RESPONSE_SEQUENCE = 0 - - --- | --- --- -_SEP_WIN :: Char -_SEP_WIN = '\\' - --- | --- --- -_SEP_UNIX :: Char -_SEP_UNIX = '/' - --- | --- --- -_TASKS_JSON_FILE_CONTENTS :: BSL.ByteString -_TASKS_JSON_FILE_CONTENTS = str2lbs $ U.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" - ] - - --- | --- --- -_DEBUG_START_MSG :: [String] -_DEBUG_START_MSG = [ - "" - , " Now, ghci launched and configuration done." - , " Press F5 to start debugging." - , " Or modify source code. it will be loaded to ghci automatically." - , " " - ] - --- | --- --- -_NOT_PERMIT_REPL_COMMANDS :: [String] -_NOT_PERMIT_REPL_COMMANDS = [ - ":{" - , ":abandon", ":back", ":break", ":continue", ":delete", ":force", ":forward" - , ":history", ":list", ":print", ":sprint", ":step", ":steplocal", ":stepmodule", ":trace" - ] - --- | --- --- -defaultDebugContextData :: DebugContextData -defaultDebugContextData = DebugContextData { - resSeqDebugContextData = _INITIAL_RESPONSE_SEQUENCE - , functionBreakPointDatasDebugContextData = MAP.fromList [] - , breakPointDatasDebugContextData = MAP.fromList [] - , workspaceDebugContextData = "" - , startupDebugContextData = "" - , debugStartedDebugContextData = False - , debugStoppedPosDebugContextData = Nothing - , currentFrameIdDebugContextData = 0 - , modifiedDebugContextData = False - , ghciProcessDebugContextData = Nothing - , responseHandlerDebugContextData = BSL.putStr - , stopOnEntryDebugContextData = False - } - - --- |===================================================================== --- Request / Response / Event --- - - --- | --- --- -logRequest :: String -> IO () -logRequest reqStr = infoM _LOG_NAME $ "[REQUEST] " ++ reqStr - - --- | --- -isLoggingStarted :: MVar DebugContextData -> IO Bool -isLoggingStarted mvarCtx = do - ctx <- readMVar mvarCtx - return . not . null $ workspaceDebugContextData ctx - --- | --- -sendResponse :: MVar DebugContextData -> BSL.ByteString -> IO () -sendResponse mvarCtx str = do - doLog <- isLoggingStarted mvarCtx - when doLog $ infoM _LOG_NAME $ "[RESPONSE]" ++ lbs2str str - - ctx <- readMVar mvarCtx - responseHandlerDebugContextData ctx str - - --- | --- --- -sendConsoleEvent :: MVar DebugContextData -> String -> IO () -sendConsoleEvent mvarCtx msg = sendOutputEventWithType mvarCtx msg "console" - - --- | --- --- -sendStdoutEvent :: MVar DebugContextData -> String -> IO () -sendStdoutEvent mvarCtx msg = sendOutputEventWithType mvarCtx msg "stdout" - - --- | --- --- -sendErrorEvent :: MVar DebugContextData -> String -> IO () -sendErrorEvent mvarCtx msg = do - doLog <- isLoggingStarted mvarCtx - when doLog $ errorM _LOG_NAME msg - sendOutputEventWithType mvarCtx msg "stderr" - - --- | --- --- -sendOutputEventWithType :: MVar DebugContextData -> String -> String -> IO () -sendOutputEventWithType mvarCtx msg msgType= do - resSeq <- getIncreasedResponseSequence mvarCtx - let outEvt = J.defaultOutputEvent resSeq - outEvtStr = J.encode outEvt{J.bodyOutputEvent = J.OutputEventBody msgType msg Nothing } - sendEvent mvarCtx outEvtStr - - --- | --- -sendEvent :: MVar DebugContextData -> BSL.ByteString -> IO () -sendEvent mvarCtx str = do - doLog <- isLoggingStarted mvarCtx - when doLog $ infoM _LOG_NAME $ "[EVENT]" ++ lbs2str str - - ctx <- readMVar mvarCtx - responseHandlerDebugContextData ctx str - - --- | --- -sendTerminateEvent :: MVar DebugContextData -> IO () -sendTerminateEvent mvarDat = do - resSeq <- getIncreasedResponseSequence mvarDat - let terminatedEvt = J.defaultTerminatedEvent resSeq - terminatedEvtStr = J.encode terminatedEvt - sendEvent mvarDat terminatedEvtStr - --- | --- -sendRestartEvent :: MVar DebugContextData -> IO () -sendRestartEvent mvarCtx = do - resSeq <- getIncreasedResponseSequence mvarCtx - let terminatedEvt = J.defaultTerminatedEvent resSeq - terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True} - sendEvent mvarCtx terminatedEvtStr - - --- |===================================================================== --- Handlers - --- | --- --- -handleRequest :: MVar DebugContextData -> BSL.ByteString -> BSL.ByteString -> IO () -handleRequest mvarDat contLenStr jsonStr = do - case J.eitherDecode jsonStr :: Either String J.Request of - Right (J.Request cmd) -> handle cmd - Left err -> sendParseErrorAndTerminate err "request" - - where - sendParseErrorAndTerminate err typ = do - let msg = L.intercalate "\n" - $ [ "[CRITICAL]"++"<"++typ++">"++" request parce error." - , lbs2str contLenStr - , lbs2str jsonStr - , show err, "" - ] ++ _ERR_MSG_URL ++ ["", ""] - sendErrorEvent mvarDat msg - sendTerminateEvent mvarDat - - handle "initialize" = case J.eitherDecode jsonStr :: Either String J.InitializeRequest of - Right req -> initializeRequestHandler mvarDat req - Left err -> do - let cont = L.intercalate " " $ map U.strip $ lines $ lbs2str contLenStr - json = L.intercalate " " $ map U.strip $ lines $ lbs2str jsonStr - er = L.intercalate " " $ map U.strip $ lines $ show err - msg = L.intercalate " " $ ["[CRITICAL] request parce error.", cont, json, er] ++ _ERR_MSG_URL - resSeq <- getIncreasedResponseSequence mvarDat - sendResponse mvarDat $ J.encode $ J.parseErrorInitializeResponse resSeq msg - sendParseErrorAndTerminate err "initialize" - - handle "launch" = case J.eitherDecode jsonStr :: Either String J.LaunchRequest of - Right req -> launchRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "launch" - - handle "configurationDone" = case J.eitherDecode jsonStr :: Either String J.ConfigurationDoneRequest of - Right req -> configurationDoneRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "configurationDone" - - handle "disconnect" = case J.eitherDecode jsonStr :: Either String J.DisconnectRequest of - Right req -> disconnectRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "disconnect" - - handle "setBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetBreakpointsRequest of - Right req -> setBreakpointsRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "setBreakpoints" - - handle "setFunctionBreakpoints" = case J.eitherDecode jsonStr :: Either String J.SetFunctionBreakpointsRequest of - Right req -> setFunctionBreakpointsRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "setFunctionBreakpoints" - - handle "continue" = case J.eitherDecode jsonStr :: Either String J.ContinueRequest of - Right req -> continueRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "continue" - - handle "next" = case J.eitherDecode jsonStr :: Either String J.NextRequest of - Right req -> nextRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "next" - - handle "stepIn" = case J.eitherDecode jsonStr :: Either String J.StepInRequest of - Right req -> stepInRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "stepIn" - - handle "stackTrace" = case J.eitherDecode jsonStr :: Either String J.StackTraceRequest of - Right req -> stackTraceRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "stackTrace" - - handle "scopes" = case J.eitherDecode jsonStr :: Either String J.ScopesRequest of - Right req -> scopesRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "scopes" - - handle "variables" = case J.eitherDecode jsonStr :: Either String J.VariablesRequest of - Right req -> variablesRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "variables" - - handle "threads" = case J.eitherDecode jsonStr :: Either String J.ThreadsRequest of - Right req -> threadsRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "threads" - - handle "evaluate" = case J.eitherDecode jsonStr :: Either String J.EvaluateRequest of - Right req -> evaluateRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "evaluate" - - handle "completions" = case J.eitherDecode jsonStr :: Either String J.CompletionsRequest of - Right req -> completionsRequestHandler mvarDat req - Left err -> sendParseErrorAndTerminate err "completions" - - -- | - -- not supported. - -- - handle "stepOut" = case J.eitherDecode jsonStr :: Either String J.StepOutRequest of - Left err -> sendParseErrorAndTerminate err "stepOut" - Right req -> do - resSeq <- getIncreasedResponseSequence mvarDat - let res = J.defaultStepOutResponse resSeq req - resStr = J.encode $ res{J.successStepOutResponse = False, J.messageStepOutResponse = "unsupported command."} - sendResponse mvarDat resStr - sendErrorEvent mvarDat "[WARN] stepOut command is not supported. ignored." - - handle "pause" = case J.eitherDecode jsonStr :: Either String J.PauseRequest of - Left err -> sendParseErrorAndTerminate err "pause" - Right req -> do - resSeq <- getIncreasedResponseSequence mvarDat - let res = J.defaultPauseResponse resSeq req - resStr = J.encode $ res{J.successPauseResponse = False, J.messagePauseResponse = "unsupported command."} - sendResponse mvarDat resStr - - sendErrorEvent mvarDat "[WARN] pause command is not supported. ignored." - - handle "source" = case J.eitherDecode jsonStr :: Either String J.SourceRequest of - Left err -> sendParseErrorAndTerminate err "source" - Right req -> do - resSeq <- getIncreasedResponseSequence mvarDat - let res = J.defaultSourceResponse resSeq req - resStr = J.encode $ res{J.successSourceResponse = False, J.messageSourceResponse = "unsupported command."} - sendResponse mvarDat resStr - - sendErrorEvent mvarDat "[WARN] source command is not supported. ignored." - - handle cmd = do - let msg = L.intercalate " " ["[WARN] unknown request command. ignored.", cmd, lbs2str contLenStr, lbs2str jsonStr] - sendErrorEvent mvarDat msg - - --- | --- -initializeRequestHandler :: MVar DebugContextData -> J.InitializeRequest -> IO () -initializeRequestHandler mvarCtx req@(J.InitializeRequest seq _ _ _) = flip E.catches handlers $ do - resSeq <- getIncreasedResponseSequence mvarCtx - let capa = J.InitializeResponseCapabilites True True True True True [] False False False False False True - res = J.InitializeResponse resSeq "response" seq True "initialize" "" capa - - sendResponse mvarCtx $ 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 <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorInitializeResponse resSeq req msg - sendErrorEvent mvarCtx msg - - --- | --- -launchRequestHandler :: MVar DebugContextData -> J.LaunchRequest -> IO () -launchRequestHandler mvarCtx req@(J.LaunchRequest _ _ _ args) = flip E.catches handlers $ do - - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx { - workspaceDebugContextData = J.workspaceLaunchRequestArguments args - , startupDebugContextData = J.startupLaunchRequestArguments args - , stopOnEntryDebugContextData = J.stopOnEntryLaunchRequestArguments args - } - - let logLevelStr = J.logLevelLaunchRequestArguments args - logLevel <- case readMay logLevelStr of - Just lv -> return lv - Nothing -> do - sendErrorEvent mvarCtx $ "log priority is invalid. WARNING set. [" ++ logLevelStr ++ "]\n" - return WARNING - - setupLogger (J.logFileLaunchRequestArguments args) logLevel - - logRequest $ show req - - prepareTasksJsonFile - - - runGHCi mvarCtx - (J.ghciCmdLaunchRequestArguments args) - (J.ghciPromptLaunchRequestArguments args) - -- (J.ghciEnvLaunchRequestArguments args) - >>= ghciLaunched - - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["launch request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorLaunchResponse resSeq req msg - sendErrorEvent mvarCtx $ msg ++ "\n" - - -- | - -- - prepareTasksJsonFile = do - ctx <- readMVar mvarCtx - let jsonFile = workspaceDebugContextData ctx ".vscode" "tasks.json" - - doesFileExist jsonFile >>= \case - True -> debugM _LOG_NAME $ "tasks.json file exists. " ++ jsonFile - False -> do - sendConsoleEvent mvarCtx $ "create tasks.json file. " ++ jsonFile ++ "\n" - saveFileLBS jsonFile _TASKS_JSON_FILE_CONTENTS - - -- | - -- - ghciLaunched (Left err) = do - let msg = L.intercalate " " ["ghci launch error.", err] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorLaunchResponse resSeq req msg - sendErrorEvent mvarCtx $ msg ++ "\n" - - sendTerminateEvent mvarCtx - - - ghciLaunched (Right ghciProc) = do - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{ghciProcessDebugContextData = Just ghciProc} - - startupRes <- loadHsFile mvarCtx (J.startupLaunchRequestArguments args) - - when (False == startupRes) $ do - let msg = L.intercalate " " ["startup load error.", J.startupLaunchRequestArguments args] - sendErrorEvent mvarCtx $ msg ++ "\n" - - setMainArgs ghciProc (J.mainArgsLaunchRequestArguments args) >>= \case - Right _ -> return () - Left err -> do - let msg = L.intercalate " " ["set args error.", err, show (J.mainArgsLaunchRequestArguments args)] - sendErrorEvent mvarCtx $ msg ++ "\n" - - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.defaultLaunchResponse resSeq req - - resSeq <- getIncreasedResponseSequence mvarCtx - sendEvent mvarCtx $ J.encode $ J.defaultInitializedEvent resSeq - - watch mvarCtx - - setMainArgs _ Nothing = return . Right $ () - setMainArgs ghciProc (Just argsStr) - | null (U.strip argsStr) = return . Right $ () - | otherwise = G.set ghciProc (sendStdoutEvent mvarCtx) ("args " ++ argsStr) - - --- | --- -configurationDoneRequestHandler :: MVar DebugContextData -> J.ConfigurationDoneRequest -> IO () -configurationDoneRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["configurationDone request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorConfigurationDoneResponse resSeq req msg - sendErrorEvent mvarCtx msg - - withProcess Nothing = sendErrorEvent mvarCtx "[withProcess] ghci not started." - - withProcess (Just ghciProc) = do - sendConsoleEvent mvarCtx $ L.intercalate "\n" _DEBUG_START_MSG - sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc - - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.defaultConfigurationDoneResponse resSeq req - - stopOnEntryDebugContextData <$> (readMVar mvarCtx) >>= stopOnEntry - - stopOnEntry False = proceedDebug mvarCtx - stopOnEntry True = do - resSeq <- getIncreasedResponseSequence mvarCtx - let stopEvt = J.defaultStoppedEvent resSeq - stopEvtStr = J.encode stopEvt - sendEvent mvarCtx stopEvtStr - - --- | --- -disconnectRequestHandler :: MVar DebugContextData -> J.DisconnectRequest -> IO () -disconnectRequestHandler mvarCtx req = do - logRequest $ show req - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - exitSuccess - - where - withProcess Nothing = do - sendErrorEvent mvarCtx "[disconnectRequestHandler] ghci not started." - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.defaultDisconnectResponse resSeq req - - withProcess (Just ghciProc) = G.quit ghciProc outHdl >>= withExitCode - - withExitCode (Left err) = do - sendErrorEvent mvarCtx $ "[disconnectRequestHandler] ghci quit error. " ++ err - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.defaultDisconnectResponse resSeq req - - withExitCode (Right code) = do - sendStdoutEvent mvarCtx $ show code - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.defaultDisconnectResponse resSeq req - - outHdl = sendStdoutEvent mvarCtx - --- | --- -setBreakpointsRequestHandler :: MVar DebugContextData -> J.SetBreakpointsRequest -> IO () -setBreakpointsRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - ctx <- readMVar mvarCtx - let cwd = workspaceDebugContextData 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 <- getIncreasedResponseSequence mvarCtx - let res = J.defaultSetBreakpointsResponse resSeq req - resStr = J.encode res{J.bodySetBreakpointsResponse = J.SetBreakpointsResponseBody resBody} - sendResponse mvarCtx resStr - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["setBreakpoints request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorSetBreakpointsResponse resSeq req msg - sendErrorEvent mvarCtx msg - - convBp cwd path (J.SourceBreakpoint lineNo colNo cond hitCond) = - BreakPointData { - nameBreakPointData = src2mod cwd path - , srcPosBreakPointData = G.SourcePosition path lineNo (maybe (-1) id colNo) (-1) (-1) - , breakNoBreakPointData = Nothing - , conditionBreakPointData = normalizeCond cond - , hitConditionBreakPointData = hitCond - , hitCountBreakPointData = 0 - } - - normalizeCond Nothing = Nothing - normalizeCond (Just c) - | null (U.strip c) = Nothing - | otherwise = Just c - - delete path = do - ctx <- takeMVar mvarCtx - let bps = breakPointDatasDebugContextData ctx - newBps = MAP.filterWithKey (\(G.SourcePosition p _ _ _ _) _-> path /= p) bps - delBps = MAP.elems $ MAP.filterWithKey (\(G.SourcePosition p _ _ _ _) _-> path == p) bps - - putMVar mvarCtx ctx{breakPointDatasDebugContextData = newBps} - - debugM _LOG_NAME $ "del bps:" ++ show delBps - - mapM_ (deleteBreakPointOnGHCi 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 = breakPointDatasDebugContextData ctx - newBps = foldr (\v@(BreakPointData _ s _ _ _ _)->MAP.insert s v) bps $ map fst results - putMVar mvarCtx ctx{breakPointDatasDebugContextData = newBps} - - return resData - - - insertInternal reqBp@(BreakPointData modName (G.SourcePosition filePath lineNo _ _ _) _ _ _ _) = - addBreakPointOnGHCi mvarCtx reqBp >>= \case - Right (no, srcPos@(G.SourcePosition path sl sc el ec)) -> - return (reqBp{ breakNoBreakPointData = Just no - , srcPosBreakPointData = srcPos - }, - J.Breakpoint (Just no) True "" - (J.Source (Just modName) path Nothing Nothing) sl sc el ec) - Left err -> - return (reqBp, - J.Breakpoint Nothing False err - (J.Source (Just modName) filePath Nothing Nothing) - lineNo (-1) lineNo (-1)) - --- | --- -setFunctionBreakpointsRequestHandler :: MVar DebugContextData -> J.SetFunctionBreakpointsRequest -> IO () -setFunctionBreakpointsRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - let args = J.argumentsSetFunctionBreakpointsRequest req - reqBps = J.breakpointsSetFunctionBreakpointsRequestArguments args - bps = map convBp reqBps - - delete - resBody <- insert bps - - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultSetFunctionBreakpointsResponse resSeq req - resStr = J.encode res{J.bodySetFunctionBreakpointsResponse = J.SetFunctionBreakpointsResponseBody resBody} - sendResponse mvarCtx resStr - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["setBreakpoints request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorSetFunctionBreakpointsResponse resSeq req msg - sendErrorEvent mvarCtx msg - - convBp (J.FunctionBreakpoint name cond hitCond) = - BreakPointData { - nameBreakPointData = name - , srcPosBreakPointData = G.SourcePosition "" (-1) (-1) (-1) (-1) - , breakNoBreakPointData = Nothing - , conditionBreakPointData = normalizeCond cond - , hitConditionBreakPointData = hitCond - , hitCountBreakPointData = 0 - } - - normalizeCond Nothing = Nothing - normalizeCond (Just c) - | null (U.strip c) = Nothing - | otherwise = Just c - - delete = do - ctx <- takeMVar mvarCtx - let bps = functionBreakPointDatasDebugContextData ctx - delBps = MAP.elems bps - - putMVar mvarCtx ctx{functionBreakPointDatasDebugContextData = MAP.fromList []} - - debugM _LOG_NAME $ "del bps:" ++ show delBps - - mapM_ (deleteBreakPointOnGHCi 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 funBPs:" ++ show addBps - debugM _LOG_NAME $ "response funBPs:" ++ show resData - - ctx <- takeMVar mvarCtx - let bps = functionBreakPointDatasDebugContextData ctx - newBps = foldr (\v@(BreakPointData _ s _ _ _ _)->MAP.insert s v) bps $ map fst results - putMVar mvarCtx ctx{functionBreakPointDatasDebugContextData = newBps} - - return resData - - - insertInternal reqBp@(BreakPointData funcName _ _ _ _ _) = do - addFunctionBreakPointOnGHCi mvarCtx reqBp >>= \case - Right (no, srcPos@(G.SourcePosition path sl sc el ec)) -> do - return ( reqBp{ breakNoBreakPointData = Just no - , srcPosBreakPointData = srcPos - } - , J.Breakpoint (Just no) True "" (J.Source (Just funcName) path Nothing Nothing) sl sc el ec) - Left err -> return (reqBp, J.Breakpoint Nothing False err (J.Source (Just funcName) "" Nothing Nothing) (-1) (-1) (-1) (-1)) - --- | --- --- -continueRequestHandler :: MVar DebugContextData -> J.ContinueRequest -> IO () -continueRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - resSeq <- getIncreasedResponseSequence mvarCtx - let resStr = J.encode $ J.defaultContinueResponse resSeq req - sendResponse mvarCtx resStr - - proceedDebug mvarCtx - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["continue request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorContinueResponse resSeq req msg - sendErrorEvent mvarCtx msg - - --- | --- --- -nextRequestHandler :: MVar DebugContextData -> J.NextRequest -> IO () -nextRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - ctx <- readMVar mvarCtx - case debugStoppedPosDebugContextData ctx of - Nothing -> do - resSeq <- getIncreasedResponseSequence 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 mvarCtx resStr - Just _ -> next - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["stepOver request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorNextResponse resSeq req msg - sendErrorEvent mvarCtx msg - - next = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - - withProcess Nothing = sendErrorEvent mvarCtx "[nextRequestHandler] ghci not started." - - withProcess (Just ghciProc) = G.stepLocal ghciProc outHdl >>= \case - Left err -> do - sendErrorEvent mvarCtx $ show err - sendTerminateEvent mvarCtx - - Right pos -> do - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} - - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultNextResponse resSeq req - resStr = J.encode res - sendResponse mvarCtx resStr - - resSeq <- getIncreasedResponseSequence mvarCtx - let stopEvt = J.defaultStoppedEvent resSeq - stopEvtStr = J.encode stopEvt - sendEvent mvarCtx stopEvtStr - - outHdl = sendStdoutEvent mvarCtx - - --- | --- --- -stepInRequestHandler :: MVar DebugContextData -> J.StepInRequest -> IO () -stepInRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - ctx <- readMVar mvarCtx - case debugStoppedPosDebugContextData ctx of - Nothing -> do - resSeq <- getIncreasedResponseSequence 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 mvarCtx 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 <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorStepInResponse resSeq req msg - sendErrorEvent mvarCtx msg - - stepIn = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - - withProcess Nothing = sendErrorEvent mvarCtx "[stepInRequestHandler] ghci not started." - - withProcess (Just ghciProc) = G.step ghciProc outHdl >>= \case - Left err -> do - sendErrorEvent mvarCtx $ show err - sendTerminateEvent mvarCtx - - Right pos -> do - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} - - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultStepInResponse resSeq req - resStr = J.encode res - sendResponse mvarCtx resStr - - resSeq <- getIncreasedResponseSequence mvarCtx - let stopEvt = J.defaultStoppedEvent resSeq - stopEvtStr = J.encode stopEvt - sendEvent mvarCtx stopEvtStr - - outHdl = sendStdoutEvent mvarCtx - - --- | --- --- -stackTraceRequestHandler :: MVar DebugContextData -> J.StackTraceRequest -> IO () -stackTraceRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - ctx <- readMVar mvarCtx - case debugStoppedPosDebugContextData ctx of - Nothing -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let body = J.StackTraceBody [] 0 - res = J.defaultStackTraceResponse resSeq req - resStr = J.encode $ res{J.bodyStackTraceResponse = body} - sendResponse mvarCtx resStr - - Just rangeData -> do - frames <- createStackFrames rangeData - debugM _LOG_NAME $ show frames - - resSeq <- getIncreasedResponseSequence mvarCtx - let body = J.StackTraceBody (reverse frames) (length frames) - res = J.defaultStackTraceResponse resSeq req - resStr = J.encode $ res{J.bodyStackTraceResponse = body} - sendResponse mvarCtx resStr - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["stackTrace request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorStackTraceResponse resSeq req msg - sendErrorEvent mvarCtx msg - - createStackFrames pos = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess pos - - withProcess pos Nothing = do - sendErrorEvent mvarCtx "[stackTraceRequestHandler] ghci not started." - defaultFrame pos - - withProcess pos (Just ghciProc) = G.history ghciProc outHdl >>= \case - Left err -> do - sendErrorEvent mvarCtx $ show err - defaultFrame pos - - Right dats -> do - cwd <- workspaceDebugContextData <$> readMVar mvarCtx - cfs <- defaultFrame pos - foldM (convTrace2Frame cwd) cfs dats - - convTrace2Frame cwd xs (G.StackFrame traceId funcName (G.SourcePosition file sl sc el ec)) = return $ - J.StackFrame traceId funcName (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc el ec : xs - - defaultFrame (G.SourcePosition file sl sc el ec) = do - ctx <- readMVar mvarCtx - let cwd = workspaceDebugContextData ctx - csf = J.StackFrame 0 "[BP]" (J.Source (Just (src2mod cwd file)) file Nothing Nothing) sl sc el ec - return [csf] - - outHdl = debugM _LOG_NAME - - --- | --- --- -scopesRequestHandler :: MVar DebugContextData -> J.ScopesRequest -> IO () -scopesRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - let args = J.argumentsScopesRequest req - traceId = J.frameIdScopesArguments args - - moveFrame mvarCtx traceId - - resSeq <- getIncreasedResponseSequence mvarCtx - let resStr = J.encode $ J.defaultScopesResponse resSeq req - sendResponse mvarCtx resStr - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["scopes request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorScopesResponse resSeq req msg - sendErrorEvent mvarCtx msg - --- | --- --- -variablesRequestHandler :: MVar DebugContextData -> J.VariablesRequest -> IO () -variablesRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - vals <- currentBindings - - resSeq <- getIncreasedResponseSequence mvarCtx - let res = J.defaultVariablesResponse resSeq req - resStr = J.encode $ res{J.bodyVariablesResponse = J.VariablesBody vals} - sendResponse mvarCtx resStr - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["variables request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorVariablesResponse resSeq req msg - sendErrorEvent mvarCtx msg - - currentBindings = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - - withProcess Nothing = do - sendErrorEvent mvarCtx "[variablesRequestHandler] ghci not started." - return [] - - withProcess (Just ghciProc) = G.bindings ghciProc outHdl >>= \case - Left err -> do - sendErrorEvent mvarCtx $ show err - return [] - - Right dats -> return $ map convBind2Vals dats - - convBind2Vals (G.BindingData varName modName val) = J.Variable varName modName val 0 - - outHdl = debugM _LOG_NAME - - --- | --- --- -threadsRequestHandler :: MVar DebugContextData -> J.ThreadsRequest -> IO () -threadsRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - resSeq <- getIncreasedResponseSequence mvarCtx - let resStr = J.encode $ J.defaultThreadsResponse resSeq req - sendResponse mvarCtx resStr - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["threads request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorThreadsResponse resSeq req msg - sendErrorEvent mvarCtx msg - - --- | --- --- -evaluateRequestHandler :: MVar DebugContextData -> J.EvaluateRequest -> IO () -evaluateRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - let (J.EvaluateArguments exp _ ctx) = J.argumentsEvaluateRequest req - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess ctx exp - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["evaluate request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorEvaluateResponse resSeq req msg - sendErrorEvent mvarCtx msg - - withProcess _ _ Nothing = sendErrorEvent mvarCtx "[evaluateRequestHandler] ghci not started." - - withProcess "watch" exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case - Left err -> do - errorM _LOG_NAME $ show err - evaluateResponse err "" - - Right typeStr -> case isFunction typeStr of - True -> evaluateResponse "" (getOnlyType typeStr) - False -> G.force ghciProc outHdl exp >>= \case - Right valStr -> evaluateResponse (getOnlyValue valStr) (getOnlyType typeStr) - Left _ -> evaluateResponse "" (getOnlyType typeStr) - - withProcess "hover" exp (Just ghciProc) = G.showType ghciProc outHdl exp >>= \case - Left err -> do - errorM _LOG_NAME $ show err - evaluateResponse err "" - Right typeStr -> evaluateResponse typeStr (getOnlyType typeStr) - - withProcess _ exp (Just ghciProc) - | null (U.strip exp) = do - evaluateResponse "" "" - sendStdoutEvent mvarCtx (G.promptGHCiProcess ghciProc) - | otherwise = replHandler ghciProc $ map U.rstrip (lines exp) - - replHandler _ [] = do - errorM _LOG_NAME "[replHandler] invalid inputs." - evaluateResponse "" "" - - replHandler ghciProc (exp:[]) - | isPermitCmd (U.strip exp) = G.exec ghciProc outHdl exp >>= \case - Left err -> do - errorM _LOG_NAME $ show err - evaluateResponse "" "" - sendErrorEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n" ++ show err - sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc - Right cmdStr -> do - evaluateResponse "" "" - sendStdoutEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n" ++ cmdStr - | otherwise = do - evaluateResponse "" "" - sendErrorEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ exp ++ "\n can not use these commands.\n" ++ show _NOT_PERMIT_REPL_COMMANDS ++ "\n" - sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc - - replHandler ghciProc exps = G.exec ghciProc outHdl ":{" >>= \case - Left err -> do - errorM _LOG_NAME $ show err - evaluateResponse "" "" - sendErrorEvent mvarCtx $ (G.promptGHCiProcess ghciProc) ++ ":{\n" ++ show err - Right cmdStr -> replsHandler ghciProc (exps ++ [":}"]) $ (G.promptGHCiProcess ghciProc) ++ ":{\n" ++ cmdStr - - replsHandler _ [] acc = do - evaluateResponse "" "" - sendStdoutEvent mvarCtx acc - - replsHandler ghciProc (x:xs) acc - | isPermitCmd (U.strip x) = G.exec ghciProc outHdl x >>= \case - Left err -> do - evaluateResponse "" "" - sendErrorEvent mvarCtx $ acc ++ x ++ "\n" ++ show err - sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc - - Right cmdStr -> replsHandler ghciProc xs $ acc ++ x ++ "\n" ++ cmdStr - | otherwise = do - evaluateResponse "" "" - sendErrorEvent mvarCtx $ acc ++ x ++ "\n can not use these commands.\n" ++ show _NOT_PERMIT_REPL_COMMANDS ++ "\n" - sendStdoutEvent mvarCtx $ G.promptGHCiProcess ghciProc - - isPermitCmd c = 0 == (length ( filter (flip U.startswith c) _NOT_PERMIT_REPL_COMMANDS)) - - outHdl = debugM _LOG_NAME - - isFunction str = case parse isFunctionParser "isFunction" str of - Right _ -> True - Left _ -> False - - isFunctionParser = manyTill anyChar (string "->") - - evaluateResponse msg typeStr = do - resSeq <- getIncreasedResponseSequence mvarCtx - let body = J.EvaluateBody msg typeStr 0 - res = J.defaultEvaluateResponse resSeq req - resStr = J.encode res{J.bodyEvaluateResponse = body} - sendResponse mvarCtx resStr - - -- | - -- force result parser - -- - -- parser of - -- Phoityne>>= :force x - -- x = 8 - -- Phoityne>>= - -- - getOnlyValue :: String -> String - getOnlyValue str = case parse getOnlyValueParser "getOnlyValue" str of - Right vals -> vals - Left _ -> str - where - getOnlyValueParser = do - _ <- manyTill anyChar (string " = ") - manyTill anyChar eof - - -- | - -- type result parser - -- - -- parser of - -- Phoityne>>= :type x - -- x :: Int -> Int - -- Phoityne>>= - -- - getOnlyType :: String -> String - getOnlyType str = case parse getOnlyTypeParser "getOnlyType" str of - Right vals -> vals - Left _ -> str - where - getOnlyTypeParser = do - _ <- manyTill anyChar (string " :: ") - manyTill anyChar eof - - --- | --- --- -completionsRequestHandler :: MVar DebugContextData -> J.CompletionsRequest -> IO () -completionsRequestHandler mvarCtx req = flip E.catches handlers $ do - logRequest $ show req - - let (J.CompletionsArguments _ key _ _) = J.argumentsCompletionsRequest req - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess key - - where - handlers = [ E.Handler someExcept ] - someExcept (e :: E.SomeException) = do - let msg = L.intercalate " " ["completions request error.", show req, show e] - resSeq <- getIncreasedResponseSequence mvarCtx - sendResponse mvarCtx $ J.encode $ J.errorCompletionsResponse resSeq req msg - sendErrorEvent mvarCtx msg - - withProcess _ Nothing = sendErrorEvent mvarCtx "[completionsRequestHandler] ghci not started." - - withProcess key (Just ghciProc) = G.complete ghciProc outHdl key 50 >>= \case - Left err -> do - errorM _LOG_NAME $ show err - resSeq <- getIncreasedResponseSequence mvarCtx - let resStr = J.encode $ J.errorCompletionsResponse resSeq req $ show err - sendResponse mvarCtx resStr - - Right xs -> do - resSeq <- getIncreasedResponseSequence mvarCtx - let bd = J.CompletionsResponseBody $ map createItem xs - res = J.defaultCompletionsResponse resSeq req - - let resStr = J.encode $ res {J.bodyCompletionsResponse = bd} - sendResponse mvarCtx resStr - - createItem (':':xs) = J.CompletionsItem xs - createItem xs = J.CompletionsItem xs - - outHdl = debugM _LOG_NAME - - --- |===================================================================== --- --- Utility - --- | --- --- -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 = False - | otherwise = isUpper $ head modName - - --- | --- --- -getIncreasedResponseSequence :: MVar DebugContextData -> IO Int -getIncreasedResponseSequence mvarCtx = do - ctx <- takeMVar mvarCtx - let resSec = 1 + resSeqDebugContextData ctx - putMVar mvarCtx ctx{resSeqDebugContextData = resSec} - return resSec - - --- | --- --- -runGHCi :: MVar DebugContextData - -> String - -> String - -> IO (Either G.ErrorData G.GHCiProcess) -runGHCi mvarCtx cmdStr pmt = do - ctx <- readMVar mvarCtx - let cmdList = filter (not.null) $ U.split " " cmdStr - cmd = head cmdList - opts = tail cmdList - cwd = workspaceDebugContextData ctx - - G.start outHdl cmd opts cwd pmt - - where - outHdl = sendStdoutEvent mvarCtx - - --- | --- --- -loadHsFile :: MVar DebugContextData -> FilePath -> IO Bool -loadHsFile mvarCtx path = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case - Nothing -> do - sendErrorEvent mvarCtx $ "load file fail.[" ++ path ++ "]" ++ " ghci not started." - return False - Just ghciProc -> G.loadFile ghciProc outHdl path >>= withFileLoadResult ghciProc - - where - outHdl msg = do - sendStdoutEvent mvarCtx msg - - withFileLoadResult _ (Left err) = do - sendErrorEvent mvarCtx $ "load file fail.[" ++ path ++ "]" ++ " " ++ err - return False - - withFileLoadResult ghciProc (Right mods) = G.loadModule ghciProc outHdl mods >>= \case - Left err -> do - sendErrorEvent mvarCtx $ "load module fail. " ++ show mods ++ " " ++ err - return False - Right _ -> return True - - --- | --- ブレークポイントをGHCi上でdeleteする --- -deleteBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO () -deleteBreakPointOnGHCi mvarCtx bp@(BreakPointData _ _ (Just breakNo) _ _ _) = - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case - Nothing -> sendErrorEvent mvarCtx $ "[deleteBreakPointOnGHCi] ghci not started. " ++ show bp - Just ghciProc -> G.delete ghciProc outHdl breakNo >>= withResult - - where - outHdl = sendStdoutEvent mvarCtx - - withResult (Left err) = sendErrorEvent mvarCtx $ "[deleteBreakPointOnGHCi] " ++ err ++ " " ++ show bp - withResult (Right _) = return () - -deleteBreakPointOnGHCi mvarCtx bp = sendErrorEvent mvarCtx $ "[deleteBreakPointOnGHCi] invalid delete break point. " ++ show bp - --- | --- GHCi上でブレークポイントを追加する --- -addBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO (Either String (Int, G.SourcePosition)) -addBreakPointOnGHCi mvarCtx bp@(BreakPointData modName (G.SourcePosition _ lineNo col _ _) _ _ _ _) = - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case - Nothing -> do - errorM _LOG_NAME $ "[addBreakPointOnGHCi] ghci not started. " ++ show bp - return $ Left $ "[addBreakPointOnGHCi] ghci not started. " ++ show bp - Just ghciProc -> G.setBreak ghciProc outHdl modName lineNo col - - where - outHdl = sendStdoutEvent mvarCtx - --- | --- GHCi上で関数ブレークポイントを追加する --- -addFunctionBreakPointOnGHCi :: MVar DebugContextData -> BreakPointData -> IO (Either String (Int, G.SourcePosition)) -addFunctionBreakPointOnGHCi mvarCtx bp@(BreakPointData name _ _ _ _ _) = - ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= \case - Nothing -> do - errorM _LOG_NAME $ "[addFunctionBreakPointOnGHCi] ghci not started. " ++ show bp - return $ Left $ "[addFunctionBreakPointOnGHCi] ghci not started. " ++ show bp - Just ghciProc -> G.setFuncBreak ghciProc outHdl name - - where - outHdl = sendStdoutEvent mvarCtx - - --- | --- Loggerのセットアップ --- -setupLogger :: FilePath -> Priority -> IO () -setupLogger logFile level = do - 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 :: MVar DebugContextData -> IO () -watch mvarCtx = do - _ <- forkIO $ watchFiles mvarCtx - return () - -watchFiles :: MVar DebugContextData -> IO () -watchFiles mvarCtx = do - FSN.withManagerConf FSN.defaultConfig{FSN.confDebounce = FSN.Debounce 1} $ \mgr -> do - - ctx <- readMVar mvarCtx - let dir = workspaceDebugContextData ctx - - debugM _LOG_NAME $ "start watch files in [" ++ dir ++ "]" - _ <- FSN.watchTree mgr dir hsFilter action - - forever $ threadDelay 1000000 - - return () - - where - hsFilter event = U.endswith _HS_FILE_EXT $ FSN.eventPath event - - action event = do - - ctx <- readMVar mvarCtx - withDebugStarted event $ debugStartedDebugContextData ctx - - withDebugStarted _ True = sendRestartEvent mvarCtx - withDebugStarted event False = do - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{modifiedDebugContextData = True} - loadHsFile mvarCtx (FSN.eventPath event) >> return () - - --- | --- --- -moveFrame :: MVar DebugContextData -> Int -> IO () -moveFrame mvarCtx traceId = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - where - withProcess Nothing = sendErrorEvent mvarCtx "[moveFrame] ghci not started." - withProcess (Just ghciProc) = do - ctx <- readMVar mvarCtx - let curTraceId = currentFrameIdDebugContextData ctx - moveCount = curTraceId - traceId - traceCmd = if 0 > moveCount then G.back ghciProc outHdl - else G.forward ghciProc outHdl - - -- _ <- traceCmd (abs moveCount) - mapM_ traceCmd [1..(abs moveCount)] - - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{currentFrameIdDebugContextData = traceId} - - outHdl = sendStdoutEvent mvarCtx - - --- | --- --- -proceedDebug :: MVar DebugContextData -> IO () -proceedDebug mvarCtx = do - ctx <- readMVar mvarCtx - let started = debugStartedDebugContextData ctx - proc = ghciProcessDebugContextData ctx - - proceed started proc - - where - -- | - -- - proceed _ Nothing = sendErrorEvent mvarCtx "[proceedDebug] ghci not started." - proceed True (Just ghciProc) = G.trace ghciProc outHdl >>= \case - Left err -> do - -- end of debugging successfully. - debugM _LOG_NAME $ show err - sendTerminateEvent mvarCtx - - Right pos -> breakOrContinue pos - - proceed False (Just ghciProc) = do - ctx <- readMVar mvarCtx - withModified (modifiedDebugContextData ctx) ghciProc - - -- | - -- - withModified True _ = sendRestartEvent mvarCtx - withModified False ghciProc = G.traceMain ghciProc outHdl >>= \case - Left err -> do - -- end of debugging successfully. - debugM _LOG_NAME $ show err - sendTerminateEvent mvarCtx - - Right pos -> do - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{currentFrameIdDebugContextData = 0, debugStartedDebugContextData = True} - breakOrContinue pos - - breakOrContinue pos = findBreakPointType mvarCtx pos >>= \case - UnknownBreakPoint -> do - sendErrorEvent mvarCtx $ "[proceedDebug] invalid break point status. " ++ show pos - sendTerminateEvent mvarCtx - - SourceBreakPoint bp -> do - breakOrContinueSourceBreakPoint mvarCtx bp >>= \case - DoBreak -> sendStopEvent pos - DoContinue -> proceedDebug mvarCtx - DoError m -> do - sendErrorEvent mvarCtx m - sendTerminateEvent mvarCtx - - FunctionBreakPoint bp -> do - breakOrContinueFunctionBreakPoint mvarCtx bp >>= \case - DoBreak -> sendStopEvent pos - DoContinue -> proceedDebug mvarCtx - DoError m -> do - sendErrorEvent mvarCtx m - sendTerminateEvent mvarCtx - - -- | - -- - outHdl = sendStdoutEvent mvarCtx - - -- | - -- - sendStopEvent pos = do - debugM _LOG_NAME $ show pos - - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{debugStoppedPosDebugContextData = Just pos} - - resSeq <- getIncreasedResponseSequence mvarCtx - let stopEvt = J.defaultStoppedEvent resSeq - stopEvtStr = J.encode stopEvt - sendEvent mvarCtx stopEvtStr - - --- | --- -data BreakPointType = - SourceBreakPoint BreakPointData - | FunctionBreakPoint BreakPointData - | UnknownBreakPoint deriving (Show, Read, Eq) - - --- | --- -data BreakOrContinueType = DoBreak | DoContinue | DoError String deriving (Show, Read, Eq) - - --- | --- -findBreakPointType :: MVar DebugContextData -> G.SourcePosition -> IO BreakPointType -findBreakPointType mvarCtx pos = do - ctx <- readMVar mvarCtx - - let bpMap = breakPointDatasDebugContextData ctx - funcMap = functionBreakPointDatasDebugContextData ctx - - case MAP.lookup pos bpMap of - Just bp -> return $ SourceBreakPoint bp - Nothing -> case MAP.lookup pos funcMap of - Just bp -> return $ FunctionBreakPoint bp - Nothing -> return UnknownBreakPoint - - --- | --- -breakOrContinueSourceBreakPoint :: MVar DebugContextData -> BreakPointData -> IO BreakOrContinueType -breakOrContinueSourceBreakPoint mvarCtx bp = do - ctx <- takeMVar mvarCtx - let bpMap = breakPointDatasDebugContextData ctx - newMap = MAP.adjust incrementBreakPointHitCount (getBreakPointKey bp) bpMap - putMVar mvarCtx ctx{breakPointDatasDebugContextData = newMap} - - breakOrContinueByCondition mvarCtx $ incrementBreakPointHitCount bp - - --- | --- -breakOrContinueFunctionBreakPoint :: MVar DebugContextData -> BreakPointData -> IO BreakOrContinueType -breakOrContinueFunctionBreakPoint mvarCtx bp = do - ctx <- takeMVar mvarCtx - let bpMap = functionBreakPointDatasDebugContextData ctx - newMap = MAP.adjust incrementBreakPointHitCount (getBreakPointKey bp) bpMap - putMVar mvarCtx ctx{functionBreakPointDatasDebugContextData = newMap} - - breakOrContinueByCondition mvarCtx $ incrementBreakPointHitCount bp - --- | --- -breakOrContinueByCondition :: MVar DebugContextData -> BreakPointData -> IO BreakOrContinueType -breakOrContinueByCondition _ (BreakPointData _ _ _ Nothing Nothing _) = return DoBreak -breakOrContinueByCondition _ (BreakPointData _ _ _ Nothing (Just hitCond) hitCount) = breakOrContinueByHitCount hitCond hitCount -breakOrContinueByCondition mvarCtx (BreakPointData _ _ _ (Just condStr) Nothing _) = breakOrContinueByOpCond mvarCtx condStr -breakOrContinueByCondition mvarCtx (BreakPointData _ _ _ (Just condStr) (Just hitCond) hitCount) = - breakOrContinueByHitCount hitCond hitCount >>= \case - DoError m -> return $ DoError m - DoContinue -> return DoContinue - DoBreak -> breakOrContinueByOpCond mvarCtx condStr - --- | --- -breakOrContinueByOpCond :: MVar DebugContextData -> String -> IO BreakOrContinueType -breakOrContinueByOpCond mvarCtx condStr = ghciProcessDebugContextData <$> (readMVar mvarCtx) >>= withProcess - where - -- | - -- - withProcess Nothing = return $ DoError "[breakOrContinueByOpCond] ghci not started." - withProcess (Just ghciProc) = do - forceBindings ghciProc outHdl - G.execBool ghciProc outHdl condStr >>= \case - Left err -> return . DoError $ "[breakOrContinueByCondition] " ++ err ++ ". '" ++ condStr ++ "'" - Right False -> do - debugM _LOG_NAME $ "continued because condition False. " ++ condStr - return DoContinue - Right True -> do - debugM _LOG_NAME $ "stopped because condition not False. " ++ condStr - return DoBreak - - -- | - -- - outHdl msg = do - sendStdoutEvent mvarCtx msg - debugM _LOG_NAME msg - - -- | - -- - forceBindings ghciProc outHdl = G.bindings ghciProc outHdl >>= \case - Left err -> sendErrorEvent mvarCtx $ "[forceBindings] " ++ err - Right bs -> mapM_ (forceBind ghciProc outHdl . G.nameBindingData) bs - - forceBind ghciProc outHdl name = G.force ghciProc outHdl name >>= \case - Left err -> sendErrorEvent mvarCtx $ "[forceBindings] " ++ err - Right _ -> return () - - --- | --- -breakOrContinueByHitCount :: String -> Int -> IO BreakOrContinueType -breakOrContinueByHitCount hitCondStr hitCount = case parse hitCondParser "Hit count condition parser" (U.strip hitCondStr) of - Left msg -> return . DoError $ show msg ++ ". '" ++ hitCondStr ++ "'" - Right func -> if func hitCount - then do - debugM _LOG_NAME $ "stopped because satisfy hit count. " ++ hitCondStr ++ ", " ++ show hitCount - return DoBreak - else do - debugM _LOG_NAME $ "continued because not satisfy hit count. " ++ hitCondStr ++ ", " ++ show hitCount - return DoContinue - - where - -- | - -- - hitCondParser = try digitCondParser <|> opCondParser - - -- | - -- - digitCondParser = do - valStr <- manyTill digit eof - return $ (<=) (read valStr) - - -- | - -- - opCondParser = do - op <- manyTill anyChar (space <|> lookAhead digit) - many space - valStr <- manyTill digit eof - let val = read valStr - case op of - "==" -> return $ (==) val - "/=" -> return $ (/=) val - "<" -> return $ flip (<) val - ">" -> return $ flip (>) val - "<=" -> return $ flip (<=) val - ">=" -> return $ flip (>=) val - "%" -> return $ modInternal val - "mod" -> return $ modInternal val - other -> fail other - - -- | - -- - modInternal :: Int -> Int -> Bool - modInternal a b = mod b a == 0 - diff --git a/app/Phoityne/VSCode/IO/Main.hs b/app/Phoityne/VSCode/IO/Main.hs deleted file mode 100644 --- a/app/Phoityne/VSCode/IO/Main.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiWayIf #-} - -module Phoityne.VSCode.IO.Main (run) where - -import qualified Phoityne.VSCode.Argument as A -import qualified Phoityne.VSCode.IO.Control as CTRL - -import Data.Either.Utils -import System.Exit -import qualified Control.Exception as E -import qualified Data.ConfigFile as C -import qualified System.Console.CmdArgs as CMD -import qualified System.Log.Logger as L - - --- | --- -run :: IO Int -run = flip E.catches handlers $ do - - args <- getArgs - - iniSet <- loadIniFile args - - flip E.finally finalProc $ do - CTRL.run args iniSet - - where - handlers = [ E.Handler helpExcept - , E.Handler exitExcept - , E.Handler ioExcept - , E.Handler someExcept - ] - finalProc = L.removeAllHandlers - helpExcept (_ :: A.HelpExitException) = return 0 - exitExcept ExitSuccess = return 0 - exitExcept (ExitFailure c) = return c - ioExcept (e :: E.IOException) = print e >> return 1 - someExcept (e :: E.SomeException) = print e >> return 1 - - --- | --- -getArgs :: IO A.ArgData -getArgs = E.catches (CMD.cmdArgs A.config) handlers - where - handlers = [E.Handler someExcept] - someExcept (e :: E.SomeException) = if - | "ExitSuccess" == show e -> E.throw A.HelpExitException - | otherwise -> E.throwIO e - - --- | --- -loadIniFile :: A.ArgData - -> IO C.ConfigParser -loadIniFile _ = do - let cp = forceEither $ C.readstring C.emptyCP defaultIniSetting - return cp{ C.accessfunc = C.interpolatingAccess 5 } - - --- | --- -defaultIniSetting :: String -defaultIniSetting = unlines [ - "[DEFAULT]" - , "work_dir = ./" - , "" - , "[LOG]" - , "file = %(work_dir)sphoityne.log" - , "level = WARNING" - , "" - , "[PHOITYNE]" - ] - diff --git a/app/Phoityne/VSCode/IO/Utility.hs b/app/Phoityne/VSCode/IO/Utility.hs deleted file mode 100644 --- a/app/Phoityne/VSCode/IO/Utility.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} - -module Phoityne.VSCode.IO.Utility where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LBS -import GHC.IO.Encoding -import Distribution.System -import Control.Monad.Trans.Resource -import qualified Data.Conduit.Binary as C -import qualified Data.Conduit as C -import qualified Data.Conduit.List as C - --- | --- --- -getReadHandleEncoding :: IO TextEncoding -getReadHandleEncoding = if - | Windows == buildOS -> mkTextEncoding "CP932//TRANSLIT" - | otherwise -> mkTextEncoding "UTF-8//TRANSLIT" - --- | --- --- -loadFile :: FilePath -> IO B.ByteString -loadFile path = do - bs <- runResourceT - $ C.sourceFile path - C.$$ C.consume - return $ B.concat bs - --- | --- --- -saveFile :: FilePath -> B.ByteString -> IO () -saveFile path cont = saveFileLBS path $ LBS.fromStrict cont - --- | --- --- -saveFileLBS :: FilePath -> LBS.ByteString -> IO () -saveFileLBS path cont = runResourceT - $ C.sourceLbs cont - C.$$ C.sinkFile path - - - diff --git a/app/Phoityne/VSCode/Main.hs b/app/Phoityne/VSCode/Main.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/Main.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} + +module Phoityne.VSCode.Main (run) where + +import qualified Phoityne.VSCode.Argument as A +import qualified Phoityne.VSCode.Control as CTRL + +import Data.Either.Utils +import System.Exit +import qualified Control.Exception as E +import qualified Data.ConfigFile as C +import qualified System.Console.CmdArgs as CMD +import qualified System.Log.Logger as L + + +-- | +-- +run :: IO Int +run = flip E.catches handlers $ do + + args <- getArgs + + iniSet <- loadIniFile args + + flip E.finally finalProc $ do + CTRL.run args iniSet + + where + handlers = [ E.Handler helpExcept + , E.Handler exitExcept + , E.Handler ioExcept + , E.Handler someExcept + ] + finalProc = L.removeAllHandlers + helpExcept (_ :: A.HelpExitException) = return 0 + exitExcept ExitSuccess = return 0 + exitExcept (ExitFailure c) = return c + ioExcept (e :: E.IOException) = print e >> return 1 + someExcept (e :: E.SomeException) = print e >> return 1 + + +-- | +-- +getArgs :: IO A.ArgData +getArgs = E.catches (CMD.cmdArgs A.config) handlers + where + handlers = [E.Handler someExcept] + someExcept (e :: E.SomeException) = if + | "ExitSuccess" == show e -> E.throw A.HelpExitException + | otherwise -> E.throwIO e + + +-- | +-- +loadIniFile :: A.ArgData + -> IO C.ConfigParser +loadIniFile _ = do + let cp = forceEither $ C.readstring C.emptyCP defaultIniSetting + return cp{ C.accessfunc = C.interpolatingAccess 5 } + + +-- | +-- +defaultIniSetting :: String +defaultIniSetting = unlines [ + "[DEFAULT]" + , "work_dir = ./" + , "" + , "[LOG]" + , "file = %(work_dir)sphoityne.log" + , "level = WARNING" + , "" + , "[PHOITYNE]" + ] + diff --git a/app/Phoityne/VSCode/TH/LaunchRequestArgumentsJSON.hs b/app/Phoityne/VSCode/TH/LaunchRequestArgumentsJSON.hs --- a/app/Phoityne/VSCode/TH/LaunchRequestArgumentsJSON.hs +++ b/app/Phoityne/VSCode/TH/LaunchRequestArgumentsJSON.hs @@ -4,7 +4,7 @@ module Phoityne.VSCode.TH.LaunchRequestArgumentsJSON where import Data.Aeson.TH --- import qualified Data.Map as M +import qualified Data.Map as M import Phoityne.VSCode.Utility -- | @@ -24,7 +24,7 @@ , ghciCmdLaunchRequestArguments :: String -- Phoityne specific argument. required. , stopOnEntryLaunchRequestArguments :: Bool -- Phoityne specific argument. required. , mainArgsLaunchRequestArguments :: Maybe String -- Phoityne specific argument. required. - -- , ghciEnvLaunchRequestArguments :: M.Map String String -- Phoityne specific argument. required. + , ghciEnvLaunchRequestArguments :: M.Map String String -- Phoityne specific argument. required. } deriving (Show, Read, Eq) diff --git a/app/Phoityne/VSCode/TH/SetExceptionBreakpointsRequestArgumentsJSON.hs b/app/Phoityne/VSCode/TH/SetExceptionBreakpointsRequestArgumentsJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetExceptionBreakpointsRequestArgumentsJSON.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SetExceptionBreakpointsRequestArgumentsJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility + +-- | +-- Arguments for 'setExceptionBreakpoints' request. +-- +data SetExceptionBreakpointsRequestArguments = + SetExceptionBreakpointsRequestArguments { + filtersSetExceptionBreakpointsRequestArguments :: [String] -- IDs of checked exception options. The set of IDs is returned via the 'exceptionBreakpointFilters' capability. + } deriving (Show, Read, Eq) + + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetExceptionBreakpointsRequestArguments") } ''SetExceptionBreakpointsRequestArguments) + diff --git a/app/Phoityne/VSCode/TH/SetExceptionBreakpointsRequestJSON.hs b/app/Phoityne/VSCode/TH/SetExceptionBreakpointsRequestJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetExceptionBreakpointsRequestJSON.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SetExceptionBreakpointsRequestJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.SetExceptionBreakpointsRequestArgumentsJSON + +-- | +-- SetExceptionBreakpoints request; value of command field is 'setExceptionBreakpoints'. +-- The request configures the debuggers response to thrown exceptions. If an exception is configured to break, +-- a StoppedEvent is fired (event type 'exception'). +-- +data SetExceptionBreakpointsRequest = + SetExceptionBreakpointsRequest { + seqSetExceptionBreakpointsRequest :: Int -- Sequence number + , typeSetExceptionBreakpointsRequest :: String -- One of "request", "response", or "event" + , commandSetExceptionBreakpointsRequest :: String -- The command to execute + , argumentsSetExceptionBreakpointsRequest :: SetExceptionBreakpointsRequestArguments -- Arguments for "setExceptionBreakpoints" request. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetExceptionBreakpointsRequest") } ''SetExceptionBreakpointsRequest) diff --git a/app/Phoityne/VSCode/TH/SetExceptionBreakpointsResponseJSON.hs b/app/Phoityne/VSCode/TH/SetExceptionBreakpointsResponseJSON.hs new file mode 100644 --- /dev/null +++ b/app/Phoityne/VSCode/TH/SetExceptionBreakpointsResponseJSON.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Phoityne.VSCode.TH.SetExceptionBreakpointsResponseJSON where + +import Data.Aeson.TH + +import Phoityne.VSCode.Utility +import Phoityne.VSCode.TH.SetExceptionBreakpointsRequestJSON + +-- | +-- Response to 'setExceptionBreakpoints' request. This is just an acknowledgement, so no body field is required. +-- +data SetExceptionBreakpointsResponse = + SetExceptionBreakpointsResponse { + seqSetExceptionBreakpointsResponse :: Int -- Sequence number + , typeSetExceptionBreakpointsResponse :: String -- One of "request", "response", or "event" + , request_seqSetExceptionBreakpointsResponse :: Int -- Sequence number of the corresponding request + , successSetExceptionBreakpointsResponse :: Bool -- Outcome of the request + , commandSetExceptionBreakpointsResponse :: String -- The command requested + , messageSetExceptionBreakpointsResponse :: String -- Contains error message if success == false. + } deriving (Show, Read, Eq) + +$(deriveJSON defaultOptions { fieldLabelModifier = rdrop (length "SetExceptionBreakpointsResponse") } ''SetExceptionBreakpointsResponse) + + +-- | +-- +defaultSetExceptionBreakpointsResponse :: Int -> SetExceptionBreakpointsRequest -> SetExceptionBreakpointsResponse +defaultSetExceptionBreakpointsResponse seq (SetExceptionBreakpointsRequest reqSeq _ _ _) = + SetExceptionBreakpointsResponse seq "response" reqSeq True "setExceptionBreakpoints" "" + + +-- | +-- +errorSetExceptionBreakpointsResponse :: Int -> SetExceptionBreakpointsRequest -> String -> SetExceptionBreakpointsResponse +errorSetExceptionBreakpointsResponse seq (SetExceptionBreakpointsRequest reqSeq _ _ _) msg = + SetExceptionBreakpointsResponse seq "response" reqSeq False "setExceptionBreakpoints" msg + diff --git a/app/Phoityne/VSCode/TH/SetFunctionBreakpointsResponseJSON.hs b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsResponseJSON.hs --- a/app/Phoityne/VSCode/TH/SetFunctionBreakpointsResponseJSON.hs +++ b/app/Phoityne/VSCode/TH/SetFunctionBreakpointsResponseJSON.hs @@ -30,12 +30,12 @@ -- defaultSetFunctionBreakpointsResponse :: Int -> SetFunctionBreakpointsRequest -> SetFunctionBreakpointsResponse defaultSetFunctionBreakpointsResponse seq (SetFunctionBreakpointsRequest reqSeq _ _ _) = - SetFunctionBreakpointsResponse seq "response" reqSeq True "setBreakpoints" "" defaultSetFunctionBreakpointsResponseBody + SetFunctionBreakpointsResponse seq "response" reqSeq True "setFunctionBreakpoints" "" defaultSetFunctionBreakpointsResponseBody -- | -- errorSetFunctionBreakpointsResponse :: Int -> SetFunctionBreakpointsRequest -> String -> SetFunctionBreakpointsResponse errorSetFunctionBreakpointsResponse seq (SetFunctionBreakpointsRequest reqSeq _ _ _) msg = - SetFunctionBreakpointsResponse seq "response" reqSeq False "setBreakpoints" msg defaultSetFunctionBreakpointsResponseBody + SetFunctionBreakpointsResponse seq "response" reqSeq False "setFunctionBreakpoints" msg defaultSetFunctionBreakpointsResponseBody diff --git a/app/Phoityne/VSCode/TH/StoppedEventBodyJSON.hs b/app/Phoityne/VSCode/TH/StoppedEventBodyJSON.hs --- a/app/Phoityne/VSCode/TH/StoppedEventBodyJSON.hs +++ b/app/Phoityne/VSCode/TH/StoppedEventBodyJSON.hs @@ -29,3 +29,5 @@ defaultStoppedEventBody :: StoppedEventBody defaultStoppedEventBody = StoppedEventBody "step" 0 "" False +exceptionStoppedEventBody :: String -> StoppedEventBody +exceptionStoppedEventBody msg = StoppedEventBody "exception" 0 msg False diff --git a/app/Phoityne/VSCode/TH/VariableJSON.hs b/app/Phoityne/VSCode/TH/VariableJSON.hs --- a/app/Phoityne/VSCode/TH/VariableJSON.hs +++ b/app/Phoityne/VSCode/TH/VariableJSON.hs @@ -16,6 +16,7 @@ nameVariable :: String -- The variable's name , typeVariable :: String -- he variable's type. , valueVariable :: String -- The variable's value. For structured objects this can be a multi line text, e.g. for a function the body of a function. + , evaluateNameVariable :: Maybe String -- Optional evaluatable name of this variable which can be passed to the 'EvaluateRequest' to fetch the variable's value. , variablesReferenceVariable :: Int -- If variablesReference is > 0, the variable is structured and its children can be retrieved by passing variablesReference to the VariablesRequest. } deriving (Show, Read, Eq) diff --git a/app/Phoityne/VSCode/Utility.hs b/app/Phoityne/VSCode/Utility.hs --- a/app/Phoityne/VSCode/Utility.hs +++ b/app/Phoityne/VSCode/Utility.hs @@ -1,7 +1,12 @@ +{-# LANGUAGE MultiWayIf #-} + module Phoityne.VSCode.Utility where import Data.Either.Utils +import GHC.IO.Encoding +import Distribution.System +import Control.Monad.Trans.Resource import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.List as L @@ -11,6 +16,9 @@ import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.ConfigFile as CFG import qualified Data.Tree as TR +import qualified Data.Conduit.Binary as C +import qualified Data.Conduit as C +import qualified Data.Conduit.List as C -- | @@ -18,21 +26,25 @@ str2bs :: String -> BS.ByteString str2bs = TE.encodeUtf8 . T.pack + -- | -- bs2str :: BS.ByteString -> String bs2str = T.unpack. TE.decodeUtf8 + -- | -- str2lbs :: String -> LBS.ByteString str2lbs = TLE.encodeUtf8 . TL.pack + -- | -- lbs2str :: LBS.ByteString -> String lbs2str = TL.unpack. TLE.decodeUtf8 + -- | -- getIniItems :: CFG.ConfigParser @@ -58,8 +70,47 @@ pushWithLimit [] item _ = [item] pushWithLimit buf item maxSize = if length buf > maxSize then item : L.init buf else item : buf + -- | -- rdrop :: Int -> [a] -> [a] rdrop cnt = reverse . drop cnt . reverse + + +-- | +-- +-- +getReadHandleEncoding :: IO TextEncoding +getReadHandleEncoding = if + | Windows == buildOS -> mkTextEncoding "CP932//TRANSLIT" + | otherwise -> mkTextEncoding "UTF-8//TRANSLIT" + + +-- | +-- +-- +loadFile :: FilePath -> IO BS.ByteString +loadFile path = do + bs <- runResourceT + $ C.sourceFile path + C.$$ C.consume + return $ BS.concat bs + + +-- | +-- +-- +saveFile :: FilePath -> BS.ByteString -> IO () +saveFile path cont = saveFileLBS path $ LBS.fromStrict cont + + +-- | +-- +-- +saveFileLBS :: FilePath -> LBS.ByteString -> IO () +saveFileLBS path cont = runResourceT + $ C.sourceLbs cont + C.$$ C.sinkFile path + + diff --git a/phoityne-vscode.cabal b/phoityne-vscode.cabal --- a/phoityne-vscode.cabal +++ b/phoityne-vscode.cabal @@ -1,5 +1,5 @@ name: phoityne-vscode -version: 0.0.14.0 +version: 0.0.15.0 synopsis: ghci debug viewer on Visual Studio Code description: Please see README.md license: BSD3 @@ -21,12 +21,12 @@ main-is: Main.hs other-modules: Paths_phoityne_vscode , Phoityne.VSCode.Argument - , Phoityne.VSCode.IO.Control - , Phoityne.VSCode.IO.Main - , Phoityne.VSCode.IO.Core + , Phoityne.VSCode.Control + , Phoityne.VSCode.Main + , Phoityne.VSCode.Core , Phoityne.VSCode.Constant , Phoityne.VSCode.Utility - , Phoityne.VSCode.IO.Utility + , Phoityne.VSCode.Utility , Phoityne.VSCode.TH.BreakpointJSON , Phoityne.VSCode.TH.CompletionsItemJSON , Phoityne.VSCode.TH.CompletionsArgumentsJSON @@ -78,6 +78,9 @@ , Phoityne.VSCode.TH.SetBreakpointsRequestJSON , Phoityne.VSCode.TH.SetBreakpointsResponseBodyJSON , Phoityne.VSCode.TH.SetBreakpointsResponseJSON + , Phoityne.VSCode.TH.SetExceptionBreakpointsRequestArgumentsJSON + , Phoityne.VSCode.TH.SetExceptionBreakpointsRequestJSON + , Phoityne.VSCode.TH.SetExceptionBreakpointsResponseJSON , Phoityne.VSCode.TH.SetFunctionBreakpointsRequestArgumentsJSON , Phoityne.VSCode.TH.SetFunctionBreakpointsRequestJSON , Phoityne.VSCode.TH.SetFunctionBreakpointsResponseBodyJSON @@ -113,8 +116,8 @@ , Phoityne.VSCode.TH.VariablesRequestJSON , Phoityne.VSCode.TH.VariablesResponseJSON , Phoityne.GHCi - , Phoityne.GHCi.IO.Command - , Phoityne.GHCi.IO.Process + , Phoityne.GHCi.Command + , Phoityne.GHCi.Process build-depends: base >= 4.7 && < 5 , directory , Cabal @@ -126,12 +129,8 @@ , aeson , bytestring , containers - , conduit - , conduit-extra , text - , resourcet , process - , HStringTemplate , transformers , mtl , filepath @@ -139,5 +138,8 @@ , parsec , split , fsnotify + , conduit + , conduit-extra + , resourcet default-language: Haskell2010