diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,4 +1,11 @@ + +20160508 phoityne-vscode-0.0.2.0 + + * [Add] デバッガ起動後、ファイル保存時にghciにリロードするようにした。 + * [Add] 条件付きブレークポイントに対応した。 + + 20160504 phoityne-vscode-0.0.1.0 * [Info] Initial release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,8 +14,7 @@ 5. Set startup source file. Default file is test/Spec.hs 6. Run debug(F5) -![Document](https://sites.google.com/site/phoityne/doc_jp/demo01.gif?attredirects=0) - +[![Demo Video1](https://sites.google.com/site/phoityne/doc_jp/demo01.gif?attredirects=0)](https://sites.google.com/site/phoityne/doc_jp/demo01.gif?attredirects=0) ## Install @@ -36,6 +35,7 @@ 1. create folder "%USERPROFILE%\.vscode\extensions\phoityne-vscode" 2. copy "phoityne-vscode-0.0.1.0\vscode\package.json"(*) to "%USERPROFILE%\.vscode\extensions\phoityne-vscode" 3. copy "%USERPROFILE%\AppData\Roaming\local\bin\phoityne-vscode.exe" to "%USERPROFILE%\.vscode\extensions\phoityne-vscode" +4. Install "Haskell Syntax Highlighting" extension. Ctrl+p and put "ext install haskell syntax highlighting". (*) download by stack unpack. diff --git a/app/Phoityne/IO/GUI/Control.hs b/app/Phoityne/IO/GUI/Control.hs --- a/app/Phoityne/IO/GUI/Control.hs +++ b/app/Phoityne/IO/GUI/Control.hs @@ -59,6 +59,7 @@ import qualified Phoityne.IO.GUI.VSCode.TH.StepOutResponseJSON as J import qualified Phoityne.IO.GUI.VSCode.TH.StoppedEventJSON as J import qualified Phoityne.IO.GUI.VSCode.TH.TerminatedEventJSON as J +import qualified Phoityne.IO.GUI.VSCode.TH.TerminatedEventBodyJSON as J import qualified Phoityne.IO.GUI.VSCode.TH.ThreadsRequestJSON as J import qualified Phoityne.IO.GUI.VSCode.TH.ThreadsResponseJSON as J import qualified Phoityne.IO.GUI.VSCode.TH.VariableJSON as J @@ -83,7 +84,7 @@ import Data.Maybe import Data.Functor.Identity import Control.Monad - +import qualified System.FSNotify as FSN -- | @@ -98,6 +99,7 @@ , debugStartedDebugContext :: Bool , debugStoppedPosDebugContext :: Maybe HighlightTextRangeData , currentFrameIdDebugContext :: Int + , modifiedDebugContext :: Bool } deriving (Show, Read, Eq, Ord) @@ -210,12 +212,20 @@ -- -- defaultDebugContext :: DebugContext -defaultDebugContext = DebugContext _INITIAL_RESPONSE_SEQUENCE (MAP.fromList []) "" "" False Nothing 0 +defaultDebugContext = DebugContext _INITIAL_RESPONSE_SEQUENCE (MAP.fromList []) "" "" False Nothing 0 False + -- | -- -- +getKeyOfHighlightTextRangeData :: HighlightTextRangeData -> BreakPointDataKey +getKeyOfHighlightTextRangeData (HighlightTextRangeData file line _ _ _) = (file, line) + + +-- | +-- +-- run :: DebugCommandData -> IO () run cmdData = do @@ -445,6 +455,18 @@ resSeq <- incResSeq mvarCtx sendEvent $ J.encode $ J.defaultInitializedEvent resSeq + watch cmdData mvarCtx + + let infoMsg = [ + "" + , " Now, ghci initialized." + , " Press F5 to start debugging." + , " Or modify source code. it will be loaded to debugger automatically." + , "" + ] + putStrLnConsole mvarCtx $ L.intercalate "\n" infoMsg + putStrStdout mvarCtx _PHOITYNE_GHCI_PROMPT + where handlers = [ E.Handler someExcept ] someExcept (e :: E.SomeException) = do @@ -452,8 +474,51 @@ errorM _LOG_NAME msg + -- | -- +-- +watch :: DebugCommandData -> MVar DebugContext -> IO () +watch cmdData mvarCtx = do + _ <- forkIO $ watchFiles cmdData mvarCtx + return () + +watchFiles :: DebugCommandData -> MVar DebugContext -> IO () +watchFiles cmdData mvarCtx = do + FSN.withManagerConf FSN.defaultConfig{FSN.confDebounce = FSN.Debounce 1} $ \mgr -> do + + ctx <- readMVar mvarCtx + let dir = workspaceDebugContext ctx + + infoM _LOG_NAME $ "start watch files in [" ++ dir ++ "]" + _ <- FSN.watchTree mgr dir hsFilter action + + forever $ threadDelay 1000000 + + return () + + where + hsFilter event = endswith _HS_FILE_EXT $ FSN.eventPath event + + action event = do + + ctx <- readMVar mvarCtx + withDebugStarted event $ debugStartedDebugContext ctx + + withDebugStarted _ True = do + resSeq <- incResSeq mvarCtx + let terminatedEvt = J.defaultTerminatedEvent resSeq + terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True} + sendEvent terminatedEvtStr + + withDebugStarted event False = do + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{modifiedDebugContext = True} + loadHsFile cmdData mvarCtx (FSN.eventPath event) >> return () + + +-- | +-- disconnectHandler :: DebugCommandData -> MVar DebugContext -> J.DisconnectRequest -> IO () disconnectHandler cmdData mvarCtx req = flip E.catches handlers $ do @@ -560,7 +625,9 @@ let src = J.Source (Just modName) filePath Nothing Nothing addBreakPointOnCUI cmdData mvarCtx reqBp >>= \case - Right no -> return (reqBp{breakNoBreakPointData = Just no}, J.Breakpoint (Just no) True "" src lineNo 1) + Right no -> do + --putStrLnStdout mvarCtx $ "set breakpoint on " ++ filePathBreakPointData reqBp ++ ":L" ++ show (lineNoBreakPointData reqBp) + return (reqBp{breakNoBreakPointData = Just no}, J.Breakpoint (Just no) True "" src lineNo 1) Left err -> return (reqBp, J.Breakpoint Nothing False err src lineNo 1) -- | @@ -759,11 +826,11 @@ cmdStr <- forceVar exp infoM _LOG_NAME cmdStr - putStrLnStdout mvarCtx cmdStr + -- putStrLnStdout mvarCtx cmdStr cmdStr <- getResult infoM _LOG_NAME cmdStr - putStrStdout mvarCtx cmdStr + -- putStrStdout mvarCtx cmdStr let result = L.intercalate " " . filter (not . null) . map strip . init . lines $ cmdStr @@ -774,13 +841,13 @@ sendResponse resStr - eval "repl" exp = do - let exec = execCommandData cmdData + eval "hover" exp = do + let info = infoDebugCommandData cmdData getResult = readDebugCommandData cmdData - cmdStr <- exec exp + cmdStr <- info exp infoM _LOG_NAME cmdStr - + cmdStr <- getResult infoM _LOG_NAME cmdStr @@ -791,20 +858,17 @@ res = J.defaultEvaluateResponse resSeq req resStr = J.encode res{J.bodyEvaluateResponse = body} sendResponse resStr - - putStrStdout mvarCtx $ "\n" ++ _PHOITYNE_GHCI_PROMPT + eval _ exp = do let exec = execCommandData cmdData getResult = readDebugCommandData cmdData cmdStr <- exec exp infoM _LOG_NAME cmdStr - putStrLnStdout mvarCtx cmdStr - + cmdStr <- getResult infoM _LOG_NAME cmdStr - putStrLnStdout mvarCtx cmdStr let result = L.intercalate " " . filter (not . null) . map strip . init . lines $ cmdStr @@ -814,7 +878,11 @@ resStr = J.encode res{J.bodyEvaluateResponse = body} sendResponse resStr + putStrStdout mvarCtx $ "\n" ++ _PHOITYNE_GHCI_PROMPT + + + -- | -- -- @@ -843,8 +911,6 @@ startDebugInternal started - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{currentFrameIdDebugContext = 0} where startDebugInternal True = do @@ -862,6 +928,16 @@ sendEventByDebugStopStatus cmdData mvarCtx cmdStr startDebugInternal False = do + ctx <- readMVar mvarCtx + withModified $ modifiedDebugContext ctx + + withModified True = do + resSeq <- incResSeq mvarCtx + let terminatedEvt = J.defaultTerminatedEvent resSeq + terminatedEvtStr = J.encode terminatedEvt{J.bodyTerminatedEvent = J.TerminatedEventBody True} + sendEvent terminatedEvtStr + + withModified False = do let getResult = readDebugCommandData cmdData runDebug = runDebugCommandData cmdData @@ -872,7 +948,11 @@ cmdStr <- getResult infoM _LOG_NAME cmdStr putStrStdout mvarCtx cmdStr - + + + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{currentFrameIdDebugContext = 0, debugStartedDebugContext = True} + sendEventByDebugStopStatus cmdData mvarCtx cmdStr @@ -880,7 +960,7 @@ -- -- sendEventByDebugStopStatus :: DebugCommandData -> MVar DebugContext -> String -> IO () -sendEventByDebugStopStatus _ mvarCtx cmdStr = case getStoppedTextRangeData cmdStr of +sendEventByDebugStopStatus cmdData mvarCtx cmdStr = case getStoppedTextRangeData cmdStr of Left err -> do infoM _LOG_NAME $ show err --putStrLnStdout mvarCtx $ show err @@ -890,18 +970,76 @@ terminatedEvtStr = J.encode terminatedEvt sendEvent terminatedEvtStr - Right pos -> do - infoM _LOG_NAME $ show pos + Right pos -> continueWithHighlightTextRangeData cmdData mvarCtx pos - ctx <- takeMVar mvarCtx - putMVar mvarCtx ctx{debugStartedDebugContext = True, debugStoppedPosDebugContext = Just pos} - resSeq <- incResSeq mvarCtx - let stopEvt = J.defaultStoppedEvent resSeq - stopEvtStr = J.encode stopEvt - sendEvent stopEvtStr +-- | +-- +-- +continueWithHighlightTextRangeData :: DebugCommandData -> MVar DebugContext -> HighlightTextRangeData -> IO () +continueWithHighlightTextRangeData cmdData mvarCtx pos = do + ctx <- readMVar mvarCtx + let bpKey = getKeyOfHighlightTextRangeData pos + bpMap = breakPointDatasDebugContext ctx + case MAP.lookup bpKey bpMap of + Nothing -> do + errorM _LOG_NAME $ "breakpoint not found." ++ show bpKey + sendStopEvent + Just condCmd -> continueWithCondCmd $ conditionBreakPointData condCmd + + where + + -- | + -- + continueWithCondCmd Nothing = do + infoM _LOG_NAME "no condition breakpoint" + sendStopEvent + continueWithCondCmd (Just condStr) = do + + let condition = execCommandData cmdData + getResult = readDebugCommandData cmdData + + _ <- condition condStr + infoM _LOG_NAME condStr + putStrLnStdout mvarCtx condStr + + cmdStr <- getResult + infoM _LOG_NAME cmdStr + putStrStdout mvarCtx cmdStr + + condRes <- getConditionResult cmdStr + + continueWithCondResult condRes + + -- | + -- + continueWithCondResult False = startDebug cmdData mvarCtx + continueWithCondResult True = sendStopEvent + + -- | + -- + getConditionResult res + | L.isPrefixOf "True" res = return True + | L.isPrefixOf "False" res = return False + | otherwise = warningM _LOG_NAME ("invalid condition result. " ++ res) >> return True + + + -- | + -- + sendStopEvent = do + infoM _LOG_NAME $ show pos + + ctx <- takeMVar mvarCtx + putMVar mvarCtx ctx{debugStoppedPosDebugContext = Just pos} + + resSeq <- incResSeq mvarCtx + let stopEvt = J.defaultStoppedEvent resSeq + stopEvtStr = J.encode stopEvt + sendEvent stopEvtStr + + -- | -- -- @@ -1022,6 +1160,11 @@ -- -- utility +-- | +-- +-- +putStrLnConsole :: MVar DebugContext -> String -> IO () +putStrLnConsole mvarCtx msg = putStrConsole mvarCtx (msg ++ "\n") -- | -- @@ -1193,7 +1336,7 @@ -- ブレークポイントをGHCi上でdeleteする -- deleteBreakPointOnCUI :: DebugCommandData -> MVar DebugContext -> BreakPointData -> IO () -deleteBreakPointOnCUI cmdData mvarCtx (BreakPointData _ _ _ (Just breakNo) _) = do +deleteBreakPointOnCUI cmdData _ (BreakPointData _ _ _ (Just breakNo) _) = do let deleteBreak = deleteBreakDebugCommandData cmdData getResult = readDebugCommandData cmdData @@ -1215,7 +1358,7 @@ -- GHCi上でブレークポイントを追加する -- addBreakPointOnCUI :: DebugCommandData -> MVar DebugContext -> BreakPointData -> IO (Either String Int) -addBreakPointOnCUI cmdData mvarCtx (BreakPointData modName _ lineNo _ _) = do +addBreakPointOnCUI cmdData _ (BreakPointData modName _ lineNo _ _) = do let setBreak = breakDebugCommandData cmdData getResult = readDebugCommandData cmdData @@ -1269,6 +1412,12 @@ -- | +-- +drive2lower :: FilePath -> FilePath +drive2lower (x : ':' : xs) = toLower x : ':' : xs +drive2lower xs = xs + +-- | -- parser of -- A) src\Phoityne\IO\Main.hs:31:11-14 -- B) src\Main.hs:(17,3)-(19,35) @@ -1279,7 +1428,7 @@ parseHighlightTextRange = do path <- manyTill anyChar (string (_HS_FILE_EXT ++ ":")) (sl, sn, el, en) <- try parseA <|> try parseB <|> try parseC - return $ HighlightTextRangeData (path ++ _HS_FILE_EXT) sl sn el en + return $ HighlightTextRangeData (drive2lower path ++ _HS_FILE_EXT) sl sn el en where parseA = do ln <- manyTill digit (char ':') diff --git a/phoityne-vscode.cabal b/phoityne-vscode.cabal --- a/phoityne-vscode.cabal +++ b/phoityne-vscode.cabal @@ -1,5 +1,5 @@ name: phoityne-vscode -version: 0.0.1.0 +version: 0.0.2.0 synopsis: ghci debug viewer on Visual Studio Code description: Please see README.md license: BSD3 @@ -124,6 +124,7 @@ , directory , parsec , split + , fsnotify default-language: Haskell2010 test-suite phoityne-vscode-test