PV is not P (#16611)

2 files changed, 133 insertions, 42 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index e7e1028c96..2ada289db4 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -49,7 +49,10 @@
 
 module Lexer (
    Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
-   P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags,
+   P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags(..),
+   appendWarning,
+   appendError,
+   allocateComments,
    MonadP(..),
    getRealSrcLoc, getPState, withThisPackage,
    failLocMsgP, srcParseFail,
@@ -58,6 +61,7 @@ module Lexer (
    activeContext, nextIsEOF,
    getLexState, popLexState, pushLexState,
    ExtBits(..),
+   xtest,
    lexTokenStream,
    AddAnn(..),mkParensApiAnn,
    addAnnsAt,
@@ -2509,33 +2513,47 @@ class Monad m => MonadP m where
                 -> SrcSpan          -- The location of the keyword itself
                 -> m ()
 
+appendError
+  :: SrcSpan
+  -> SDoc
+  -> (DynFlags -> Messages)
+  -> (DynFlags -> Messages)
+appendError srcspan msg m =
+  \d ->
+    let (ws, es) = m d
+        errormsg = mkErrMsg d srcspan alwaysQualify msg
+        es' = es `snocBag` errormsg
+    in (ws, es')
+
+appendWarning
+  :: ParserFlags
+  -> WarningFlag
+  -> SrcSpan
+  -> SDoc
+  -> (DynFlags -> Messages)
+  -> (DynFlags -> Messages)
+appendWarning o option srcspan warning m =
+  \d ->
+    let (ws, es) = m d
+        warning' = makeIntoWarning (Reason option) $
+           mkWarnMsg d srcspan alwaysQualify warning
+        ws' = if warnopt option o then ws `snocBag` warning' else ws
+    in (ws', es)
+
 instance MonadP P where
   addError srcspan msg
    = P $ \s@PState{messages=m} ->
-         let
-             m' d =
-                 let (ws, es) = m d
-                     errormsg = mkErrMsg d srcspan alwaysQualify msg
-                     es' = es `snocBag` errormsg
-                 in (ws, es')
-         in POk s{messages=m'} ()
+             POk s{messages=appendError srcspan msg m} ()
   addWarning option srcspan warning
    = 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 warnopt option o then ws `snocBag` warning' else ws
-                 in (ws', es)
-         in POk s{messages=m'} ()
+             POk s{messages=appendWarning o option srcspan warning m} ()
   addFatalError span msg =
     addError span msg >> P PFailed
   getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)
                          in b `seq` POk s b
   addAnnotation l a v = do
     addAnnotationOnly l a v
-    allocateComments l
+    allocateCommentsP l
 
 addAnnsAt :: MonadP m => SrcSpan -> [AddAnn] -> m ()
 addAnnsAt l = mapM_ (\(AddAnn a v) -> addAnnotation l a v)
@@ -3092,19 +3110,28 @@ queueComment c = P $ \s -> POk s {
 
 -- | Go through the @comment_q@ in @PState@ and remove all comments
 -- that belong within the given span
-allocateComments :: SrcSpan -> P ()
-allocateComments ss = P $ \s ->
+allocateCommentsP :: SrcSpan -> P ()
+allocateCommentsP ss = P $ \s ->
+  let (comment_q', newAnns) = allocateComments ss (comment_q s) in
+    POk s {
+       comment_q = comment_q'
+     , annotations_comments = newAnns ++ (annotations_comments s)
+     } ()
+
+allocateComments
+  :: SrcSpan
+  -> [Located AnnotationComment]
+  -> ([Located AnnotationComment], [(SrcSpan,[Located AnnotationComment])])
+allocateComments ss comment_q =
   let
-    (before,rest)  = break (\(L l _) -> isSubspanOf l ss) (comment_q s)
+    (before,rest)  = break (\(L l _) -> isSubspanOf l ss) comment_q
     (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest
     comment_q' = before ++ after
     newAnns = if null middle then []
                              else [(ss,middle)]
   in
-    POk s {
-       comment_q = comment_q'
-     , annotations_comments = newAnns ++ (annotations_comments s)
-     } ()
+    (comment_q', newAnns)
+
 
 commentToAnnotation :: Located Token -> Located AnnotationComment
 commentToAnnotation (L l (ITdocCommentNext s))  = L l (AnnDocCommentNext s)
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index b0d493c559..a574fbe338 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -131,10 +131,10 @@ import Maybes
 import Util
 import ApiAnnotation
 import Data.List
-import DynFlags ( WarningFlag(..) )
+import DynFlags ( WarningFlag(..), DynFlags )
+import ErrUtils ( Messages )
 
 import Control.Monad
-import Control.Monad.Trans.Reader
 import Text.ParserCombinators.ReadP as ReadP
 import Data.Char
 import qualified Data.Monoid as Monoid
@@ -3003,30 +3003,94 @@ failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg
 -----------------------------------------------------------------------------
 -- Misc utils
 
--- See Note [Parser-Validator] and Note [Parser-Validator ReaderT SDoc]
-newtype PV a = PV (ReaderT SDoc P a)
-  deriving (Functor, Applicative, Monad)
+data PV_Context =
+  PV_Context
+    { pv_options :: ParserFlags
+    , pv_hint :: SDoc  -- See Note [Parser-Validator Hint]
+    }
+
+data PV_Accum =
+  PV_Accum
+    { pv_messages :: DynFlags -> Messages
+    , pv_annotations :: [(ApiAnnKey,[SrcSpan])]
+    , pv_comment_q :: [Located AnnotationComment]
+    , pv_annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
+    }
+
+data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum
+
+-- See Note [Parser-Validator]
+newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a }
+
+instance Functor PV where
+  fmap = liftM
+
+instance Applicative PV where
+  pure a = a `seq` PV (\_ acc -> PV_Ok acc a)
+  (<*>) = ap
+
+instance Monad PV where
+  m >>= f = PV $ \ctx acc ->
+    case unPV m ctx acc of
+      PV_Ok acc' a -> unPV (f a) ctx acc'
+      PV_Failed acc' -> PV_Failed acc'
 
 runPV :: PV a -> P a
-runPV (PV m) = runReaderT m empty
+runPV = runPV_msg empty
 
 runPV_msg :: SDoc -> PV a -> P a
-runPV_msg msg (PV m) = runReaderT m msg
+runPV_msg msg m =
+  P $ \s ->
+    let
+      pv_ctx = PV_Context
+        { pv_options = options s
+        , pv_hint = msg }
+      pv_acc = PV_Accum
+        { pv_messages = messages s
+        , pv_annotations = annotations s
+        , pv_comment_q = comment_q s
+        , pv_annotations_comments = annotations_comments s }
+      mkPState acc' =
+        s { messages = pv_messages acc'
+          , annotations = pv_annotations acc'
+          , comment_q = pv_comment_q acc'
+          , annotations_comments = pv_annotations_comments acc' }
+    in
+      case unPV m pv_ctx pv_acc of
+        PV_Ok acc' a -> POk (mkPState acc') a
+        PV_Failed acc' -> PFailed (mkPState acc')
 
 localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a
-localPV_msg f (PV m) = PV (local f m)
+localPV_msg f m =
+  let modifyHint ctx = ctx{pv_hint = f (pv_hint ctx)} in
+  PV (\ctx acc -> unPV m (modifyHint ctx) acc)
 
 instance MonadP PV where
   addError srcspan msg =
-    PV $ ReaderT $ \ctxMsg -> addError srcspan (msg $$ ctxMsg)
-  addWarning option srcspan msg =
-    PV $ ReaderT $ \_ -> addWarning option srcspan msg
+    PV $ \ctx acc@PV_Accum{pv_messages=m} ->
+      let msg' = msg $$ pv_hint ctx in
+      PV_Ok acc{pv_messages=appendError srcspan msg' m} ()
+  addWarning option srcspan warning =
+    PV $ \PV_Context{pv_options=o} acc@PV_Accum{pv_messages=m} ->
+      PV_Ok acc{pv_messages=appendWarning o option srcspan warning m} ()
   addFatalError srcspan msg =
-    PV $ ReaderT $ \ctxMsg -> addFatalError srcspan (msg $$ ctxMsg)
+    addError srcspan msg >> PV (const PV_Failed)
   getBit ext =
-    PV $ ReaderT $ \_ -> getBit ext
+    PV $ \ctx acc ->
+      let b = ext `xtest` pExtsBitmap (pv_options ctx) in
+      PV_Ok acc $! b
   addAnnotation l a v =
-    PV $ ReaderT $ \_ -> addAnnotation l a v
+    PV $ \_ acc ->
+      let
+        (comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc)
+        annotations_comments' = new_ann_comments ++ pv_annotations_comments acc
+        annotations' = ((l,a), [v]) : pv_annotations acc
+        acc' = acc
+          { pv_annotations = annotations'
+          , pv_comment_q = comment_q'
+          , pv_annotations_comments = annotations_comments' }
+      in
+        PV_Ok acc' ()
 
 {- Note [Parser-Validator]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3058,7 +3122,7 @@ not consume any input, but may fail or use other effects. Thus we have:
 
 -}
 
-{- Note [Parser-Validator ReaderT SDoc]
+{- Note [Parser-Validator Hint]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 A PV computation is parametrized by a hint for error messages, which can be set
 depending on validation context. We use this in checkPattern to fix #984.
@@ -3094,9 +3158,9 @@ We attempt to detect such cases and add a hint to the error messages:
     Possibly caused by a missing 'do'?
 
 The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed
-via ReaderT SDoc in PV. When validating in a context other than 'bindpat' (a
-pattern to the left of <-), we set the hint to 'empty' and it has no effect on
-the error messages.
+as the 'pv_hint' field 'PV_Context'. When validating in a context other than
+'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has
+no effect on the error messages.
 
 -}