Commit 469fe613 authored by Alec Theriault's avatar Alec Theriault Committed by Ben Gamari

'DynFlag'-free version of 'mkParserFlags'

Summary:
This is a fixed version of the reverted d2fbc33c
and  5aa29231.

Obtaining a `DynFlags` is difficult, making using the lexer/parser
for pure parsing/lexing unreasonably difficult, even with `mkPStatePure`.
This is despite the fact that we only really need

    * language extension flags
    * warning flags
    * a handful of boolean options

The new `mkParserFlags'` function makes is easier to directly construct a
`ParserFlags`. Furthermore, since `pExtsBitmap` is just a footgun, I've gone
ahead and made `ParserFlags` an abstract type.

Also, we now export `ExtBits` and `getBit` instead of defining/exporting a
bunch of boilerplate functions that test for a particular 'ExtBits'.
In the process, I also

  * cleaned up an unneeded special case for `ITstatic`
  * made `UsePosPrags` another variant of `ExtBits`
  * made the logic in `reservedSymsFM` match that of `reservedWordsFM`

Test Plan: make test

Reviewers: bgamari, alanz, tdammers

Subscribers: sjakobi, tdammers, rwbarton, mpickering, carter

GHC Trac Issues: #11301

Differential Revision: https://phabricator.haskell.org/D5405
parent d512b330
This diff is collapsed.
......@@ -87,8 +87,6 @@ import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilD
-- compiler/utils
import Util ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )
import GhcPrelude
import qualified GHC.LanguageExtensions as LangExt
}
%expect 237 -- shift/reduce conflicts
......@@ -3755,14 +3753,14 @@ fileSrcSpan = do
-- Hint about the MultiWayIf extension
hintMultiWayIf :: SrcSpan -> P ()
hintMultiWayIf span = do
mwiEnabled <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState
mwiEnabled <- getBit MultiWayIfBit
unless mwiEnabled $ parseErrorSDoc span $
text "Multi-way if-expressions need MultiWayIf turned on"
-- Hint about if usage for beginners
hintIf :: SrcSpan -> String -> P (LHsExpr GhcPs)
hintIf span msg = do
mwiEnabled <- liftM ((LangExt.MultiWayIf `extopt`) . options) getPState
mwiEnabled <- getBit MultiWayIfBit
if mwiEnabled
then parseErrorSDoc span $ text $ "parse error in if statement"
else parseErrorSDoc span $ text $ "parse error in if statement: "++msg
......@@ -3770,8 +3768,8 @@ hintIf span msg = do
-- Hint about explicit-forall, assuming UnicodeSyntax is on
hintExplicitForall :: SrcSpan -> P ()
hintExplicitForall span = do
forall <- extension explicitForallEnabled
rulePrag <- extension inRulePrag
forall <- getBit ExplicitForallBit
rulePrag <- getBit InRulePragBit
unless (forall || rulePrag) $ parseErrorSDoc span $ vcat
[ text "Illegal symbol '\x2200' in type" -- U+2200 FOR ALL
, text "Perhaps you intended to use RankNTypes or a similar language"
......@@ -3781,7 +3779,7 @@ hintExplicitForall span = do
-- Hint about explicit-forall, assuming UnicodeSyntax is off
hintExplicitForall' :: SrcSpan -> P (Located RdrName)
hintExplicitForall' span = do
forall <- extension explicitForallEnabled
forall <- getBit ExplicitForallBit
let illegalDot = "Illegal symbol '.' in type"
if forall
then parseErrorSDoc span $ vcat
......@@ -3801,7 +3799,7 @@ checkIfBang _ = False
-- | Warn about missing space after bang
warnSpaceAfterBang :: SrcSpan -> P ()
warnSpaceAfterBang span = do
bang_on <- extension bangPatEnabled
bang_on <- getBit BangPatBit
unless bang_on $
addWarning Opt_WarnSpaceAfterBang span msg
where
......@@ -3814,8 +3812,8 @@ warnSpaceAfterBang span = do
-- variable or constructor. See Trac #13450.
reportEmptyDoubleQuotes :: SrcSpan -> P (Located (HsExpr GhcPs))
reportEmptyDoubleQuotes span = do
thEnabled <- liftM ((LangExt.TemplateHaskellQuotes `extopt`) . options) getPState
if thEnabled
thQuotes <- getBit ThQuotesBit
if thQuotes
then parseErrorSDoc span $ vcat
[ text "Parser error on `''`"
, text "Character literals may not be empty"
......
......@@ -108,7 +108,6 @@ import Maybes
import Util
import ApiAnnotation
import Data.List
import qualified GHC.LanguageExtensions as LangExt
import DynFlags ( WarningFlag(..) )
import Control.Monad
......@@ -880,7 +879,7 @@ equalsDots = text "= ..."
checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Nothing = return ()
checkDatatypeContext (Just c)
= do allowed <- extension datatypeContextsEnabled
= do allowed <- getBit DatatypeContextsBit
unless allowed $
parseErrorSDoc (getLoc c)
(text "Illegal datatype context (use DatatypeContexts):"
......@@ -918,7 +917,7 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
checkRecordSyntax :: Outputable a => Located a -> P (Located a)
checkRecordSyntax lr@(dL->L loc r)
= do allowed <- extension traditionalRecordSyntaxEnabled
= do allowed <- getBit TraditionalRecordSyntaxBit
if allowed
then return lr
else parseErrorSDoc loc
......@@ -930,8 +929,8 @@ checkRecordSyntax lr@(dL->L loc r)
checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
-> P (Located ([AddAnn], [LConDecl GhcPs]))
checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration.
= do opts <- fmap options getPState
if LangExt.GADTSyntax `extopt` opts -- GADTs implies GADTSyntax
= do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax
if gadtSyntax
then return gadts
else parseErrorSDoc span $ vcat
[ text "Illegal keyword 'where' in data declaration"
......@@ -995,8 +994,8 @@ checkBlockArguments expr = case unLoc expr of
_ -> return ()
where
check element = do
pState <- getPState
unless (extopt LangExt.BlockArguments (options pState)) $
blockArguments <- getBit BlockArgumentsBit
unless blockArguments $
parseErrorSDoc (getLoc expr) $
text "Unexpected " <> text element <> text " in function application:"
$$ nest 4 (ppr expr)
......@@ -1082,8 +1081,7 @@ checkPat msg loc e _
checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs)
checkAPat msg loc e0 = do
pState <- getPState
let opts = options pState
nPlusKPatterns <- getBit NPlusKPatternsBit
case e0 of
EWildPat _ -> return (WildPat noExt)
HsVar _ x -> return (VarPat noExt x)
......@@ -1119,7 +1117,7 @@ checkAPat msg loc e0 = do
OpApp _ (dL->L nloc (HsVar _ (dL->L _ n)))
(dL->L _ (HsVar _ (dL->L _ plus)))
(dL->L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
| extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
| nPlusKPatterns && (plus == plus_RDR)
-> return (mkNPlusKPat (cL nloc n) (cL lloc lit))
OpApp _ l (dL->L cl (HsVar _ (dL->L _ c))) r
| isDataOcc (rdrNameOcc c) -> do
......@@ -1285,8 +1283,8 @@ checkDoAndIfThenElse :: LHsExpr GhcPs
-> P ()
checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do pState <- getPState
unless (extopt LangExt.DoAndIfThenElse (options pState)) $ do
= do doAndIfThenElse <- getBit DoAndIfThenElseBit
unless doAndIfThenElse $ do
parseErrorSDoc (combineLocs guardExpr elseExpr)
(text "Unexpected semi-colons in conditional:"
$$ nest 4 expr
......@@ -1356,7 +1354,7 @@ isFunLhs e = go e [] []
go e@(L loc (OpApp _ l (dL->L loc' (HsVar _ (dL->L _ op))) r)) es ann
| Just (e',es') <- splitBang e
= do { bang_on <- extension bangPatEnabled
= do { bang_on <- getBit BangPatBit
; if bang_on then go e' (es' ++ es) ann
else return (Just (cL loc' op, Infix, (l:r:es), ann)) }
-- No bangs; behave just like the next case
......@@ -1837,15 +1835,15 @@ mergeDataCon all_xs =
nest 2 (hsep . reverse $ map ppr all_xs')
---------------------------------------------------------------------------
-- Check for monad comprehensions
-- | Check for monad comprehensions
--
-- If the flag MonadComprehensions is set, return a `MonadComp' context,
-- otherwise use the usual `ListComp' context
-- If the flag MonadComprehensions is set, return a 'MonadComp' context,
-- otherwise use the usual 'ListComp' context
checkMonadComp :: P (HsStmtContext Name)
checkMonadComp = do
pState <- getPState
return $ if extopt LangExt.MonadComprehensions (options pState)
monadComprehensions <- getBit MonadComprehensionsBit
return $ if monadComprehensions
then MonadComp
else ListComp
......@@ -2168,7 +2166,7 @@ mkModuleImpExp (dL->L l specname) subs =
(\newName -> IEThingWith noExt (cL l newName)
NoIEWildcard (wrapped xs) []) <$> nameT
ImpExpAllWith xs ->
do allowed <- extension patternSynonymsEnabled
do allowed <- getBit PatternSynonymsBit
if allowed
then
let withs = map unLoc xs
......@@ -2207,7 +2205,7 @@ mkModuleImpExp (dL->L l specname) subs =
mkTypeImpExp :: Located RdrName -- TcCls or Var name space
-> P (Located RdrName)
mkTypeImpExp name =
do allowed <- extension explicitNamespacesEnabled
do allowed <- getBit ExplicitNamespacesBit
if allowed
then return (fmap (`setRdrNameSpace` tcClsName) name)
else parseErrorSDoc (getLoc name)
......@@ -2263,7 +2261,7 @@ warnStarBndr span = addWarning Opt_WarnStarBinder span msg
failOpFewArgs :: Located RdrName -> P a
failOpFewArgs (dL->L loc op) =
do { star_is_type <- extension starIsTypeEnabled
do { star_is_type <- getBit StarIsTypeBit
; let msg = too_few $$ starInfo star_is_type op
; parseErrorSDoc loc msg }
where
......@@ -2295,7 +2293,7 @@ parseErrorSDoc span s = failSpanMsgP span s
-- | Hint about bang patterns, assuming @BangPatterns@ is off.
hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
hintBangPat span e = do
bang_on <- extension bangPatEnabled
bang_on <- getBit BangPatBit
unless bang_on $
parseErrorSDoc span
(text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
......
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