From 1befd2c00f8a8fc1ca62ef18ca3028c58e35dabd Mon Sep 17 00:00:00 2001
From: Vladislav Zavialov <vlad.z.4096@gmail.com>
Date: Tue, 30 Apr 2019 16:56:32 +0300
Subject: [PATCH] PV is not P (#16611)
---
compiler/parser/Lexer.x | 75 ++++++++++++++++++---------
compiler/parser/RdrHsSyn.hs | 100 +++++++++++++++++++++++++++++-------
2 files changed, 133 insertions(+), 42 deletions(-)
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index e7e1028c9612..2ada289db404 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 b0d493c559d3..a574fbe338dd 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.
-}
--
GitLab