leksah-0.16.2.2: src/IDE/LogRef.hs
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards, ScopedTypeVariables, OverloadedStrings #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.LogRef
-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License : GNU-GPL
--
-- Maintainer : <maintainer at leksah.org>
-- Stability : provisional
-- Portability : portable
--
--
-- |
--
---------------------------------------------------------------------------------
module IDE.LogRef (
nextError
, previousError
, nextBreakpoint
, previousBreakpoint
, markLogRefs
, unmarkLogRefs
, defaultLineLogger
, defaultLineLogger'
, logOutputLines
, logOutputLines_
, logOutputLinesDefault_
, logOutput
, logOutputDefault
, logOutputPane
, logOutputForBuild
, logOutputForBreakpoints
, logOutputForSetBreakpoint
, logOutputForSetBreakpointDefault
, logOutputForLiveContext
, logOutputForLiveContextDefault
, logOutputForHistoricContext
, logOutputForHistoricContextDefault
, selectRef
, setBreakpointList
, showSourceSpan
, srcSpanParser
) where
import Control.Monad.Reader
import Text.ParserCombinators.Parsec.Language
import Text.ParserCombinators.Parsec hiding(Parser)
import qualified Text.ParserCombinators.Parsec.Token as P
import IDE.Core.State
import IDE.TextEditor
import IDE.Pane.SourceBuffer
import qualified IDE.Pane.Log as Log
import IDE.Utils.Tool
import System.FilePath (equalFilePath, makeRelative, isAbsolute, (</>))
import Data.List (partition, stripPrefix, elemIndex, isPrefixOf)
import Data.Maybe (catMaybes, isJust)
import System.Exit (ExitCode(..))
import System.Log.Logger (debugM)
import IDE.Utils.FileUtils(myCanonicalizePath)
import IDE.Pane.Log (getDefaultLogLaunch, IDELog(..), getLog)
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import Data.Conduit ((=$))
import IDE.Pane.WebKit.Output(setOutput)
import Data.IORef (atomicModifyIORef, IORef, readIORef)
import Data.Text (Text)
import Control.Applicative ((<$>))
import qualified Data.Text as T
(length, stripPrefix, isPrefixOf, unpack, unlines, pack, null)
import Data.Monoid ((<>))
import qualified Data.Set as S (notMember, member, insert, empty)
import Data.Set (Set)
import Data.Sequence (ViewR(..), Seq)
import qualified Data.Foldable as F (toList, forM_)
import qualified Data.Sequence as Seq
(null, singleton, viewr, reverse, fromList)
import System.Directory (doesFileExist)
showSourceSpan :: LogRef -> Text
showSourceSpan = T.pack . displaySrcSpan . logRefSrcSpan
selectRef :: Maybe LogRef -> IDEAction
selectRef (Just ref) = do
mbBuf <- selectSourceBuf (logRefFullFilePath ref)
case mbBuf of
Just buf -> markRefInSourceBuf buf ref True
Nothing -> liftIO . void $ debugM "leksah" "no buf"
log :: Log.IDELog <- Log.getLog
maybe (return ()) (Log.markErrorInLog log) (logLines ref)
selectRef Nothing = return ()
forOpenLogRefs :: (LogRef -> IDEBuffer -> IDEAction) -> IDEAction
forOpenLogRefs f = do
logRefs <- readIDE allLogRefs
allBufs <- allBuffers
F.forM_ logRefs $ \ref -> do
let fp = logRefFullFilePath ref
fpc <- liftIO $ myCanonicalizePath fp
forM_ (filter (\buf -> case fileName buf of
Just fn -> equalFilePath fpc fn
Nothing -> False) allBufs) (f ref)
markLogRefs :: IDEAction
markLogRefs =
forOpenLogRefs $ \logRef buf -> markRefInSourceBuf buf logRef False
unmarkLogRefs :: IDEAction
unmarkLogRefs =
forOpenLogRefs $ \logRef IDEBuffer {sourceView = sv} -> do
buf <- getBuffer sv
removeTagByName buf (T.pack $ show (logRefType logRef))
setBreakpointList :: Seq LogRef -> IDEAction
setBreakpointList breaks = do
ideR <- ask
unmarkLogRefs
errs <- readIDE errorRefs
contexts <- readIDE contextRefs
modifyIDE_ (\ide -> ide{allLogRefs = errs <> breaks <> contexts})
setCurrentBreak Nothing
markLogRefs
triggerEventIDE BreakpointChanged
return ()
addLogRefs :: Seq LogRef -> IDEAction
addLogRefs refs = do
ideR <- ask
unmarkLogRefs
modifyIDE_ (\ide -> ide{allLogRefs = allLogRefs ide <> refs})
setCurrentError Nothing
markLogRefs
triggerEventIDE (ErrorChanged False)
triggerEventIDE BreakpointChanged
triggerEventIDE TraceChanged
return ()
next :: (IDE -> Seq LogRef)
-> (IDE -> Maybe LogRef)
-> (Maybe LogRef -> IDEAction)
-> IDEAction
next all current set = do
all <- F.toList <$> readIDE all
current <- readIDE current
let isCurrent = (== current) . Just
case dropWhile isCurrent (dropWhile (not . isCurrent) all) <> all of
(n:_) -> do
set (Just n)
selectRef (Just n)
_ -> return ()
nextError :: IDEAction
nextError = next errorRefs currentError setCurrentError
previousError :: IDEAction
previousError = next (Seq.reverse . errorRefs) currentError setCurrentError
nextBreakpoint :: IDEAction
nextBreakpoint = next breakpointRefs currentBreak setCurrentBreak
previousBreakpoint :: IDEAction
previousBreakpoint = next (Seq.reverse . breakpointRefs) currentBreak setCurrentBreak
nextContext :: IDEAction
nextContext = next contextRefs currentContext setCurrentContext
previousContext :: IDEAction
previousContext = next (Seq.reverse . contextRefs) currentContext setCurrentContext
lastContext :: IDEAction
lastContext = do
contexts <- readIDE contextRefs
currentContext <- readIDE currentContext
case contexts of
(Seq.viewr -> _ :> l) -> do
setCurrentContext $ Just l
selectRef $ Just l
_ -> return ()
fixColumn c = max 0 (c - 1)
srcPathParser :: CharParser () FilePath
srcPathParser = try (do
symbol "dist/build/tmp-" -- Support for cabal haddock
many digit
char '/'
many (noneOf ":"))
<|> many (noneOf ":")
srcSpanParser :: CharParser () SrcSpan
srcSpanParser = try (do
filePath <- srcPathParser
char ':'
char '('
beginLine <- int
char ','
beginCol <- int
char ')'
char '-'
char '('
endLine <- int
char ','
endCol <- int
char ')'
return $ SrcSpan filePath beginLine (fixColumn beginCol) endLine (fixColumn endCol))
<|> try (do
filePath <- srcPathParser
char ':'
line <- int
char ':'
beginCol <- int
char '-'
endCol <- int
return $ SrcSpan filePath line (fixColumn beginCol) line (fixColumn endCol))
<|> try (do
filePath <- srcPathParser
char ':'
line <- int
char ':'
col <- int
return $ SrcSpan filePath line (fixColumn col) line (fixColumn col))
<?> "srcSpanParser"
data BuildOutput = BuildProgress Int Int FilePath
| DocTestFailure SrcSpan Text
buildOutputParser :: CharParser () BuildOutput
buildOutputParser = try (do
char '['
n <- int
whiteSpace
symbol "of"
whiteSpace
total <- int
char ']'
whiteSpace
symbol "Compiling"
many (noneOf "(")
char '('
whiteSpace
file <- many (noneOf ",")
char ','
many anyChar
return $ BuildProgress n total file)
<|> try (do
symbol "###"
whiteSpace
symbol "Failure"
whiteSpace
symbol "in"
whiteSpace
file <- many (noneOf ":")
char ':'
line <- int
char ':'
whiteSpace
text <- T.pack <$> many anyChar
return $ DocTestFailure (SrcSpan file line 7 line (T.length text - 7)) $ "Failure in " <> text)
<?> "buildOutputParser"
data BuildError = BuildLine
| EmptyLine
| ErrorLine SrcSpan LogRefType Text
| WarningLine Text
| OtherLine Text
| ElmFile FilePath Text
| ElmLine Int
| ElmPointLine Int
| ElmColumn Int Int
buildErrorParser :: CharParser () BuildError
buildErrorParser = try (do
char '['
int
symbol "of"
int
char ']'
many anyChar
return BuildLine)
<|> try (do
whiteSpace
span <- srcSpanParser
char ':'
whiteSpace
refType <- try (do
symbol "Warning:" <|> symbol "warning:"
return WarningRef)
<|> (do
symbol "Error:" <|> symbol "error:"
return ErrorRef)
<|> return ErrorRef
text <- T.pack <$> many anyChar
return (ErrorLine span refType text))
<|> try (do
char '-'
char '-'
char ' '
whiteSpace
text <- T.pack . reverse . drop 1 . reverse <$> many (noneOf "-")
char '-'
char '-'
many (char '-')
whiteSpace
optional (char '.' >> char '/')
file <- many anyChar
return (ElmFile file text))
<|> try (do
line <- int
char '|'
pointer <- char '>' <|> char ' '
text <- T.pack <$> many anyChar
return $ (case pointer of
'>' -> ElmPointLine
_ -> ElmLine) line)
<|> try (do
col1 <- length <$> many (char ' ')
char '^'
col2 <- length <$> many (char '^')
eof
return (ElmColumn col1 (col1 + col2)))
<|> try (do
whiteSpace
eof
return EmptyLine)
<|> try (do
whiteSpace
warning <- T.pack <$> (symbol "Warning:" <|> symbol "warning:")
text <- T.pack <$> many anyChar
return (WarningLine (warning <> text)))
<|> try (do
text <- T.pack <$> many anyChar
eof
return (OtherLine text))
<?> "buildLineParser"
data BreakpointDescription = BreakpointDescription Int SrcSpan
breaksLineParser :: CharParser () BreakpointDescription
breaksLineParser = try (do
char '['
n <- int
char ']'
whiteSpace
many (noneOf " ")
whiteSpace
span <- srcSpanParser
return (BreakpointDescription n span))
<?> "breaksLineParser"
setBreakpointLineParser :: CharParser () BreakpointDescription
setBreakpointLineParser = try (do
symbol "Breakpoint"
whiteSpace
n <- int
whiteSpace
symbol "activated"
whiteSpace
symbol "at"
whiteSpace
span <- srcSpanParser
return (BreakpointDescription n span))
<?> "setBreakpointLineParser"
lexer = P.makeTokenParser emptyDef
lexeme = P.lexeme lexer
whiteSpace = P.whiteSpace lexer
hexadecimal = P.hexadecimal lexer
symbol = P.symbol lexer
identifier = P.identifier lexer
colon = P.colon lexer
int = fromInteger <$> P.integer lexer
defaultLineLogger :: IDELog -> LogLaunch -> ToolOutput -> IDEM Int
defaultLineLogger log logLaunch out = liftIO $ defaultLineLogger' log logLaunch out
defaultLineLogger' :: IDELog -> LogLaunch -> ToolOutput -> IO Int
defaultLineLogger' log logLaunch out =
case out of
ToolInput line -> appendLog' (line <> "\n") InputTag
ToolOutput line -> appendLog' (line <> "\n") LogTag
ToolError line -> appendLog' (line <> "\n") ErrorTag
ToolPrompt line -> do
unless (T.null line) $ void (appendLog' (line <> "\n") LogTag)
appendLog' (T.pack (concat (replicate 20 "- ")) <> "-\n") FrameTag
ToolExit ExitSuccess -> appendLog' (T.pack (replicate 41 '-') <> "\n") FrameTag
ToolExit (ExitFailure 1) -> appendLog' (T.pack (replicate 41 '=') <> "\n") FrameTag
ToolExit (ExitFailure n) -> appendLog' (T.pack (take 41 ("========== " ++ show n <> " " ++ repeat '=')) <> "\n") FrameTag
where
appendLog' = Log.appendLog log logLaunch
paneLineLogger :: IDELog -> LogLaunch -> ToolOutput -> IDEM (Maybe Text)
paneLineLogger log logLaunch out = liftIO $ paneLineLogger' log logLaunch out
paneLineLogger' :: IDELog -> LogLaunch -> ToolOutput -> IO (Maybe Text)
paneLineLogger' log logLaunch out =
case out of
ToolInput line -> appendLog' (line <> "\n") InputTag >> return Nothing
ToolOutput line -> appendLog' (line <> "\n") LogTag >> return (Just line)
ToolError line -> appendLog' (line <> "\n") ErrorTag >> return Nothing
ToolPrompt line -> do
unless (T.null line) $ void (appendLog' (line <> "\n") LogTag)
appendLog' (T.pack (concat (replicate 20 "- ")) <> "-\n") FrameTag
return Nothing
ToolExit ExitSuccess -> appendLog' (T.pack (replicate 41 '-') <> "\n") FrameTag >> return Nothing
ToolExit (ExitFailure 1) -> appendLog' (T.pack (replicate 41 '=') <> "\n") FrameTag >> return Nothing
ToolExit (ExitFailure n) -> appendLog' (T.pack (take 41 ("========== " ++ show n ++ " " ++ repeat '=')) <> "\n") FrameTag >> return Nothing
where
appendLog' = Log.appendLog log logLaunch
logOutputLines :: LogLaunch -- ^ logLaunch
-> (IDELog -> LogLaunch -> ToolOutput -> IDEM a)
-> C.Sink ToolOutput IDEM [a]
logOutputLines logLaunch lineLogger = do
log :: Log.IDELog <- lift $ postSyncIDE Log.getLog
results <- CL.mapM (postSyncIDE . lineLogger log logLaunch) =$ CL.consume
lift . postSyncIDE $ triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])
return results
logOutputLines_ :: LogLaunch
-> (IDELog -> LogLaunch -> ToolOutput -> IDEM a)
-> C.Sink ToolOutput IDEM ()
logOutputLines_ logLaunch lineLogger = do
logOutputLines logLaunch lineLogger
return ()
logOutputLinesDefault_ :: (IDELog -> LogLaunch -> ToolOutput -> IDEM a)
-> C.Sink ToolOutput IDEM ()
logOutputLinesDefault_ lineLogger = do
defaultLogLaunch <- lift getDefaultLogLaunch
logOutputLines_ defaultLogLaunch lineLogger
logOutput :: LogLaunch
-> C.Sink ToolOutput IDEM ()
logOutput logLaunch = do
logOutputLines logLaunch defaultLineLogger
return ()
logOutputDefault :: C.Sink ToolOutput IDEM ()
logOutputDefault = do
defaultLogLaunch <- lift getDefaultLogLaunch
logOutput defaultLogLaunch
logOutputPane :: Text -> IORef [Text] -> C.Sink ToolOutput IDEM ()
logOutputPane command buffer = do
defaultLogLaunch <- lift getDefaultLogLaunch
result <- catMaybes <$> logOutputLines defaultLogLaunch paneLineLogger
unless (null result) $ do
liftIO $ debugM "leskah" "logOutputPane has result"
new <- liftIO . atomicModifyIORef buffer $ \x -> let new = x ++ result in (new, new)
mbURI <- lift $ readIDE autoURI
unless (isJust mbURI) . lift . postSyncIDE . setOutput command $ T.unlines new
data BuildOutputState = BuildOutputState { log :: IDELog
, inError :: Bool
, inDocTest :: Bool
, errs :: [LogRef]
, elmLine :: Int
, testFails :: [LogRef]
, filesCompiled :: Set FilePath
}
-- Not quite a Monoid
initialState :: IDELog -> BuildOutputState
initialState log = BuildOutputState log False False [] 1 [] S.empty
-- Sometimes we get error spans relative to a build dependency
findSourcePackage :: Project -> IDEPackage -> FilePath -> IO IDEPackage
findSourcePackage project package file =
doesFileExist (ipdPackageDir package </> file) >>= \case
True -> return package
False ->
-- If the file only exists in one package in the project it is probably the right one
filterM (\p -> doesFileExist $ ipdPackageDir p </> file) (pjPackages project) >>= \case
[p] -> return p
_ -> return package -- Not really sure where this file is
logOutputForBuild :: Project
-> IDEPackage
-> Bool
-> Bool
-> C.Sink ToolOutput IDEM [LogRef]
logOutputForBuild project package backgroundBuild jumpToWarnings = do
liftIO $ debugM "leksah" "logOutputForBuild"
log <- lift getLog
logLaunch <- lift Log.getDefaultLogLaunch
-- Elm does not log files compiled so just clear all the log refs for elm files
lift $ postSyncIDE $ removeFileExtLogRefs (ipdPackageDir package) ".elm" [ErrorRef, WarningRef]
BuildOutputState {..} <- CL.foldM (readAndShow logLaunch) $ initialState log
lift $ postSyncIDE $ do
allErrorLikeRefs <- readIDE errorRefs
triggerEventIDE (Sensitivity [(SensitivityError,not (Seq.null allErrorLikeRefs))])
let errorNum = length (filter isError errs)
let warnNum = length errs - errorNum
triggerEventIDE (StatusbarChanged [CompartmentState
(T.pack $ show errorNum ++ " Errors, " ++ show warnNum ++ " Warnings"), CompartmentBuild False])
return errs
where
readAndShow :: LogLaunch -> BuildOutputState -> ToolOutput -> IDEM BuildOutputState
readAndShow logLaunch state@BuildOutputState {..} output = do
ideR <- ask
let logPrevious (previous:_) = reflectIDE (addLogRef False backgroundBuild previous) ideR
logPrevious _ = return ()
liftIDE $ postSyncIDE $ liftIO $ do
debugM "leksah" $ "readAndShow " ++ show output
case output of
-- stack prints everything to stderr, so let's process errors as normal output first
ToolError line -> processNormalOutput ideR logLaunch state logPrevious line $ do
let parsed = parse buildErrorParser "" $ T.unpack line
let nonErrorPrefixes = ["Linking ", "ar:", "ld:", "ld warning:"]
tag <- case parsed of
Right BuildLine -> return InfoTag
Right (OtherLine text) | "Linking " `T.isPrefixOf` text ->
-- when backgroundBuild $ lift interruptProcess
return InfoTag
Right (OtherLine text) | any (`T.isPrefixOf` text) nonErrorPrefixes ->
return InfoTag
_ -> return ErrorTag
lineNr <- Log.appendLog log logLaunch (line <> "\n") tag
case (parsed, errs) of
(Left e,_) -> do
sysMessage Normal . T.pack $ show e
return state { inError = False }
(Right ne@(ErrorLine span refType str),_) -> do
foundInPackage <- findSourcePackage project package (srcSpanFilename span)
let ref = LogRef span (ipdCabalFile foundInPackage) str Nothing (Just (lineNr,lineNr)) refType
root = logRefRootPath ref
file = logRefFilePath ref
fullFilePath = logRefFullFilePath ref
unless (fullFilePath `S.member` filesCompiled) $
reflectIDE (removeBuildLogRefs (root </> file)) ideR
when inError $ logPrevious errs
return state { inError = True
, errs = ref:errs
, elmLine = 1
, filesCompiled = S.insert fullFilePath filesCompiled
}
(Right (ElmFile efile str),_) -> do
let ref = LogRef (SrcSpan efile 1 0 1 0) (ipdCabalFile package) str Nothing (Just (lineNr,lineNr)) ErrorRef
root = logRefRootPath ref
file = logRefFilePath ref
fullFilePath = logRefFullFilePath ref
when inError $ logPrevious errs
return state { inError = True
, errs = ref:errs
, elmLine = 1
, filesCompiled = S.insert fullFilePath filesCompiled
}
(Right (ElmLine eline), _) ->
if inError
then return state
{ elmLine = eline
}
else return state
(Right (ElmPointLine eline), ref:tl) ->
if inError
then return state
{ errs = ref
{ logRefSrcSpan =
case logRefSrcSpan ref of
SrcSpan f 1 0 1 0 -> SrcSpan f eline 0 (eline + 1) 0
SrcSpan f l _ _ _ -> SrcSpan f l 0 (eline + 1) 0
} : tl
}
else return state
(Right (ElmColumn c1 c2), ref@LogRef{logRefSrcSpan = span}:tl) ->
if inError
then do
let line = max 1 elmLine
leftMargin = 2 + length (show line)
return state
{ errs = ref
{ logRefSrcSpan = (logRefSrcSpan ref)
{ srcSpanStartColumn = max 0 (c1 - leftMargin)
, srcSpanEndColumn = max 0 (c2 - leftMargin)
, srcSpanStartLine = line
, srcSpanEndLine = line
}
} : tl
}
else return state
(Right (OtherLine str1), ref@(LogRef span rootPath str Nothing (Just (l1,l2)) refType):tl) ->
if inError
then return state { errs = LogRef span rootPath
(if T.null str then line else str <> "\n" <> line)
Nothing
(Just (l1, lineNr))
refType
: tl
}
else return state
(Right (WarningLine str1),LogRef span rootPath str Nothing (Just (l1, l2)) isError : tl) ->
if inError
then return state { errs = LogRef span rootPath
(if T.null str then line else str <> "\n" <> line)
Nothing
(Just (l1, lineNr))
WarningRef
: tl
}
else return state
(Right EmptyLine, _) -> return state -- Elm errors can contain empty lines
_ -> do
when inError $ logPrevious errs
return state { inError = False }
ToolOutput line ->
processNormalOutput ideR logLaunch state logPrevious line $
case (inDocTest, testFails) of
(True, LogRef span rootPath str Nothing (Just (l1, l2)) refType : tl) -> do
logLn <- Log.appendLog log logLaunch (line <> "\n") ErrorTag
return state { testFails = LogRef span
rootPath
(str <> "\n" <> line)
Nothing (Just (l1,logLn)) TestFailureRef : tl
}
_ -> do
Log.appendLog log logLaunch (line <> "\n") LogTag
when inDocTest $ logPrevious testFails
return state { inDocTest = False }
ToolInput line -> do
Log.appendLog log logLaunch (line <> "\n") InputTag
return state
ToolPrompt line -> do
unless (T.null line) . void $ Log.appendLog log logLaunch (line <> "\n") LogTag
when inError $ logPrevious errs
when inDocTest $ logPrevious testFails
let errorNum = length (filter isError errs)
let warnNum = length errs - errorNum
case errs of
[] -> defaultLineLogger' log logLaunch output
_ -> Log.appendLog log logLaunch (T.pack $ "- - - " ++ show errorNum ++ " errors - "
++ show warnNum ++ " warnings - - -\n") FrameTag
return state { inError = False, inDocTest = False }
ToolExit _ -> do
let errorNum = length (filter isError errs)
warnNum = length errs - errorNum
when inError $ logPrevious errs
when inDocTest $ logPrevious testFails
case (errs, testFails) of
([], []) -> defaultLineLogger' log logLaunch output
_ -> Log.appendLog log logLaunch (T.pack $ "----- " ++ show errorNum ++ " errors -- "
++ show warnNum ++ " warnings -- "
++ show (length testFails) ++ " doctest failures -----\n") FrameTag
return state { inError = False, inDocTest = False }
-- process output line as normal, otherwise calls given alternative
processNormalOutput :: IORef IDE -> LogLaunch -> BuildOutputState -> ([LogRef]->IO()) -> Text -> IO BuildOutputState -> IO BuildOutputState
processNormalOutput ideR logLaunch state@BuildOutputState {..} logPrevious line altFunction =
case parse buildOutputParser "" $ T.unpack line of
(Right (BuildProgress n total file)) -> do
logLn <- Log.appendLog log logLaunch (line <> "\n") LogTag
reflectIDE (triggerEventIDE (StatusbarChanged [CompartmentState
(T.pack $ "Compiling " ++ show n ++ " of " ++ show total), CompartmentBuild False])) ideR
f <- if isAbsolute file
then return file
else (</> file) . ipdPackageDir <$> findSourcePackage project package file
reflectIDE (removeBuildLogRefs f) ideR
when inDocTest $ logPrevious testFails
return state { inDocTest = False }
(Right (DocTestFailure span exp)) -> do
logLn <- Log.appendLog log logLaunch (line <> "\n") ErrorTag
when inDocTest $ logPrevious testFails
return state { inDocTest = True
, testFails = LogRef span
(ipdCabalFile package)
exp
Nothing (Just (logLn,logLn)) TestFailureRef : testFails
}
_ -> altFunction
--logOutputLines :: Text -- ^ logLaunch
-- -> (LogLaunch -> ToolOutput -> IDEM a)
-- -> [ToolOutput]
-- -> IDEM [a]
logOutputForBreakpoints :: IDEPackage
-> LogLaunch -- ^ loglaunch
-> C.Sink ToolOutput IDEM ()
logOutputForBreakpoints package logLaunch = do
breaks <- logOutputLines logLaunch (\log logLaunch out -> postSyncIDE $
case out of
ToolOutput line -> do
logLineNumber <- liftIO $ Log.appendLog log logLaunch (line <> "\n") LogTag
case parse breaksLineParser "" $ T.unpack line of
Right (BreakpointDescription n span) ->
return $ Just $ LogRef span (ipdCabalFile package) line Nothing (Just (logLineNumber, logLineNumber)) BreakpointRef
_ -> return Nothing
_ -> do
defaultLineLogger log logLaunch out
return Nothing)
lift . setBreakpointList . Seq.fromList $ catMaybes breaks
logOutputForSetBreakpoint :: IDEPackage
-> LogLaunch -- ^ loglaunch
-> C.Sink ToolOutput IDEM ()
logOutputForSetBreakpoint package logLaunch = do
breaks <- logOutputLines logLaunch (\log logLaunch out ->
case out of
ToolOutput line -> do
logLineNumber <- liftIO $ Log.appendLog log logLaunch (line <> "\n") LogTag
case parse setBreakpointLineParser "" $ T.unpack line of
Right (BreakpointDescription n span) ->
return $ Just $ LogRef span (ipdCabalFile package) line Nothing (Just (logLineNumber, logLineNumber)) BreakpointRef
_ -> return Nothing
_ -> do
defaultLineLogger log logLaunch out
return Nothing)
lift . postSyncIDE . addLogRefs . Seq.fromList $ catMaybes breaks
logOutputForSetBreakpointDefault :: IDEPackage
-> C.Sink ToolOutput IDEM ()
logOutputForSetBreakpointDefault package = do
defaultLogLaunch <- lift getDefaultLogLaunch
logOutputForSetBreakpoint package defaultLogLaunch
logOutputForContext :: IDEPackage
-> LogLaunch -- ^ loglaunch
-> (Text -> [SrcSpan])
-> C.Sink ToolOutput IDEM ()
logOutputForContext package loglaunch getContexts = do
refs <- catMaybes <$> logOutputLines loglaunch (\log logLaunch out ->
case out of
ToolOutput line -> do
logLineNumber <- liftIO $ Log.appendLog log logLaunch (line <> "\n") LogTag
let contexts = getContexts line
if null contexts
then return Nothing
else return $ Just $ LogRef (last contexts) (ipdCabalFile package) line Nothing (Just (logLineNumber, logLineNumber)) ContextRef
_ -> do
defaultLineLogger log logLaunch out
return Nothing)
lift . unless (null refs) . postSyncIDE $ do
addLogRefs . Seq.singleton $ last refs
lastContext
contextParser :: CharParser () SrcSpan
contextParser = try (do
whiteSpace
symbol "Logged breakpoint at" <|> symbol "Stopped at"
whiteSpace
srcSpanParser)
<?> "historicContextParser"
logOutputForLiveContext :: IDEPackage
-> LogLaunch -- ^ loglaunch
-> C.Sink ToolOutput IDEM ()
logOutputForLiveContext package logLaunch = logOutputForContext package logLaunch (getContexts . T.unpack)
where
getContexts [] = []
getContexts line@(x:xs) = case parse contextParser "" line of
Right desc -> desc : getContexts xs
_ -> getContexts xs
logOutputForLiveContextDefault :: IDEPackage
-> C.Sink ToolOutput IDEM ()
logOutputForLiveContextDefault package = do
defaultLogLaunch <- lift getDefaultLogLaunch
logOutputForLiveContext package defaultLogLaunch
logOutputForHistoricContext :: IDEPackage
-> LogLaunch -- ^ loglaunch
-> C.Sink ToolOutput IDEM ()
logOutputForHistoricContext package logLaunch = logOutputForContext package logLaunch getContexts
where
getContexts line = case parse contextParser "" $ T.unpack line of
Right desc -> [desc]
_ -> []
logOutputForHistoricContextDefault :: IDEPackage
-> C.Sink ToolOutput IDEM ()
logOutputForHistoricContextDefault package = do
defaultLogLaunch <- lift getDefaultLogLaunch
logOutputForHistoricContext package defaultLogLaunch