Commit 39a2faa0 authored by Dave Laing's avatar Dave Laing Committed by Ben Gamari
Browse files

Rework parser to allow use with DynFlags

Split out the options needed by the parser from DynFlags, making the
parser more friendly to standalone usage.

Test Plan: validate

Reviewers: simonmar, alanz, bgamari, austin, thomie

Reviewed By: simonmar, alanz, bgamari, thomie

Subscribers: thomie, mpickering

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

GHC Trac Issues: #10961
parent ba3e1fd3
......@@ -25,6 +25,7 @@ module CmmLex (
import CmmExpr
import Lexer
import CmmMonad
import SrcLoc
import UniqFM
import StringBuffer
......@@ -182,13 +183,13 @@ data CmmToken
-- -----------------------------------------------------------------------------
-- Lexer actions
type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated CmmToken)
type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken)
begin :: Int -> Action
begin code _span _str _len = do pushLexState code; lexToken
begin code _span _str _len = do liftP (pushLexState code); lexToken
pop :: Action
pop _span _buf _len = popLexState >> lexToken
pop _span _buf _len = liftP popLexState >> lexToken
special_char :: Action
special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))
......@@ -286,45 +287,47 @@ tok_string str = CmmT_String (read str)
setLine :: Int -> Action
setLine code span buf len = do
let line = parseUnsignedInteger buf len 10 octDecDigit
setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
-- subtract one: the line number refers to the *following* line
-- trace ("setLine " ++ show line) $ do
popLexState >> pushLexState code
liftP $ do
setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
-- subtract one: the line number refers to the *following* line
-- trace ("setLine " ++ show line) $ do
popLexState >> pushLexState code
lexToken
setFile :: Int -> Action
setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
popLexState >> pushLexState code
liftP $ do
setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
popLexState >> pushLexState code
lexToken
-- -----------------------------------------------------------------------------
-- This is the top-level function: called from the parser each time a
-- new token is to be read from the input.
cmmlex :: (Located CmmToken -> P a) -> P a
cmmlex :: (Located CmmToken -> PD a) -> PD a
cmmlex cont = do
(L span tok) <- lexToken
--trace ("token: " ++ show tok) $ do
cont (L (RealSrcSpan span) tok)
lexToken :: P (RealLocated CmmToken)
lexToken :: PD (RealLocated CmmToken)
lexToken = do
inp@(loc1,buf) <- getInput
sc <- getLexState
sc <- liftP getLexState
case alexScan inp sc of
AlexEOF -> do let span = mkRealSrcSpan loc1 loc1
setLastToken span 0
liftP (setLastToken span 0)
return (L span CmmT_EOF)
AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error"
AlexSkip inp2 _ -> do
setInput inp2
lexToken
AlexToken inp2@(end,_buf2) len t -> do
setInput inp2
let span = mkRealSrcSpan loc1 end
span `seq` setLastToken span len
span `seq` liftP (setLastToken span len)
t span buf len
-- -----------------------------------------------------------------------------
......@@ -352,9 +355,9 @@ alexGetByte (loc,s)
loc' = advanceSrcLoc loc c
s' = stepOn s
getInput :: P AlexInput
getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b)
getInput :: PD AlexInput
getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b)
setInput :: AlexInput -> P ()
setInput (l,b) = P $ \s -> POk s{ loc=l, buffer=b } ()
setInput :: AlexInput -> PD ()
setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } ()
}
-----------------------------------------------------------------------------
-- A Parser monad with access to the 'DynFlags'.
--
-- The 'P' monad only has access to the subset of of 'DynFlags'
-- required for parsing Haskell.
-- The parser for C-- requires access to a lot more of the 'DynFlags',
-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.
-----------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module CmmMonad (
PD(..)
, liftP
) where
import Control.Monad
#if __GLASGOW_HASKELL__ > 710
import qualified Control.Monad.Fail as MonadFail
#endif
import DynFlags
import Lexer
newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }
instance Functor PD where
fmap = liftM
instance Applicative PD where
pure = returnPD
(<*>) = ap
instance Monad PD where
(>>=) = thenPD
fail = failPD
#if __GLASGOW_HASKELL__ > 710
instance MonadFail.MonadFail PD where
fail = failPD
#endif
liftP :: P a -> PD a
liftP (P f) = PD $ \_ s -> f s
returnPD :: a -> PD a
returnPD = liftP . return
thenPD :: PD a -> (a -> PD b) -> PD b
(PD m) `thenPD` k = PD $ \d s ->
case m d s of
POk s1 a -> unPD (k a) d s1
PFailed span err -> PFailed span err
failPD :: String -> PD a
failPD = liftP . fail
instance HasDynFlags PD where
getDynFlags = PD $ \d s -> POk s d
......@@ -228,6 +228,7 @@ import CmmLex
import CLabel
import SMRep
import Lexer
import CmmMonad
import CostCentre
import ForeignCall
......@@ -339,7 +340,7 @@ import qualified Data.Map as M
INT { L _ (CmmT_Int $$) }
FLOAT { L _ (CmmT_Float $$) }
%monad { P } { >>= } { return }
%monad { PD } { >>= } { return }
%lexer { cmmlex } { L _ CmmT_EOF }
%name cmmParse cmm
%tokentype { Located CmmToken }
......@@ -368,7 +369,7 @@ cmmtop :: { CmmParse () }
| cmmdata { $1 }
| decl { $1 }
| 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
{% withThisPackage $ \pkg ->
{% liftP . withThisPackage $ \pkg ->
do lits <- sequence $6;
staticClosure pkg $3 $5 (map getLit lits) }
......@@ -389,7 +390,7 @@ cmmdata :: { CmmParse () }
data_label :: { CmmParse CLabel }
: NAME ':'
{% withThisPackage $ \pkg ->
{% liftP . withThisPackage $ \pkg ->
return (mkCmmDataLabel pkg $1) }
statics :: { [CmmParse [CmmStatic]] }
......@@ -448,14 +449,14 @@ maybe_body :: { CmmParse () }
info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
: NAME
{% withThisPackage $ \pkg ->
{% liftP . withThisPackage $ \pkg ->
do newFunctionName $1 pkg
return (mkCmmCodeLabel pkg $1, Nothing, []) }
| 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type
{% withThisPackage $ \pkg ->
{% liftP . withThisPackage $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13
rep = mkRTSRep (fromIntegral $9) $
......@@ -471,7 +472,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type
{% withThisPackage $ \pkg ->
{% liftP . withThisPackage $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13
ty = Fun 0 (ArgSpec (fromIntegral $15))
......@@ -489,7 +490,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, tag, closure type, description, type
{% withThisPackage $ \pkg ->
{% liftP . withThisPackage $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $13 $15
ty = Constr (fromIntegral $9) -- Tag
......@@ -508,7 +509,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type
{% withThisPackage $ \pkg ->
{% liftP . withThisPackage $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $9 $11
ty = ThunkSelector (fromIntegral $5)
......@@ -522,7 +523,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
-- closure type (no live regs)
{% withThisPackage $ \pkg ->
{% liftP . withThisPackage $ \pkg ->
do let prof = NoProfilingInfo
rep = mkRTSRep (fromIntegral $5) $ mkStackRep []
return (mkCmmRetLabel pkg $3,
......@@ -533,7 +534,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
-- closure type, live regs
{% withThisPackage $ \pkg ->
{% liftP . withThisPackage $ \pkg ->
do dflags <- getDynFlags
live <- sequence $7
let prof = NoProfilingInfo
......@@ -871,13 +872,13 @@ getLit (CmmLit l) = l
getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r
getLit _ = panic "invalid literal" -- TODO messy failure
nameToMachOp :: FastString -> P (Width -> MachOp)
nameToMachOp :: FastString -> PD (Width -> MachOp)
nameToMachOp name =
case lookupUFM machOps name of
Nothing -> fail ("unknown primitive " ++ unpackFS name)
Just m -> return m
exprOp :: FastString -> [CmmParse CmmExpr] -> P (CmmParse CmmExpr)
exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
exprOp name args_code = do
dflags <- getDynFlags
case lookupUFM (exprMacros dflags) name of
......@@ -1007,13 +1008,13 @@ callishMachOps = listToUFM $
-- in the MO_* constructor. In order to do this, however, we
-- must intercept the arguments in primCall.
parseSafety :: String -> P Safety
parseSafety :: String -> PD Safety
parseSafety "safe" = return PlaySafe
parseSafety "unsafe" = return PlayRisky
parseSafety "interruptible" = return PlayInterruptible
parseSafety str = fail ("unrecognised safety: " ++ str)
parseCmmHint :: String -> P ForeignHint
parseCmmHint :: String -> PD ForeignHint
parseCmmHint "ptr" = return AddrHint
parseCmmHint "signed" = return SignedHint
parseCmmHint str = fail ("unrecognised hint: " ++ str)
......@@ -1034,13 +1035,13 @@ isPtrGlobalReg CurrentNursery = True
isPtrGlobalReg (VanillaReg _ VGcPtr) = True
isPtrGlobalReg _ = False
happyError :: P a
happyError = srcParseFail
happyError :: PD a
happyError = PD $ \_ s -> unP srcParseFail s
-- -----------------------------------------------------------------------------
-- Statement-level macros
stmtMacro :: FastString -> [CmmParse CmmExpr] -> P (CmmParse ())
stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
stmtMacro fun args_code = do
case lookupUFM stmtMacros fun of
Nothing -> fail ("unknown macro: " ++ unpackFS fun)
......@@ -1140,7 +1141,7 @@ foreignCall
-> [CmmParse (CmmExpr, ForeignHint)]
-> Safety
-> CmmReturnInfo
-> P (CmmParse ())
-> PD (CmmParse ())
foreignCall conv_string results_code expr_code args_code safety ret
= do conv <- case conv_string of
"C" -> return CCallConv
......@@ -1218,7 +1219,7 @@ primCall
:: [CmmParse (CmmFormal, ForeignHint)]
-> FastString
-> [CmmParse CmmExpr]
-> P (CmmParse ())
-> PD (CmmParse ())
primCall results_code name args_code
= case lookupUFM callishMachOps name of
Nothing -> fail ("unknown primitive " ++ unpackFS name)
......@@ -1382,7 +1383,7 @@ parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brack
init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
-- reset the lex_state: the Lexer monad leaves some stuff
-- in there we don't want.
case unP cmmParse init_state of
case unPD cmmParse dflags init_state of
PFailed span err -> do
let msg = mkPlainErrMsg dflags span err
return ((emptyBag, unitBag msg), Nothing)
......@@ -1390,7 +1391,7 @@ parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brack
st <- initC
let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
(cmm,_) = runC dflags no_module st fcode
let ms = getMessages pst
let ms = getMessages pst dflags
if (errorsFound dflags ms)
then return (ms, Nothing)
else do
......
......@@ -213,6 +213,7 @@ Library
CmmLint
CmmLive
CmmMachOp
CmmMonad
CmmSwitch
CmmNode
CmmOpt
......
......@@ -1495,5 +1495,5 @@ parser str dflags filename =
Left (unitBag (mkPlainErrMsg dflags span err))
POk pst rdr_module ->
let (warns,_) = getMessages pst in
let (warns,_) = getMessages pst dflags in
Right (warns, rdr_module)
......@@ -65,7 +65,7 @@ getImports dflags buf filename source_filename = do
case unP parseHeader (mkPState dflags buf loc) of
PFailed span err -> parseError dflags span err
POk pst rdr_module -> do
let _ms@(_warns, errs) = getMessages pst
let _ms@(_warns, errs) = getMessages pst dflags
-- don't log warnings: they'll be reported when we parse the file
-- for real. See #2500.
ms = (emptyBag, errs)
......
......@@ -361,7 +361,7 @@ hscParse' mod_summary = {-# SCC "Parser" #-}
liftIO $ throwOneError (mkPlainErrMsg dflags span err)
POk pst rdr_module -> do
logWarningsReportErrors (getMessages pst)
logWarningsReportErrors (getMessages pst dflags)
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
ppr rdr_module
liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
......@@ -1674,7 +1674,7 @@ hscParseThingWithLocation source linenumber parser str
throwErrors $ unitBag msg
POk pst thing -> do
logWarningsReportErrors (getMessages pst)
logWarningsReportErrors (getMessages pst dflags)
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
return thing
......
......@@ -53,9 +53,9 @@
{-# OPTIONS_GHC -funbox-strict-fields #-}
module Lexer (
Token(..), lexer, pragState, mkPState, PState(..),
P(..), ParseResult(..), getSrcLoc,
getPState, getDynFlags, withThisPackage,
Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
P(..), ParseResult(..), mkParserFlags, ParserFlags(..), getSrcLoc,
getPState, extopt, withThisPackage,
failLocMsgP, failSpanMsgP, srcParseFail,
getMessages,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
......@@ -85,6 +85,9 @@ import Data.List
import Data.Maybe
import Data.Word
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
-- ghc-boot
import qualified GHC.LanguageExtensions as LangExt
......@@ -1183,8 +1186,8 @@ varid span buf len =
maybe_layout keyword
return $ L span keyword
Just (ITstatic, _) -> do
flags <- getDynFlags
if xopt LangExt.StaticPointers flags
staticPointers <- extension staticPointersEnabled
if staticPointers
then return $ L span ITstatic
else return $ L span $ ITvarid fs
Just (keyword, 0) -> do
......@@ -1735,18 +1738,34 @@ data ParseResult a
-- show this span, e.g. by highlighting it.
MsgDoc -- The error message
-- | Test whether a 'WarningFlag' is set
warnopt :: WarningFlag -> ParserFlags -> Bool
warnopt f options = fromEnum f `IntSet.member` pWarningFlags options
-- | Test whether a 'LangExt.Extension' is set
extopt :: LangExt.Extension -> ParserFlags -> Bool
extopt f options = fromEnum f `IntSet.member` pExtensionFlags options
-- | The subset of the 'DynFlags' used by the parser
data ParserFlags = ParserFlags {
pWarningFlags :: IntSet
, pExtensionFlags :: IntSet
, pThisPackage :: UnitId -- ^ key of package currently being compiled
, pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions
}
data PState = PState {
buffer :: StringBuffer,
dflags :: DynFlags,
messages :: Messages,
options :: ParserFlags,
-- This needs to take DynFlags as an argument until
-- we have a fix for #10143
messages :: DynFlags -> Messages,
tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file
tab_count :: !Int, -- number of tab warnings in the file
last_tk :: Maybe Token,
last_loc :: RealSrcSpan, -- pos of previous token
last_len :: !Int, -- len of previous token
loc :: RealSrcLoc, -- current loc (end of prev token + 1)
extsBitmap :: !ExtsBitmap, -- bitmap that determines permitted
-- extensions
context :: [LayoutContext],
lex_state :: [Int],
srcfiles :: [FastString],
......@@ -1833,22 +1852,21 @@ failSpanMsgP span msg = P $ \_ -> PFailed span msg
getPState :: P PState
getPState = P $ \s -> POk s s
instance HasDynFlags P where
getDynFlags = P $ \s -> POk s (dflags s)
withThisPackage :: (UnitId -> a) -> P a
withThisPackage f
= do pkg <- liftM thisPackage getDynFlags
return $ f pkg
withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o))
extension :: (ExtsBitmap -> Bool) -> P Bool
extension p = P $ \s -> POk s (p $! extsBitmap s)
extension p = P $ \s -> POk s (p $! (pExtsBitmap . options) s)
getExts :: P ExtsBitmap
getExts = P $ \s -> POk s (extsBitmap s)
getExts = P $ \s -> POk s (pExtsBitmap . options $ s)
setExts :: (ExtsBitmap -> ExtsBitmap) -> P ()
setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } ()
setExts f = P $ \s -> POk s {
options =
let p = options s
in p { pExtsBitmap = f (pExtsBitmap p) }
} ()
setSrcLoc :: RealSrcLoc -> P ()
setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
......@@ -1996,6 +2014,10 @@ getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs
setALRContext :: [ALRContext] -> P ()
setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()
getALRTransitional :: P Bool
getALRTransitional = P $ \s@PState {options = o} ->
POk s (extopt LangExt.AlternativeLayoutRuleTransitional o)
getJustClosedExplicitLetBlock :: P Bool
getJustClosedExplicitLetBlock
= P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b
......@@ -2077,6 +2099,7 @@ data ExtBits
| BinaryLiteralsBit
| NegativeLiteralsBit
| TypeApplicationsBit
| StaticPointersBit
deriving Enum
......@@ -2139,6 +2162,8 @@ patternSynonymsEnabled :: ExtsBitmap -> Bool
patternSynonymsEnabled = xtest PatternSynonymsBit
typeApplicationEnabled :: ExtsBitmap -> Bool
typeApplicationEnabled = xtest TypeApplicationsBit
staticPointersEnabled :: ExtsBitmap -> Bool
staticPointersEnabled = xtest StaticPointersBit
-- PState for parsing options pragmas
--
......@@ -2147,35 +2172,16 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) {
lex_state = [bol, option_prags, 0]
}
-- create a parse state
--
mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState flags buf loc =
PState {
buffer = buf,
dflags = flags,
messages = emptyMessages,
tab_first = Nothing,
tab_count = 0,
last_tk = Nothing,
last_loc = mkRealSrcSpan loc loc,
last_len = 0,
loc = loc,
extsBitmap = bitmap,
context = [],
lex_state = [bol, 0],
srcfiles = [],
alr_pending_implicit_tokens = [],
alr_next_token = Nothing,
alr_last_loc = alrInitialLoc (fsLit "<no file>"),
alr_context = [],
alr_expecting_ocurly = Nothing,
alr_justClosedExplicitLetBlock = False,
annotations = [],
comment_q = [],
annotations_comments = []
-- | Extracts the flag information needed for parsing
mkParserFlags :: DynFlags -> ParserFlags
mkParserFlags flags =
ParserFlags {
pWarningFlags = DynFlags.warningFlags flags
, pExtensionFlags = DynFlags.extensionFlags flags
, pThisPackage = DynFlags.thisPackage flags
, pExtsBitmap = bitmap
}
where
where
bitmap = FfiBit `setBitIf` xopt LangExt.ForeignFunctionInterface flags
.|. InterruptibleFfiBit `setBitIf` xopt LangExt.InterruptibleFFI flags
.|. CApiFfiBit `setBitIf` xopt LangExt.CApiFFI flags
......@@ -2210,32 +2216,67 @@ mkPState flags buf loc =
.|. NegativeLiteralsBit `setBitIf` xopt LangExt.NegativeLiterals flags
.|. PatternSynonymsBit `setBitIf` xopt LangExt.PatternSynonyms flags
.|. TypeApplicationsBit `setBitIf` xopt LangExt.TypeApplications flags
.|. StaticPointersBit `setBitIf` xopt LangExt.StaticPointers flags
--
setBitIf :: ExtBits -> Bool -> ExtsBitmap
b `setBitIf` cond | cond = xbit b
| otherwise = 0
-- | Creates a parse state from a 'DynFlags' value
mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState flags = mkPStatePure (mkParserFlags flags)
-- | Creates a parse state from a 'ParserFlags' value
mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState
mkPStatePure options buf loc =
PState {
buffer = buf,
options = options,
messages = const emptyMessages,
tab_first = Nothing,
tab_count = 0,
last_tk = Nothing,
last_loc = mkRealSrcSpan loc loc,
last_len = 0,
loc = loc,
context = [],
lex_state = [bol, 0],
srcfiles = [],
alr_pending_implicit_tokens = [],
alr_next_token = Nothing,
alr_last_loc = alrInitialLoc (fsLit "<no file>"),
alr_context = [],
alr_expecting_ocurly = Nothing,
alr_justClosedExplicitLetBlock = False,
annotations = [],
comment_q = [],
annotations_comments = []
}
addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
addWarning option srcspan warning
= P $ \s@PState{messages=(ws,es), dflags=d} ->
let warning' = makeIntoWarning (Reason option) $
= P $ \s@PState{messages=m, options=o} ->
let
m' d =
let (ws, es) = m d
warning' = makeIntoWarning (Reason option) $
mkWarnMsg d srcspan alwaysQualify warning
ws' = if wopt option d then ws `snocBag` warning' else ws
in POk s{messages=(ws', es)} ()
ws' = if warnopt option o then ws `snocBag` warning' else ws
in (ws', es)
in POk s{messages=m'} ()
addTabWarning :: RealSrcSpan -> P ()
addTabWarning srcspan
= P $ \s@PState{tab_first=tf, tab_count=tc, dflags=d} ->
= P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->
let tf' = if isJust tf then tf else Just srcspan
tc' = tc + 1
s' = if wopt Opt_WarnTabs d
s' = if warnopt Opt_WarnTabs o
then s{tab_first = tf', tab_count = tc'}
else s
in POk s' ()
mkTabWarning :: PState -> Maybe ErrMsg
mkTabWarning PState{tab_first=tf, tab_count=tc, dflags=d} =
mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg
mkTabWarning PState{tab_first=tf, tab_count=tc} d =
let middle = if tc == 1
then text ""
else text ", and in" <+> speakNOf (tc - 1) (text "further location")
......@@ -2246,9 +2287,10 @@ mkTabWarning PState{tab_first=tf, tab_count=tc, dflags=d} =
in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $
mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf
getMessages :: PState -> Messages
getMessages p@PState{messages=(ws,es)} =
let tabwarning = mkTabWarning p
getMessages :: PState -> DynFlags -> Messages
getMessages p@PState{messages=m} d =
let (ws, es) = m d
tabwarning = mkTabWarning p d
ws' = maybe ws (`consBag` ws) tabwarning
in (ws', es)
......@@ -2259,11 +2301,11 @@ setContext :: [LayoutContext] -> P ()
setContext ctx = P $ \s -> POk s{context=ctx} ()
popContext :: P ()
popContext = P $ \ s@(PState{ buffer = buf, dflags = flags, context = ctx,
popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
last_len = len, last_loc = last_loc }) ->
case ctx of
(_:tl) -> POk s{ context = tl } ()
[] -> PFailed (RealSrcSpan last_loc) (srcParseErr flags buf len)