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

compiler/cmm/CmmLex.x

@@ -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 } ()
 }

compiler/cmm/CmmMonad.hs

+-----------------------------------------------------------------------------
+-- 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

compiler/cmm/CmmParse.y

@@ -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

compiler/ghc.cabal.in

@@ -213,6 +213,7 @@ Library
         CmmLint
         CmmLive
         CmmMachOp
+        CmmMonad
         CmmSwitch
         CmmNode
         CmmOpt

compiler/main/GHC.hs

@@ -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)

compiler/main/HeaderInfo.hs

@@ -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)

compiler/main/HscMain.hs

@@ -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
 

compiler/parser/Lexer.x

@@ -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)
+        []     -> PFailed (RealSrcSpan last_loc) (srcParseErr o buf len)
 
 -- Push a new layout context at the indentation of the last token read.
 -- This is only used at the outer level of a module when the 'module'
@@ -2285,11 +2327,11 @@ getOffside = P $ \s@PState{last_loc=loc, context=stk} ->
 -- Construct a parse error
 
 srcParseErr
-  :: DynFlags
+  :: ParserFlags
   -> StringBuffer       -- current buffer (placed just after the last token)
   -> Int                -- length of the previous token
   -> MsgDoc
-srcParseErr dflags buf len
+srcParseErr options buf len
   = if null token
          then text "parse error (possibly incorrect indentation or mismatched brackets)"
          else text "parse error on input" <+> quotes (text token)
@@ -2301,15 +2343,15 @@ srcParseErr dflags buf len
                         (text "Perhaps you need a 'let' in a 'do' block?"
                          $$ text "e.g. 'let x = 5' instead of 'x = 5'")
   where token = lexemeToString (offsetBytes (-len) buf) len
-        th_enabled = xopt LangExt.TemplateHaskell dflags
+        th_enabled = extopt LangExt.TemplateHaskell options
 
 -- Report a parse failure, giving the span of the previous token as
 -- the location of the error.  This is the entry point for errors
 -- detected during parsing.
 srcParseFail :: P a
-srcParseFail = P $ \PState{ buffer = buf, dflags = flags, last_len = len,
+srcParseFail = P $ \PState{ buffer = buf, options = o, last_len = len,