phoityne-vscode 0.0.14.0 → 0.0.15.0
raw patch · 24 files changed
+3073/−2808 lines, 24 filesdep −HStringTemplate
Dependencies removed: HStringTemplate
Files
- Changelog.md +6/−0
- README.md +30/−17
- app/Main.hs +1/−1
- app/Phoityne/GHCi.hs +4/−4
- app/Phoityne/GHCi/Command.hs +639/−0
- app/Phoityne/GHCi/IO/Command.hs +0/−627
- app/Phoityne/GHCi/IO/Process.hs +0/−209
- app/Phoityne/GHCi/Process.hs +222/−0
- app/Phoityne/VSCode/Control.hs +84/−0
- app/Phoityne/VSCode/Core.hs +1857/−0
- app/Phoityne/VSCode/IO/Control.hs +0/−84
- app/Phoityne/VSCode/IO/Core.hs +0/−1728
- app/Phoityne/VSCode/IO/Main.hs +0/−76
- app/Phoityne/VSCode/IO/Utility.hs +0/−47
- app/Phoityne/VSCode/Main.hs +76/−0
- app/Phoityne/VSCode/TH/LaunchRequestArgumentsJSON.hs +2/−2
- app/Phoityne/VSCode/TH/SetExceptionBreakpointsRequestArgumentsJSON.hs +20/−0
- app/Phoityne/VSCode/TH/SetExceptionBreakpointsRequestJSON.hs +24/−0
- app/Phoityne/VSCode/TH/SetExceptionBreakpointsResponseJSON.hs +39/−0
- app/Phoityne/VSCode/TH/SetFunctionBreakpointsResponseJSON.hs +2/−2
- app/Phoityne/VSCode/TH/StoppedEventBodyJSON.hs +2/−0
- app/Phoityne/VSCode/TH/VariableJSON.hs +1/−0
- app/Phoityne/VSCode/Utility.hs +51/−0
- phoityne-vscode.cabal +13/−11
Changelog.md view
@@ -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
README.md view
@@ -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. -+ +(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 @@  +### Break on Exception++++ ### Repl & Completions  ## 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
app/Main.hs view
@@ -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 -- |
app/Phoityne/GHCi.hs view
@@ -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
+ app/Phoityne/GHCi/Command.hs view
@@ -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 <exception thrown>" 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+--+-- <interactive>: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 "<interactive>"))+ _ <- manyTill anyChar (char ' ')+ manyTill anyChar eof
− app/Phoityne/GHCi/IO/Command.hs
@@ -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------ <interactive>: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 "<interactive>"))- _ <- manyTill anyChar (char ' ')- manyTill anyChar eof
− app/Phoityne/GHCi/IO/Process.hs
@@ -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
+ app/Phoityne/GHCi/Process.hs view
@@ -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
+ app/Phoityne/VSCode/Control.hs view
@@ -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+
+ app/Phoityne/VSCode/Core.hs view
@@ -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]<initialize> 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+
− app/Phoityne/VSCode/IO/Control.hs
@@ -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-
− app/Phoityne/VSCode/IO/Core.hs
@@ -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]<initialize> 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-
− app/Phoityne/VSCode/IO/Main.hs
@@ -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]"- ]-
− app/Phoityne/VSCode/IO/Utility.hs
@@ -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---
+ app/Phoityne/VSCode/Main.hs view
@@ -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]"+ ]+
app/Phoityne/VSCode/TH/LaunchRequestArgumentsJSON.hs view
@@ -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)
+ app/Phoityne/VSCode/TH/SetExceptionBreakpointsRequestArgumentsJSON.hs view
@@ -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)+
+ app/Phoityne/VSCode/TH/SetExceptionBreakpointsRequestJSON.hs view
@@ -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)
+ app/Phoityne/VSCode/TH/SetExceptionBreakpointsResponseJSON.hs view
@@ -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+
app/Phoityne/VSCode/TH/SetFunctionBreakpointsResponseJSON.hs view
@@ -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
app/Phoityne/VSCode/TH/StoppedEventBodyJSON.hs view
@@ -29,3 +29,5 @@ defaultStoppedEventBody :: StoppedEventBody defaultStoppedEventBody = StoppedEventBody "step" 0 "" False +exceptionStoppedEventBody :: String -> StoppedEventBody+exceptionStoppedEventBody msg = StoppedEventBody "exception" 0 msg False
app/Phoityne/VSCode/TH/VariableJSON.hs view
@@ -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)
app/Phoityne/VSCode/Utility.hs view
@@ -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++
phoityne-vscode.cabal view
@@ -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