Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
46c184e1
Commit
46c184e1
authored
Jun 14, 2012
by
Ian Lynagh
Browse files
Change -dppr-user-length from a static to a dynamic flag
parent
0f3d8ab9
Changes
7
Hide whitespace changes
Inline
Side-by-side
compiler/main/DynFlags.hs
View file @
46c184e1
...
...
@@ -611,6 +611,9 @@ data DynFlags = DynFlags {
haddockOptions
::
Maybe
String
,
ghciScripts
::
[
String
],
-- Output style options
pprUserLength
::
Int
,
-- | what kind of {-# SCC #-} to add automatically
profAuto
::
ProfAuto
,
...
...
@@ -967,6 +970,7 @@ defaultDynFlags mySettings =
log_action
=
defaultLogAction
,
flushOut
=
defaultFlushOut
,
flushErr
=
defaultFlushErr
,
pprUserLength
=
5
,
profAuto
=
NoProfAuto
,
llvmVersion
=
panic
"defaultDynFlags: No llvmVersion"
}
...
...
@@ -1609,6 +1613,9 @@ dynamic_flags = [
,
Flag
"I"
(
Prefix
addIncludePath
)
,
Flag
"i"
(
OptPrefix
addImportPath
)
------ Output style options -----------------------------------------
,
Flag
"dppr-user-length"
(
intSuffix
(
\
n
d
->
d
{
pprUserLength
=
n
}))
------ Debugging ----------------------------------------------------
,
Flag
"dstg-stats"
(
NoArg
(
setDynFlag
Opt_StgStats
))
...
...
compiler/main/DynFlags.hs-boot
View file @
46c184e1
...
...
@@ -8,4 +8,5 @@ data DynFlags
tracingDynFlags
::
DynFlags
targetPlatform
::
DynFlags
->
Platform
pprUserLength
::
DynFlags
->
Int
compiler/main/ErrUtils.lhs
View file @
46c184e1
...
...
@@ -146,7 +146,8 @@ printBagOfErrors dflags bag_of_errors
pprErrMsgBag :: Bag ErrMsg -> [SDoc]
pprErrMsgBag bag
= [ let style = mkErrStyle unqual
= [ sdocWithDynFlags $ \dflags ->
let style = mkErrStyle dflags unqual
in withPprStyle style (d $$ e)
| ErrMsg { errMsgShortDoc = d,
errMsgExtraInfo = e,
...
...
@@ -161,13 +162,14 @@ pprLocErrMsg (ErrMsg { errMsgSpans = spans
, errMsgExtraInfo = e
, errMsgSeverity = sev
, errMsgContext = unqual })
= withPprStyle (mkErrStyle unqual) (mkLocMessage sev s (d $$ e))
= sdocWithDynFlags $ \dflags ->
withPprStyle (mkErrStyle dflags unqual) (mkLocMessage sev s (d $$ e))
where
(s : _) = spans -- Should be non-empty
printMsgBag :: DynFlags -> Bag ErrMsg -> IO ()
printMsgBag dflags bag
= sequence_ [ let style = mkErrStyle unqual
= sequence_ [ let style = mkErrStyle
dflags
unqual
in log_action dflags dflags sev s style (d $$ e)
| ErrMsg { errMsgSpans = s:_,
errMsgShortDoc = d,
...
...
@@ -317,13 +319,15 @@ putMsgWith dflags print_unqual msg
sty = mkUserStyle print_unqual AllTheWay
errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg dflags msg = log_action dflags dflags SevError noSrcSpan defaultErrStyle msg
errorMsg dflags msg =
log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
fatalErrorMsg' la dflags msg = la dflags SevFatal noSrcSpan defaultErrStyle msg
fatalErrorMsg' la dflags msg =
la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
...
...
compiler/main/StaticFlags.hs
View file @
46c184e1
...
...
@@ -27,7 +27,6 @@ module StaticFlags (
WayName
(
..
),
Way
(
..
),
v_Ways
,
isRTSWay
,
mkBuildTag
,
-- Output style options
opt_PprUserLength
,
opt_PprCols
,
opt_PprCaseAsLet
,
opt_PprStyle_Debug
,
opt_TraceLevel
,
...
...
@@ -276,9 +275,6 @@ opt_TraceLevel :: Int
opt_TraceLevel
=
lookup_def_int
"-dtrace-level"
1
-- Standard level is 1
-- Less verbose is 0
opt_PprUserLength
::
Int
opt_PprUserLength
=
lookup_def_int
"-dppr-user-length"
5
--ToDo: give this a name
opt_Fuel
::
Int
opt_Fuel
=
lookup_def_int
"-dopt-fuel"
maxBound
...
...
compiler/typecheck/TcRnMonad.lhs
View file @
46c184e1
...
...
@@ -1226,7 +1226,7 @@ failIfM msg
= do { env <- getLclEnv
; let full_msg = (if_loc env <> colon) $$ nest 2 msg
; dflags <- getDynFlags
; liftIO (log_action dflags dflags SevFatal noSrcSpan defaultErrStyle full_msg)
; liftIO (log_action dflags dflags SevFatal noSrcSpan
(
defaultErrStyle
dflags)
full_msg)
; failM }
--------------------
...
...
@@ -1257,7 +1257,7 @@ forkM_maybe doc thing_inside
dflags <- getDynFlags
let msg = hang (text "forkM failed:" <+> doc)
2 (text (show exn))
liftIO $ log_action dflags dflags SevFatal noSrcSpan defaultErrStyle msg
liftIO $ log_action dflags dflags SevFatal noSrcSpan
(
defaultErrStyle
dflags)
msg
; traceIf (text "} ending fork (badly)" <+> doc)
; return Nothing }
...
...
compiler/utils/Outputable.lhs
View file @
46c184e1
...
...
@@ -71,7 +71,8 @@ module Outputable (
pprDebugAndThen,
) where
import {-# SOURCE #-} DynFlags( DynFlags, tracingDynFlags, targetPlatform )
import {-# SOURCE #-} DynFlags( DynFlags, tracingDynFlags,
targetPlatform, pprUserLength )
import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
import {-# SOURCE #-} Name( Name, nameModule )
...
...
@@ -195,16 +196,17 @@ defaultDumpStyle | opt_PprStyle_Debug = PprDebug
| otherwise = PprDump
-- | Style for printing error messages
mkErrStyle :: PrintUnqualified -> PprStyle
mkErrStyle qual = mkUserStyle qual (PartWay
opt_P
prUserLength)
mkErrStyle ::
DynFlags ->
PrintUnqualified -> PprStyle
mkErrStyle
dflags
qual = mkUserStyle qual (PartWay
(p
prUserLength
dflags)
)
defaultErrStyle :: PprStyle
defaultErrStyle ::
DynFlags ->
PprStyle
-- Default style for error messages
-- It's a bit of a hack because it doesn't take into account what's in scope
-- Only used for desugarer warnings, and typechecker errors in interface sigs
defaultErrStyle
| opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
| otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
defaultErrStyle dflags = mkUserStyle alwaysQualify depth
where depth = if opt_PprStyle_Debug
then AllTheWay
else PartWay (pprUserLength dflags)
mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
mkUserStyle unqual depth
...
...
docs/users_guide/flags.xml
View file @
46c184e1
...
...
@@ -2712,7 +2712,7 @@
<row>
<entry><option>
-dppr-user-length
</option></entry>
<entry>
Set the depth for printing expressions in error msgs
</entry>
<entry>
stat
ic
</entry>
<entry>
dynam
ic
</entry>
<entry>
-
</entry>
</row>
<row>
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment