Commit 83c93c10 authored by Edward Z. Yang's avatar Edward Z. Yang

Add support for extended verbosity specification -v"debug +callsite"

This patch uses CallStack support in GHC 7.10 and GHC 8.0 to make
it possible to get stack traces when we log output.

This is the bare minimum to make this patch useful: there is
plenty of tuning that can be done.  For example:

* Insertions of withFrozenCallStack can help make the "callsite" output
  more useful, though be careful, we lose all stack information at that point!

* Insertions of 'WithVerbosity', which will let us get deeper stacks
  (at the moment, they are basically always 1-deep.)

Fixes #3768.

CC @23SkidooSigned-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent c171c78f
...@@ -313,6 +313,7 @@ library ...@@ -313,6 +313,7 @@ library
Distribution.Compat.Internal.TempFile Distribution.Compat.Internal.TempFile
Distribution.Compat.ReadP Distribution.Compat.ReadP
Distribution.Compat.Semigroup Distribution.Compat.Semigroup
Distribution.Compat.Stack
Distribution.Compat.Time Distribution.Compat.Time
Distribution.Compiler Distribution.Compiler
Distribution.InstalledPackageInfo Distribution.InstalledPackageInfo
......
...@@ -37,6 +37,7 @@ module Distribution.Compat.ReadP ...@@ -37,6 +37,7 @@ module Distribution.Compat.ReadP
-- * Other operations -- * Other operations
pfail, -- :: ReadP a pfail, -- :: ReadP a
eof, -- :: ReadP ()
satisfy, -- :: (Char -> Bool) -> ReadP Char satisfy, -- :: (Char -> Bool) -> ReadP Char
char, -- :: Char -> ReadP Char char, -- :: Char -> ReadP Char
string, -- :: String -> ReadP String string, -- :: String -> ReadP String
...@@ -204,6 +205,12 @@ pfail :: ReadP r a ...@@ -204,6 +205,12 @@ pfail :: ReadP r a
-- ^ Always fails. -- ^ Always fails.
pfail = R (const Fail) pfail = R (const Fail)
eof :: ReadP r ()
-- ^ Succeeds iff we are at the end of input
eof = do { s <- look
; if null s then return ()
else pfail }
(+++) :: ReadP r a -> ReadP r a -> ReadP r a (+++) :: ReadP r a -> ReadP r a -> ReadP r a
-- ^ Symmetric choice. -- ^ Symmetric choice.
R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ImplicitParams #-}
module Distribution.Compat.Stack (
WithCallStack,
CallStack,
withFrozenCallStack,
callStack,
prettyCallStack,
parentSrcLocPrefix
) where
#ifdef MIN_VERSION_base
#if MIN_VERSION_base(4,8,1)
#define GHC_STACK_SUPPORTED 1
#endif
#endif
#ifdef GHC_STACK_SUPPORTED
import GHC.Stack
#endif
#ifdef GHC_STACK_SUPPORTED
#if MIN_VERSION_base(4,9,0)
type WithCallStack a = HasCallStack => a
#elif MIN_VERSION_base(4,8,1)
type WithCallStack a = (?loc :: CallStack) => a
#endif
#if !MIN_VERSION_base(4,9,0)
-- NB: Can't say WithCallStack (WithCallStack a -> a);
-- Haskell doesn't support this kind of implicit parameter!
-- See https://mail.haskell.org/pipermail/ghc-devs/2016-January/011096.html
-- Since this function doesn't do anything, it's OK to
-- give it a less good type.
withFrozenCallStack :: WithCallStack (a -> a)
withFrozenCallStack x = x
callStack :: (?loc :: CallStack) => CallStack
callStack = ?loc
prettyCallStack :: CallStack -> String
prettyCallStack = showCallStack
#endif
-- | Give the *parent* of the person who invoked this;
-- so it's most suitable for being called from a utility function.
-- You probably want to call this using 'withFrozenCallStack'; otherwise
-- it's not very useful. We didn't implement this for base-4.8.1
-- because we cannot rely on freezing to have taken place.
--
parentSrcLocPrefix :: WithCallStack String
#if MIN_VERSION_base(4,9,0)
parentSrcLocPrefix =
case getCallStack callStack of
(_:(_, loc):_) -> showLoc loc
[(_, loc)] -> showLoc loc
[] -> error "parentSrcLocPrefix: empty call stack"
where
showLoc loc =
srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": "
#else
parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "
#endif
#else
data CallStack = CallStack
deriving (Eq, Show)
type WithCallStack a = a
withFrozenCallStack :: a -> a
withFrozenCallStack x = x
callStack :: CallStack
callStack = CallStack
prettyCallStack :: CallStack -> String
prettyCallStack _ = "Call stacks not available with base < 4.8.1.0 (GHC 7.10)"
parentSrcLocPrefix :: String
parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "
#endif
This diff is collapsed.
...@@ -9,9 +9,17 @@ ...@@ -9,9 +9,17 @@
-- Maintainer : cabal-devel@haskell.org -- Maintainer : cabal-devel@haskell.org
-- Portability : portable -- Portability : portable
-- --
-- A simple 'Verbosity' type with associated utilities. There are 4 standard -- A 'Verbosity' type with associated utilities.
-- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This --
-- is used for deciding what logging messages to print. -- There are 4 standard verbosity levels from 'silent', 'normal',
-- 'verbose' up to 'deafening'. This is used for deciding what logging
-- messages to print.
--
-- Verbosity also is equipped with some internal settings which can be
-- used to control at a fine granularity the verbosity of specific
-- settings (e.g., so that you can trace only particular things you
-- are interested in.) It's important to note that the instances
-- for 'Verbosity' assume that this does not exist.
-- Verbosity for Cabal functions. -- Verbosity for Cabal functions.
...@@ -21,65 +29,126 @@ module Distribution.Verbosity ( ...@@ -21,65 +29,126 @@ module Distribution.Verbosity (
silent, normal, verbose, deafening, silent, normal, verbose, deafening,
moreVerbose, lessVerbose, moreVerbose, lessVerbose,
intToVerbosity, flagToVerbosity, intToVerbosity, flagToVerbosity,
showForCabal, showForGHC showForCabal, showForGHC,
-- * Call stacks
verboseCallSite, verboseCallStack,
isVerboseCallSite, isVerboseCallStack,
) where ) where
import Prelude () import Prelude ()
import Distribution.Compat.Prelude import Distribution.Compat.Prelude
import Distribution.ReadE import Distribution.ReadE
import Distribution.Compat.ReadP
import Data.List (elemIndex) import Data.List (elemIndex)
data Verbosity = Silent | Normal | Verbose | Deafening data Verbosity = Verbosity {
deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) vLevel :: VerbosityLevel,
vCallStack :: CallStackLevel
} deriving (Generic)
mkVerbosity :: VerbosityLevel -> Verbosity
mkVerbosity l = Verbosity { vLevel = l, vCallStack = NoStack }
instance Show Verbosity where
showsPrec n = showsPrec n . vLevel
instance Read Verbosity where
readsPrec n s = map (\(x,y) -> (mkVerbosity x,y)) (readsPrec n s)
instance Eq Verbosity where
x == y = vLevel x == vLevel y
instance Ord Verbosity where
compare x y = compare (vLevel x) (vLevel y)
instance Enum Verbosity where
toEnum = mkVerbosity . toEnum
fromEnum = fromEnum . vLevel
instance Bounded Verbosity where
minBound = mkVerbosity minBound
maxBound = mkVerbosity maxBound
instance Binary Verbosity instance Binary Verbosity
data VerbosityLevel = Silent | Normal | Verbose | Deafening
deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)
instance Binary VerbosityLevel
-- We shouldn't print /anything/ unless an error occurs in silent mode -- We shouldn't print /anything/ unless an error occurs in silent mode
silent :: Verbosity silent :: Verbosity
silent = Silent silent = mkVerbosity Silent
-- Print stuff we want to see by default -- Print stuff we want to see by default
normal :: Verbosity normal :: Verbosity
normal = Normal normal = mkVerbosity Normal
-- Be more verbose about what's going on -- Be more verbose about what's going on
verbose :: Verbosity verbose :: Verbosity
verbose = Verbose verbose = mkVerbosity Verbose
-- Not only are we verbose ourselves (perhaps even noisier than when -- Not only are we verbose ourselves (perhaps even noisier than when
-- being "verbose"), but we tell everything we run to be verbose too -- being "verbose"), but we tell everything we run to be verbose too
deafening :: Verbosity deafening :: Verbosity
deafening = Deafening deafening = mkVerbosity Deafening
moreVerbose :: Verbosity -> Verbosity moreVerbose :: Verbosity -> Verbosity
moreVerbose Silent = Silent --silent should stay silent moreVerbose v =
moreVerbose Normal = Verbose case vLevel v of
moreVerbose Verbose = Deafening Silent -> v -- silent should stay silent
moreVerbose Deafening = Deafening Normal -> v { vLevel = Verbose }
Verbose -> v { vLevel = Deafening }
Deafening -> v
lessVerbose :: Verbosity -> Verbosity lessVerbose :: Verbosity -> Verbosity
lessVerbose Deafening = Deafening lessVerbose v =
lessVerbose Verbose = Normal case vLevel v of
lessVerbose Normal = Silent Deafening -> v -- deafening stays deafening
lessVerbose Silent = Silent Verbose -> v { vLevel = Normal }
Normal -> v { vLevel = Silent }
Silent -> v
intToVerbosity :: Int -> Maybe Verbosity intToVerbosity :: Int -> Maybe Verbosity
intToVerbosity 0 = Just Silent intToVerbosity 0 = Just (mkVerbosity Silent)
intToVerbosity 1 = Just Normal intToVerbosity 1 = Just (mkVerbosity Normal)
intToVerbosity 2 = Just Verbose intToVerbosity 2 = Just (mkVerbosity Verbose)
intToVerbosity 3 = Just Deafening intToVerbosity 3 = Just (mkVerbosity Deafening)
intToVerbosity _ = Nothing intToVerbosity _ = Nothing
parseVerbosity :: ReadP r (Either Int Verbosity)
parseVerbosity = parseIntVerbosity <++ parseStringVerbosity
where
parseIntVerbosity = fmap Left (readS_to_P reads)
parseStringVerbosity = fmap Right $ do
level <- parseVerbosityLevel
_ <- skipSpaces
extras <- sepBy parseExtra skipSpaces
return (foldr (.) id extras (mkVerbosity level))
parseVerbosityLevel = choice
[ string "silent" >> return Silent
, string "normal" >> return Normal
, string "verbose" >> return Verbose
, string "debug" >> return Deafening
, string "deafening" >> return Deafening
]
parseExtra = char '+' >> choice
[ string "callsite" >> return verboseCallSite
, string "callstack" >> return verboseCallStack
]
flagToVerbosity :: ReadE Verbosity flagToVerbosity :: ReadE Verbosity
flagToVerbosity = ReadE $ \s -> flagToVerbosity = ReadE $ \s ->
case reads s of case readP_to_S (parseVerbosity >>= \r -> eof >> return r) s of
[(i, "")] -> [(Left i, "")] ->
case intToVerbosity i of case intToVerbosity i of
Just v -> Right v Just v -> Right v
Nothing -> Left ("Bad verbosity: " ++ show i ++ Nothing -> Left ("Bad verbosity: " ++ show i ++
". Valid values are 0..3") ". Valid values are 0..3")
[(Right v, "")] -> Right v
_ -> Left ("Can't parse verbosity " ++ s) _ -> Left ("Can't parse verbosity " ++ s)
showForCabal, showForGHC :: Verbosity -> String showForCabal, showForGHC :: Verbosity -> String
...@@ -89,3 +158,24 @@ showForCabal v = maybe (error "unknown verbosity") show $ ...@@ -89,3 +158,24 @@ showForCabal v = maybe (error "unknown verbosity") show $
showForGHC v = maybe (error "unknown verbosity") show $ showForGHC v = maybe (error "unknown verbosity") show $
elemIndex v [silent,normal,__,verbose,deafening] elemIndex v [silent,normal,__,verbose,deafening]
where __ = silent -- this will be always ignored by elemIndex where __ = silent -- this will be always ignored by elemIndex
data CallStackLevel = NoStack | TopStackFrame | FullStack
deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)
instance Binary CallStackLevel
-- | Turn on verbose call-site printing when we log. Overrides 'verboseCallStack'.
verboseCallSite :: Verbosity -> Verbosity
verboseCallSite v = v { vCallStack = TopStackFrame }
-- | Turn on verbose call-stack printing when we log. Overrides 'verboseCallSite'.
verboseCallStack :: Verbosity -> Verbosity
verboseCallStack v = v { vCallStack = FullStack }
-- | Test if we should output call sites when we log.
isVerboseCallSite :: Verbosity -> Bool
isVerboseCallSite = (== TopStackFrame) . vCallStack
-- | Test if we should output call stacks when we log.
isVerboseCallStack :: Verbosity -> Bool
isVerboseCallStack = (== FullStack) . vCallStack
...@@ -77,6 +77,14 @@ ...@@ -77,6 +77,14 @@
'GHCJS_PACKAGE_PATH', lifting the restriction that they be unset. 'GHCJS_PACKAGE_PATH', lifting the restriction that they be unset.
(#3728,#2711). (#3728,#2711).
* Add support for new caret-style version range operator `^>=` (#3705) * Add support for new caret-style version range operator `^>=` (#3705)
* Verbosity `-v` now takes an extended format which allows
specifying exactly what you want to be logged. The format is
"[silent|normal|verbose|debug] flags", where flags is a space
separated list of flags. At the moment, only the flags
+callsite and +callstack are supported; these report the
call site/stack of a logging output respectively (these
are only supported if Cabal is built with GHC 8.0/7.10.2
or greater, respectively).
1.24.0.0 Ryan Thomas <ryan@ryant.org> March 2016 1.24.0.0 Ryan Thomas <ryan@ryant.org> March 2016
* Support GHC 8. * Support GHC 8.
......
...@@ -409,6 +409,15 @@ The following options are understood by all commands: ...@@ -409,6 +409,15 @@ The following options are understood by all commands:
Set the verbosity level (0-3). The normal level is 1; a missing *n* Set the verbosity level (0-3). The normal level is 1; a missing *n*
defaults to 2. defaults to 2.
There is also an extended version of this command which can be
used to fine-tune the verbosity of output. It takes the
form ``[silent|normal|verbose|debug]``\ *flags*, where *flags*
is a list of ``+`` flags which toggle various aspects of
output. At the moment, only ``+callsite`` and ``+callstack``
are supported, which respectively toggle call site and call
stack printing (these are only supported if Cabal
is built with a sufficiently recent GHC.)
The various commands and the additional options they support are The various commands and the additional options they support are
described below. In the simple build infrastructure, any other options described below. In the simple build infrastructure, any other options
will be reported as errors. will be reported as errors.
......
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