<commit_before>%
% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[ErrsUtils]{Utilities for error reporting}

\begin{code}
module ErrUtils (
	Message, mkLocMessage, printError,
	Severity(..),

	ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
	errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
	Messages, errorsFound, emptyMessages,
	mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
    handleFlagWarnings,

	ghcExit,
	doIfSet, doIfSet_dyn, 
	dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
        mkDumpDoc, dumpSDoc,

	--  * Messages during compilation
	putMsg,
	errorMsg,
	fatalErrorMsg,
	compilationProgressMsg,
	showPass,
	debugTraceMsg,	
    ) where

#include "HsVersions.h"

import Bag		( Bag, bagToList, isEmptyBag, emptyBag )
import SrcLoc		( SrcSpan )
import Util		( sortLe )
import Outputable
import SrcLoc		( srcSpanStart, noSrcSpan )
import DynFlags		( DynFlags(..), DynFlag(..), dopt )
import StaticFlags	( opt_ErrorSpans )

import Control.Monad
import System.Exit	( ExitCode(..), exitWith )
import Data.Dynamic
import Data.List
import System.IO
import Exception

-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.

type Message = SDoc

data Severity
  = SevInfo
  | SevWarning
  | SevError
  | SevFatal

mkLocMessage :: SrcSpan -> Message -> Message
mkLocMessage locn msg
  | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg
  | otherwise      = hang (ppr (srcSpanStart locn) <> colon) 4 msg
  -- always print the location, even if it is unhelpful.  Error messages
  -- are supposed to be in a standard format, and one without a location
  -- would look strange.  Better to say explicitly "<no location info>".

printError :: SrcSpan -> Message -> IO ()
printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)


-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.

data ErrMsg = ErrMsg { 
	errMsgSpans     :: [SrcSpan],
	errMsgContext   :: PrintUnqualified,
	errMsgShortDoc  :: Message,
	errMsgExtraInfo :: Message
	}
	-- The SrcSpan is used for sorting errors into line-number order
	-- NB  Pretty.Doc not SDoc: we deal with the printing style (in ptic 
	-- whether to qualify an External Name) at the error occurrence

#if __GLASGOW_HASKELL__ >= 609
instance Exception ErrMsg
#endif

instance Show ErrMsg where
    show em = showSDoc (errMsgShortDoc em)

throwErrMsg :: ErrMsg -> a
#if __GLASGOW_HASKELL__ < 609
throwErrMsg = throwDyn
#else
throwErrMsg = throw
#endif

handleErrMsg :: (ErrMsg -> IO a) -> IO a -> IO a
#if __GLASGOW_HASKELL__ < 609
handleErrMsg = flip catchDyn
#else
handleErrMsg = handle
#endif

-- So we can throw these things as exceptions
errMsgTc :: TyCon
errMsgTc = mkTyCon "ErrMsg"
{-# NOINLINE errMsgTc #-}
instance Typeable ErrMsg where
  typeOf _ = mkTyConApp errMsgTc []

type WarnMsg = ErrMsg

-- A short (one-line) error message, with context to tell us whether
-- to qualify names in the message or not.
mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg
mkErrMsg locn print_unqual msg
  = ErrMsg [locn] print_unqual msg empty

-- Variant that doesn't care about qualified/unqualified names
mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg
mkPlainErrMsg locn msg
  = ErrMsg [locn] alwaysQualify msg empty

-- A long (multi-line) error message, with context to tell us whether
-- to qualify names in the message or not.
mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
mkLongErrMsg locn print_unqual msg extra 
 = ErrMsg [locn] print_unqual msg extra

mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
mkWarnMsg = mkErrMsg

type Messages = (Bag WarnMsg, Bag ErrMsg)

emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)

errorsFound :: DynFlags -> Messages -> Bool
-- The dyn-flags are used to see if the user has specified
-- -Werror, which says that warnings should be fatal
errorsFound dflags (warns, errs) 
  | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
  | otherwise  		        = not (isEmptyBag errs)

printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
printErrorsAndWarnings dflags (warns, errs)
  | no_errs && no_warns = return ()
  | no_errs             = do printBagOfWarnings dflags warns
                             when (dopt Opt_WarnIsError dflags) $
                                 errorMsg dflags $
                                     text "\nFailing due to -Werror.\n"
                          -- Don't print any warnings if there are errors
  | otherwise           = printBagOfErrors dflags errs
  where<commit_msg>Expand ErrUtils api with another plain variant<commit_after>%
% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[ErrsUtils]{Utilities for error reporting}

\begin{code}
module ErrUtils (
	Message, mkLocMessage, printError,
	Severity(..),

	ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
	errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
	Messages, errorsFound, emptyMessages,
	mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
    handleFlagWarnings,

	ghcExit,
	doIfSet, doIfSet_dyn, 
	dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
        mkDumpDoc, dumpSDoc,

	--  * Messages during compilation
	putMsg,
	errorMsg,
	fatalErrorMsg,
	compilationProgressMsg,
	showPass,
	debugTraceMsg,	
    ) where

#include "HsVersions.h"

import Bag		( Bag, bagToList, isEmptyBag, emptyBag )
import SrcLoc		( SrcSpan )
import Util		( sortLe )
import Outputable
import SrcLoc		( srcSpanStart, noSrcSpan )
import DynFlags		( DynFlags(..), DynFlag(..), dopt )
import StaticFlags	( opt_ErrorSpans )

import Control.Monad
import System.Exit	( ExitCode(..), exitWith )
import Data.Dynamic
import Data.List
import System.IO
import Exception

-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.

type Message = SDoc

data Severity
  = SevInfo
  | SevWarning
  | SevError
  | SevFatal

mkLocMessage :: SrcSpan -> Message -> Message
mkLocMessage locn msg
  | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg
  | otherwise      = hang (ppr (srcSpanStart locn) <> colon) 4 msg
  -- always print the location, even if it is unhelpful.  Error messages
  -- are supposed to be in a standard format, and one without a location
  -- would look strange.  Better to say explicitly "<no location info>".

printError :: SrcSpan -> Message -> IO ()
printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)


-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.

data ErrMsg = ErrMsg { 
	errMsgSpans     :: [SrcSpan],
	errMsgContext   :: PrintUnqualified,
	errMsgShortDoc  :: Message,
	errMsgExtraInfo :: Message
	}
	-- The SrcSpan is used for sorting errors into line-number order
	-- NB  Pretty.Doc not SDoc: we deal with the printing style (in ptic 
	-- whether to qualify an External Name) at the error occurrence

#if __GLASGOW_HASKELL__ >= 609
instance Exception ErrMsg
#endif

instance Show ErrMsg where
    show em = showSDoc (errMsgShortDoc em)

throwErrMsg :: ErrMsg -> a
#if __GLASGOW_HASKELL__ < 609
throwErrMsg = throwDyn
#else
throwErrMsg = throw
#endif

handleErrMsg :: (ErrMsg -> IO a) -> IO a -> IO a
#if __GLASGOW_HASKELL__ < 609
handleErrMsg = flip catchDyn
#else
handleErrMsg = handle
#endif

-- So we can throw these things as exceptions
errMsgTc :: TyCon
errMsgTc = mkTyCon "ErrMsg"
{-# NOINLINE errMsgTc #-}
instance Typeable ErrMsg where
  typeOf _ = mkTyConApp errMsgTc []

type WarnMsg = ErrMsg

-- A short (one-line) error message, with context to tell us whether
-- to qualify names in the message or not.
mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg
mkErrMsg locn print_unqual msg
  = ErrMsg [locn] print_unqual msg empty

-- Variant that doesn't care about qualified/unqualified names
mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg
mkPlainErrMsg locn msg
  = ErrMsg [locn] alwaysQualify msg empty

-- A long (multi-line) error message, with context to tell us whether
-- to qualify names in the message or not.
mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
mkLongErrMsg locn print_unqual msg extra 
 = ErrMsg [locn] print_unqual msg extra

mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
mkWarnMsg = mkErrMsg

-- Variant that doesn't care about qualified/unqualified names
mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg
mkPlainWarnMsg locn msg = mkWarnMsg locn alwaysQualify msg

type Messages = (Bag WarnMsg, Bag ErrMsg)

emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)

errorsFound :: DynFlags -> Messages -> Bool
-- The dyn-flags are used to see if the user has specified
-- -Werror, which says that warnings should be fatal
errorsFound dflags (warns, errs) 
  | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
  | otherwise  		        = not (isEmptyBag errs)

printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
printErrorsAndWarnings dflags (warns, errs)
  | no_errs && no_warns = return ()
  | no_errs             = do printBagOfWarnings dflags warns
                             when (dopt Opt_WarnIsError dflags) $
                                 errorMsg dflags $
                                     text "\nFailing due to -Werror.\n"
                          -- Don't print any warnings if there are errors
  | otherwise           = printBagOfErrors dflags errs
  where
{'fraction_non_alphanumeric': 0.1110771425659839, 'fraction_numerical': 0.003872414144502191, 'mean_word_length': 3.0942845223195663, 'pattern_counts': {'":': 0, '<': 13, '<?xml version=': 0, '>': 61, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 6, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7429819', 'n_tokens_mistral': 3070, 'n_tokens_neox': 2986, 'n_words': 1014}