Commit 158530a5 authored by Rufflewind's avatar Rufflewind Committed by Ben Gamari
Browse files

Add caret diagnostics

This is controlled by -f[no-]diagnostics-show-caret.

Example of what it looks like:
```
    |
 42 |     x = 1 + ()
    |         ^^^^^^
```
This is appended to each diagnostic message.

Test Plan:
testsuite/tests/warnings/should_fail/CaretDiagnostics1
testsuite/tests/warnings/should_fail/CaretDiagnostics2

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj, bgamari

Subscribers: joehillen, mpickering, Phyx, simonpj, alanz, thomie

Differential Revision: https://phabricator.haskell.org/D2718

GHC Trac Issues: #8809
parent 8f89e763
......@@ -9,8 +9,8 @@ import json
path = sys.argv[1]
warnings = []
if os.path.isfile(path):
with open(path) as f:
if '\0' in f.read(8000):
with open(path, 'rb') as f:
if b'\0' in f.read(8000):
warning = {
'severity': 'warning',
'message': 'This file appears to be a binary file; does it really belong in the repository?'
......
......@@ -25,9 +25,9 @@ logger.debug(sys.argv)
path = sys.argv[1]
warnings = []
r = re.compile(r'ASSERT\s+\(')
r = re.compile(rb'ASSERT\s+\(')
if os.path.isfile(path):
with open(path) as f:
with open(path, 'rb') as f:
for lineno, line in enumerate(f):
if r.search(line):
warning = {
......
......@@ -176,7 +176,8 @@ import FastString
import Outputable
import Foreign.C ( CInt(..) )
import System.IO.Unsafe ( unsafeDupablePerformIO )
import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn )
import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn
, getCaretDiagnostic )
import SysTools.Terminal ( stderrSupportsAnsiColors )
import System.IO.Unsafe ( unsafePerformIO )
......@@ -517,6 +518,7 @@ data GeneralFlag
-- output style opts
| Opt_ErrorSpans -- Include full span info in error messages,
-- instead of just the start position.
| Opt_DiagnosticsShowCaret -- Show snippets of offending code
| Opt_PprCaseAsLet
| Opt_PprShowTicks
| Opt_ShowHoleConstraints
......@@ -1699,8 +1701,14 @@ defaultLogAction dflags reason severity srcSpan style msg
SevInteractive -> putStrSDoc msg style
SevInfo -> printErrs msg style
SevFatal -> printErrs msg style
_ -> do hPutChar stderr '\n'
printErrs message (setStyleColoured True style)
_ -> do -- otherwise (i.e. SevError or SevWarning)
hPutChar stderr '\n'
caretDiagnostic <-
if gopt Opt_DiagnosticsShowCaret dflags
then getCaretDiagnostic severity srcSpan
else pure empty
printErrs (message $+$ caretDiagnostic)
(setStyleColoured True style)
-- careful (#2302): printErrs prints in UTF-8,
-- whereas converting to string first and using
-- hPutStr would just emit the low 8 bits of
......@@ -3477,6 +3485,7 @@ fFlagsDeps = [
flagSpec "defer-type-errors" Opt_DeferTypeErrors,
flagSpec "defer-typed-holes" Opt_DeferTypedHoles,
flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables,
flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret,
flagSpec "dicts-cheap" Opt_DictsCheap,
flagSpec "dicts-strict" Opt_DictsStrict,
flagSpec "dmd-tx-dict-sel" Opt_DmdTxDictSel,
......@@ -3780,6 +3789,7 @@ defaultFlags :: Settings -> [GeneralFlag]
defaultFlags settings
-- See Note [Updating flag description in the User's Guide]
= [ Opt_AutoLinkPackages,
Opt_DiagnosticsShowCaret,
Opt_EmbedManifest,
Opt_FlatCache,
Opt_GenManifest,
......
......@@ -35,6 +35,7 @@ module ErrUtils (
-- * Utilities
doIfSet, doIfSet_dyn,
getCaretDiagnostic,
-- * Dump files
dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
......@@ -60,6 +61,8 @@ import Outputable
import Panic
import SrcLoc
import DynFlags
import FastString (unpackFS)
import StringBuffer (hGetStringBuffer, len, lexemeToString)
import System.Directory
import System.Exit ( ExitCode(..), exitWith )
......@@ -74,6 +77,7 @@ import Data.Time
import Control.Monad
import Control.Monad.IO.Class
import System.IO
import System.IO.Error ( catchIOError )
import GHC.Conc ( getAllocationCounter )
import System.CPUTime
......@@ -190,20 +194,99 @@ mkLocMessageAnn ann severity locn msg
-- Add prefixes, like Foo.hs:34: warning:
-- <the warning message>
prefix = locn' <> colon <+>
coloured (colBold `mappend` sevColor) sevText <> optAnn
coloured sevColour sevText <> optAnn
in bold (hang prefix 4 msg)
where
(sevText, sevColor) =
sevColour = colBold `mappend` getSeverityColour severity
sevText =
case severity of
SevWarning -> (text "warning:", colMagentaFg)
SevError -> (text "error:", colRedFg)
SevFatal -> (text "fatal:", colRedFg)
_ -> (empty, mempty)
SevWarning -> text "warning:"
SevError -> text "error:"
SevFatal -> text "fatal:"
_ -> empty
-- Add optional information
optAnn = case ann of
Nothing -> text ""
Just i -> text " [" <> coloured sevColor (text i) <> text "]"
Just i -> text " [" <> coloured sevColour (text i) <> text "]"
getSeverityColour :: Severity -> PprColour
getSeverityColour SevWarning = colMagentaFg
getSeverityColour SevError = colRedFg
getSeverityColour SevFatal = colRedFg
getSeverityColour _ = mempty
getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
getCaretDiagnostic severity (RealSrcSpan span) = do
caretDiagnostic <$> getSrcLine (srcSpanFile span) (row - 1)
where
getSrcLine fn i = do
(getLine i <$> readFile' (unpackFS fn))
`catchIOError` \ _ ->
pure Nothing
getLine i contents =
case drop i (lines contents) of
srcLine : _ -> Just srcLine
[] -> Nothing
readFile' fn = do
-- StringBuffer has advantages over readFile:
-- (a) no lazy IO, otherwise IO exceptions may occur in pure code
-- (b) always UTF-8, rather than some system-dependent encoding
-- (Haskell source code must be UTF-8 anyway)
buf <- hGetStringBuffer fn
pure (fix <$> lexemeToString buf (len buf))
-- allow user to visibly see that their code is incorrectly encoded
-- (StringBuffer.nextChar uses \0 to represent undecodable characters)
fix '\0' = '\xfffd'
fix c = c
sevColour = colBold `mappend` getSeverityColour severity
marginColour = colBold `mappend` colBlueFg
row = srcSpanStartLine span
rowStr = show row
multiline = row /= srcSpanEndLine span
stripNewlines = filter (/= '\n')
caretDiagnostic Nothing = empty
caretDiagnostic (Just srcLineWithNewline) =
coloured marginColour (text marginSpace) <>
text ("\n") <>
coloured marginColour (text marginRow) <>
text (" " ++ srcLinePre) <>
coloured sevColour (text srcLineSpan) <>
text (srcLinePost ++ "\n") <>
coloured marginColour (text marginSpace) <>
coloured sevColour (text (" " ++ caretLine))
where
srcLine = stripNewlines srcLineWithNewline
start = srcSpanStartCol span - 1
end | multiline = length srcLine
| otherwise = srcSpanEndCol span - 1
width = max 1 (end - start)
marginWidth = length rowStr
marginSpace = replicate marginWidth ' ' ++ " |"
marginRow = rowStr ++ " |"
(srcLinePre, srcLineRest) = splitAt start srcLine
(srcLineSpan, srcLinePost) = splitAt width srcLineRest
caretEllipsis | multiline = "..."
| otherwise = ""
caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning reason err = err
......
......@@ -17,3 +17,4 @@ type MsgDoc = SDoc
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
......@@ -800,6 +800,12 @@ messages and in GHCi:
the detection mechanism is not yet implemented, so colors are off by
default on all platforms.)
.. ghc-flag:: -f[no-]diagnostics-show-caret
Controls whether GHC displays a line of the original source code where the
error was detected. This also affects the associated caret symbol that
points at the region of code at fault. The flag is on by default.
.. ghc-flag:: -ferror-spans
Causes GHC to emit the full source span of the syntactic entity
......
......@@ -47,6 +47,7 @@ ifeq "$(MinGhcVersion801)" "YES"
# Turn off any VT800 codes in the output or they wreak havoc on the
# testsuite output.
TEST_HC_OPTS += -fdiagnostics-color=never
TEST_HC_OPTS += -fno-diagnostics-show-caret
endif
# Add the no-debug-output last as it is often convenient to copy the test invocation
......
......@@ -5,6 +5,7 @@ with the following modifiers:
-XNondecreasingIndentation
GHCi-specific dynamic flag settings:
other dynamic, non-language, flag settings:
-fno-diagnostics-show-caret
-fno-ghci-history
-fimplicit-import-qualified
-fshow-warning-groups
......@@ -20,6 +21,7 @@ with the following modifiers:
-XNondecreasingIndentation
GHCi-specific dynamic flag settings:
other dynamic, non-language, flag settings:
-fno-diagnostics-show-caret
-fno-ghci-history
-fimplicit-import-qualified
-fshow-warning-groups
......@@ -34,6 +36,7 @@ with the following modifiers:
-XNondecreasingIndentation
GHCi-specific dynamic flag settings:
other dynamic, non-language, flag settings:
-fno-diagnostics-show-caret
-fno-ghci-history
-fimplicit-import-qualified
-fshow-warning-groups
......@@ -50,6 +53,7 @@ with the following modifiers:
-XNondecreasingIndentation
GHCi-specific dynamic flag settings:
other dynamic, non-language, flag settings:
-fno-diagnostics-show-caret
-fno-ghci-history
-fimplicit-import-qualified
-fshow-warning-groups
......
......@@ -6,6 +6,7 @@ with the following modifiers:
-XNondecreasingIndentation
GHCi-specific dynamic flag settings:
other dynamic, non-language, flag settings:
-fno-diagnostics-show-caret
-fno-ghci-history
-fimplicit-import-qualified
-fshow-warning-groups
......
......@@ -5,6 +5,7 @@ with the following modifiers:
-XNondecreasingIndentation
GHCi-specific dynamic flag settings:
other dynamic, non-language, flag settings:
-fno-diagnostics-show-caret
-fno-ghci-history
-fimplicit-import-qualified
-fshow-warning-groups
......@@ -20,6 +21,7 @@ with the following modifiers:
-XNondecreasingIndentation
GHCi-specific dynamic flag settings:
other dynamic, non-language, flag settings:
-fno-diagnostics-show-caret
-fno-ghci-history
-fimplicit-import-qualified
-fshow-warning-groups
......@@ -34,6 +36,7 @@ with the following modifiers:
-XNondecreasingIndentation
GHCi-specific dynamic flag settings:
other dynamic, non-language, flag settings:
-fno-diagnostics-show-caret
-fno-ghci-history
-fimplicit-import-qualified
-fshow-warning-groups
......@@ -50,6 +53,7 @@ with the following modifiers:
-XNondecreasingIndentation
GHCi-specific dynamic flag settings:
other dynamic, non-language, flag settings:
-fno-diagnostics-show-caret
-fno-ghci-history
-fimplicit-import-qualified
-fshow-warning-groups
......
module CaretDiagnostics1 where
main :: IO ()
main = do
10000000000000000000000000000000000000 +
2 +
(3 :: Int)
pure ("this is not an IO" + ( ))
where
_ = case id of
"γηξ" -> (
) '0'
fóo :: Int
fóo = ()
CaretDiagnostics1.hs:(5,3)-(7,16): error:
• Couldn't match expected type ‘IO a1’ with actual type ‘Int’
• In a stmt of a 'do' block:
10000000000000000000000000000000000000 + 2 + (3 :: Int)
In the expression:
do 10000000000000000000000000000000000000 + 2 + (3 :: Int)
pure ("this is not an IO" + ())
In an equation for ‘main’:
main
= do 10000000000000000000000000000000000000 + 2 + (3 :: Int)
pure ("this is not an IO" + ())
where
_ = case id of { "γηξ" -> () '0' }
|
5 | 10000000000000000000000000000000000000 +
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...
CaretDiagnostics1.hs:8:3-45: error:
• Couldn't match type ‘[Char]’ with ‘()’
Expected type: IO ()
Actual type: IO [Char]
• In a stmt of a 'do' block: pure ("this is not an IO" + ())
In the expression:
do 10000000000000000000000000000000000000 + 2 + (3 :: Int)
pure ("this is not an IO" + ())
In an equation for ‘main’:
main
= do 10000000000000000000000000000000000000 + 2 + (3 :: Int)
pure ("this is not an IO" + ())
where
_ = case id of { "γηξ" -> () '0' }
|
8 | pure ("this is not an IO" + ( ))
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
CaretDiagnostics1.hs:8:31-44: error:
• Couldn't match expected type ‘[Char]’ with actual type ‘()’
• In the second argument of ‘(+)’, namely ‘()’
In the first argument of ‘pure’, namely
‘("this is not an IO" + ())’
In a stmt of a 'do' block: pure ("this is not an IO" + ())
|
8 | pure ("this is not an IO" + ( ))
| ^^^^^^^^^^^^^^
CaretDiagnostics1.hs:13:7-11: error:
• Couldn't match expected type ‘a0 -> a0’ with actual type ‘[Char]’
• In the pattern: "γηξ"
In a case alternative: "γηξ" -> () '0'
In the expression: case id of { "γηξ" -> () '0' }
|
13 | "γηξ" -> (
| ^^^^^
CaretDiagnostics1.hs:(13,16)-(14,13): error:
• Couldn't match expected type ‘Char -> p0’ with actual type ‘()’
• The function ‘()’ is applied to one argument,
but its type ‘()’ has none
In the expression: () '0'
In a case alternative: "γηξ" -> () '0'
|
13 | "γηξ" -> (
| ^...
CaretDiagnostics1.hs:17:7-8: error:
• Couldn't match expected type ‘Int’ with actual type ‘()’
• In the expression: ()
In an equation for ‘fóo’: fóo = ()
|
17 | fóo = ()
| ^^
CaretDiagnostics2.hs:3:1: error:
lexical error (UTF-8 decoding error)
|
3 | �&l��5k�
| ^
test('WerrorFail', normal, compile_fail, [''])
test('CaretDiagnostics1', normal, compile_fail, ['-fdiagnostics-show-caret -ferror-spans'])
test('CaretDiagnostics2', normal, compile_fail, ['-fdiagnostics-show-caret'])
......@@ -68,6 +68,10 @@ verbosityOptions =
, flagDescription = "Use colors in error messages"
, flagType = DynamicFlag
}
, flag { flagName = "-f[no-]diagnostics-show-caret"
, flagDescription = "Whether to show snippets of original source code"
, flagType = DynamicFlag
}
, flag { flagName = "-ferror-spans"
, flagDescription = "Output full span in error messages"
, flagType = DynamicFlag
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment