phoityne-vscode 0.0.1.0 → 0.0.2.0
raw patch · 4 files changed
+189/−32 lines, 4 filesdep +fsnotify
Dependencies added: fsnotify
Files
- Changelog.md +7/−0
- README.md +2/−2
- app/Phoityne/IO/GUI/Control.hs +178/−29
- phoityne-vscode.cabal +2/−1
Changelog.md view
@@ -1,4 +1,11 @@ ++20160508 phoityne-vscode-0.0.2.0++ * [Add] デバッガ起動後、ファイル保存時にghciにリロードするようにした。+ * [Add] 条件付きブレークポイントに対応した。++ 20160504 phoityne-vscode-0.0.1.0 * [Info] Initial release.
README.md view
@@ -14,8 +14,7 @@ 5. Set startup source file. Default file is test/Spec.hs 6. Run debug(F5) --+[](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.
app/Phoityne/IO/GUI/Control.hs view
@@ -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 ':')
phoityne-vscode.cabal view
@@ -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