Introduce MonadP, make PV a newtype

Previously we defined   type PV = P,
this had the downside that if we wanted to change PV,
we would have to modify P as well.

Now PV is free to evolve independently from P.

The common operations addError, addFatalError, getBit, addAnnsAt,
were abstracted into a class called MonadP.

3 files changed, 104 insertions, 73 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 6feb06b586..0f3997e168 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -50,16 +50,17 @@
 module Lexer (
    Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..),
    P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags,
+   MonadP(..),
    getRealSrcLoc, getPState, withThisPackage,
    failLocMsgP, srcParseFail,
    getErrorMessages, getMessages,
    popContext, pushModuleContext, setLastToken, setSrcLoc,
    activeContext, nextIsEOF,
    getLexState, popLexState, pushLexState,
-   ExtBits(..), getBit,
-   addWarning, addError, addFatalError,
+   ExtBits(..),
+   addWarning,
    lexTokenStream,
-   addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
+   addAnnotation,AddAnn,mkParensApiAnn,
    commentToAnnotation
   ) where
 
@@ -2276,11 +2277,6 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
 -- stored in a @Word64@.
 type ExtsBitmap = Word64
 
--- | Check if a given flag is currently set in the bitmap.
-getBit :: ExtBits -> P Bool
-getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)
-                       in b `seq` POk s b
-
 xbit :: ExtBits -> ExtsBitmap
 xbit = bit . fromEnum
 
@@ -2474,34 +2470,52 @@ mkPStatePure options buf loc =
       annotations_comments = []
     }
 
--- | Add a non-fatal error. Use this when the parser can produce a result
---   despite the error.
---
---   For example, when GHC encounters a @forall@ in a type,
---   but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@
---   as if @-XExplicitForAll@ was enabled, adding a non-fatal error to
---   the accumulator.
+-- | An mtl-style class for monads that support parsing-related operations.
+-- For example, sometimes we make a second pass over the parsing results to validate,
+-- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume
+-- input but can report parsing errors, check for extension bits, and accumulate
+-- parsing annotations. Both P and PV are instances of MonadP.
 --
---   Control flow wise, non-fatal errors act like warnings: they are added
---   to the accumulator and parsing continues. This allows GHC to report
---   more than one parse error per file.
+-- MonadP grants us convenient overloading. The other option is to have separate operations
+-- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on.
 --
-addError :: SrcSpan -> SDoc -> P ()
-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'} ()
-
--- | Add a fatal error. This will be the last error reported by the parser, and
---   the parser will not produce any result, ending in a 'PFailed' state.
-addFatalError :: SrcSpan -> SDoc -> P a
-addFatalError span msg =
-  addError span msg >> P PFailed
+class Monad m => MonadP m where
+  -- | Add a non-fatal error. Use this when the parser can produce a result
+  --   despite the error.
+  --
+  --   For example, when GHC encounters a @forall@ in a type,
+  --   but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@
+  --   as if @-XExplicitForAll@ was enabled, adding a non-fatal error to
+  --   the accumulator.
+  --
+  --   Control flow wise, non-fatal errors act like warnings: they are added
+  --   to the accumulator and parsing continues. This allows GHC to report
+  --   more than one parse error per file.
+  --
+  addError :: SrcSpan -> SDoc -> m ()
+  -- | Add a fatal error. This will be the last error reported by the parser, and
+  --   the parser will not produce any result, ending in a 'PFailed' state.
+  addFatalError :: SrcSpan -> SDoc -> m a
+  -- | Check if a given flag is currently set in the bitmap.
+  getBit :: ExtBits -> m Bool
+  -- | Given a location and a list of AddAnn, apply them all to the location.
+  addAnnsAt :: SrcSpan -> [AddAnn] -> m ()
+
+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'} ()
+  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
+  addAnnsAt loc anns = mapM_ (\a -> a loc) anns
 
 -- | Add a warning to the accumulator.
 --   Use 'getMessages' to get the accumulated warnings.
@@ -3055,10 +3069,6 @@ addAnnotationOnly l a v = P $ \s -> POk s {
   annotations = ((l,a), [v]) : annotations s
   } ()
 
--- |Given a location and a list of AddAnn, apply them all to the location.
-addAnnsAt :: SrcSpan -> [AddAnn] -> P ()
-addAnnsAt loc anns = mapM_ (\a -> a loc) anns
-
 -- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
 -- 'AddAnn' values for the opening and closing bordering on the start
 -- and end of the span
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 469e02d0a6..aa1f2647a9 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2582,8 +2582,8 @@ exp   :: { ExpCmdP }
 infixexp :: { ExpCmdP }
         : exp10 { $1 }
         | infixexp qop exp10  {  ExpCmdP $
-                                 runExpCmdP $1 >>= \ $1 ->
-                                 runExpCmdP $3 >>= \ $3 ->
+                                 runExpCmdPV $1 >>= \ $1 ->
+                                 runExpCmdPV $3 >>= \ $3 ->
                                  ams (sLL $1 $> (ecOpApp $1 $2 $3))
                                      [mj AnnVal $2] }
                  -- AnnVal annotation for NPlusKPat, which discards the operator
@@ -2670,13 +2670,13 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
 
 fexp    :: { ExpCmdP }
         : fexp aexp                  {% runExpCmdP $2 >>= \ $2 ->
-                                        checkBlockArguments $2 >>= \_ ->
+                                        runPV (checkBlockArguments $2) >>= \_ ->
                                         return $ ExpCmdP $
-                                          runExpCmdP $1 >>= \ $1 ->
+                                          runExpCmdPV $1 >>= \ $1 ->
                                           checkBlockArguments $1 >>= \_ ->
                                           return (sLL $1 $> (ecHsApp $1 $2)) }
         | fexp TYPEAPP atype         {% runExpCmdP $1 >>= \ $1 ->
-                                        checkBlockArguments $1 >>= \_ ->
+                                        runPV (checkBlockArguments $1) >>= \_ ->
                                         fmap ecFromExp $
                                         ams (sLL $1 $> $ HsAppType noExt $1 (mkHsWildCardBndrs $3))
                                             [mj AnnAt $2] }
@@ -2699,7 +2699,7 @@ aexp    :: { ExpCmdP }
 
         | '\\' apat apats '->' exp
                    {  ExpCmdP $
-                      runExpCmdP $5 >>= \ $5 ->
+                      runExpCmdPV $5 >>= \ $5 ->
                       ams (sLL $1 $> $ ecHsLam (mkMatchGroup FromSource
                             [sLL $1 $> $ Match { m_ext = noExt
                                                , m_ctxt = LambdaExpr
@@ -2707,12 +2707,12 @@ aexp    :: { ExpCmdP }
                                                , m_grhss = unguardedGRHSs $5 }]))
                           [mj AnnLam $1, mu AnnRarrow $4] }
         | 'let' binds 'in' exp          {  ExpCmdP $
-                                           runExpCmdP $4 >>= \ $4 ->
+                                           runExpCmdPV $4 >>= \ $4 ->
                                            ams (sLL $1 $> $ ecHsLet (snd (unLoc $2)) $4)
                                                (mj AnnLet $1:mj AnnIn $3
                                                  :(fst $ unLoc $2)) }
         | '\\' 'lcase' altslist
-            {% $3 >>= \ $3 ->
+            {% runPV $3 >>= \ $3 ->
                fmap ecFromExp $
                ams (sLL $1 $> $ HsLamCase noExt
                                    (mkMatchGroup FromSource (snd $ unLoc $3)))
@@ -2720,8 +2720,8 @@ aexp    :: { ExpCmdP }
         | 'if' exp optSemi 'then' exp optSemi 'else' exp
                          {% runExpCmdP $2 >>= \ $2 ->
                             return $ ExpCmdP $
-                              runExpCmdP $5 >>= \ $5 ->
-                              runExpCmdP $8 >>= \ $8 ->
+                              runExpCmdPV $5 >>= \ $5 ->
+                              runExpCmdPV $8 >>= \ $8 ->
                               checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
                               ams (sLL $1 $> $ ecHsIf $2 $5 $8)
                                   (mj AnnIf $1:mj AnnThen $4
@@ -2746,7 +2746,7 @@ aexp    :: { ExpCmdP }
                                         ams (cL (comb2 $1 $2)
                                                (ecHsDo (mapLoc snd $2)))
                                                (mj AnnDo $1:(fst $ unLoc $2)) }
-        | 'mdo' stmtlist            {% $2 >>= \ $2 ->
+        | 'mdo' stmtlist            {% runPV $2 >>= \ $2 ->
                                        fmap ecFromExp $
                                        ams (cL (comb2 $1 $2)
                                               (mkHsDo MDoExpr (snd $ unLoc $2)))
@@ -2788,7 +2788,7 @@ aexp2   :: { ExpCmdP }
         -- correct Haskell (you'd have to write '((+ 3), (4 -))')
         -- but the less cluttered version fell out of having texps.
         | '(' texp ')'                  { ExpCmdP $
-                                           runExpCmdP $2 >>= \ $2 ->
+                                           runExpCmdPV $2 >>= \ $2 ->
                                            ams (sLL $1 $> (ecHsPar $2)) [mop $1,mcp $3] }
         | '(' tup_exprs ')'             {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2)
                                               ; fmap ecFromExp $
@@ -3022,12 +3022,12 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }   -- In reverse order, becau
                 amsL (comb2 $1 $>) (fst $ unLoc $3) >>
                 return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) }
     | squals ',' qual
-             {% $3 >>= \ $3 ->
+             {% runPV $3 >>= \ $3 ->
                 addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>
                 return (sLL $1 $> ($3 : unLoc $1)) }
     | transformqual        {% ams $1 (fst $ unLoc $1) >>
                               return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) }
-    | qual                               {% $1 >>= \ $1 ->
+    | qual                               {% runPV $1 >>= \ $1 ->
                                             return $ sL1 $1 [$1] }
 --  | transformquals1 ',' '{|' pquals '|}'   { sLL $1 $> ($4 : unLoc $1) }
 --  | '{|' pquals '|}'                       { sL1 $1 [$2] }
@@ -3068,11 +3068,11 @@ guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
     : guardquals1           { cL (getLoc $1) (reverse (unLoc $1)) }
 
 guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
-    : guardquals1 ',' qual  {% $3 >>= \ $3 ->
+    : guardquals1 ',' qual  {% runPV $3 >>= \ $3 ->
                                addAnnotation (gl $ head $ unLoc $1) AnnComma
                                              (gl $2) >>
                                return (sLL $1 $> ($3 : unLoc $1)) }
-    | qual                  {% $1 >>= \ $1 ->
+    | qual                  {% runPV $1 >>= \ $1 ->
                                return $ sL1 $1 [$1] }
 
 -----------------------------------------------------------------------------
@@ -3126,7 +3126,7 @@ alt_rhs :: { forall b. ExpCmdI b => PV (Located ([AddAnn],GRHSs GhcPs (Located (
                                       return $ sLL alt $> (fst $ unLoc $2, GRHSs noExt (unLoc alt) (snd $ unLoc $2)) }
 
 ralt :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]) }
-        : '->' exp            { runExpCmdP $2 >>= \ $2 ->
+        : '->' exp            { runExpCmdPV $2 >>= \ $2 ->
                                 ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
                                     [mu AnnRarrow $1] }
         | gdpats              { $1 >>= \gdpats ->
@@ -3142,14 +3142,14 @@ gdpats :: { forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))]
 -- generate the open brace in addition to the vertical bar in the lexer, and
 -- we don't need it.
 ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }
-         : '{' gdpats '}'                 {% $2 >>= \ $2 ->
+         : '{' gdpats '}'                 {% runPV $2 >>= \ $2 ->
                                              return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2)  }
-         |     gdpats close               {% $1 >>= \ $1 ->
+         |     gdpats close               {% runPV $1 >>= \ $1 ->
                                              return $ sL1 $1 ([],unLoc $1) }
 
 gdpat   :: { forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs))) }
         : '|' guardquals '->' exp
-                                   { runExpCmdP $4 >>= \ $4 ->
+                                   { runExpCmdPV $4 >>= \ $4 ->
                                      ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
                                          [mj AnnVbar $1,mu AnnRarrow $3] }
 
@@ -3229,12 +3229,12 @@ stmts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located (b
 -- For typing stmts at the GHCi prompt, where
 -- the input may consist of just comments.
 maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }
-        : stmt                          {% fmap Just $1 }
+        : stmt                          {% fmap Just (runPV $1) }
         | {- nothing -}                 { Nothing }
 
 -- For GHC API.
 e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
-        : stmt                          {% $1 }
+        : stmt                          {% runPV $1 }
 
 stmt  :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
         : qual                          { $1 }
@@ -3243,10 +3243,10 @@ stmt  :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
                                                (mj AnnRec $1:(fst $ unLoc $2)) }
 
 qual  :: { forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs))) }
-    : bindpat '<-' exp                   { runExpCmdP $3 >>= \ $3 ->
+    : bindpat '<-' exp                   { runExpCmdPV $3 >>= \ $3 ->
                                            ams (sLL $1 $> $ mkBindStmt $1 $3)
                                                [mu AnnLarrow $2] }
-    | exp                                { runExpCmdP $1 >>= \ $1 ->
+    | exp                                { runExpCmdPV $1 >>= \ $1 ->
                                            return $ sL1 $1 $ mkBodyStmt $1 }
     | 'let' binds                        { ams (sLL $1 $> $ LetStmt noExt (snd $ unLoc $2))
                                                (mj AnnLet $1:(fst $ unLoc $2)) }
@@ -4037,7 +4037,7 @@ am a (b,s) = do
 -- as any annotations that may arise in the binds. This will include open
 -- and closing braces if they are used to delimit the let expressions.
 --
-ams :: Located a -> [AddAnn] -> P (Located a)
+ams :: MonadP m => Located a -> [AddAnn] -> m (Located a)
 ams a@(dL->L l _) bs = addAnnsAt l bs >> return a
 
 amsL :: SrcSpan -> [AddAnn] -> P ()
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index bfb83bc9b3..be1dd974a9 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -15,6 +15,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module   RdrHsSyn (
         mkHsOpApp,
@@ -88,7 +89,9 @@ module   RdrHsSyn (
 
         -- Expression/command ambiguity resolution
         PV,
-        ExpCmdP(ExpCmdP, runExpCmdP),
+        runPV,
+        ExpCmdP(ExpCmdP, runExpCmdPV),
+        runExpCmdP,
         ExpCmdI(..),
         ecFromExp,
         ecFromCmd,
@@ -970,11 +973,11 @@ checkTyClHdr is_cls ty
 
 -- | Yield a parse error if we have a function applied directly to a do block
 -- etc. and BlockArguments is not enabled.
-checkExpBlockArguments :: LHsExpr GhcPs -> P ()
-checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
+checkExpBlockArguments :: LHsExpr GhcPs -> PV ()
+checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
 (checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)
   where
-    checkExpr :: LHsExpr GhcPs -> P ()
+    checkExpr :: LHsExpr GhcPs -> PV ()
     checkExpr expr = case unLoc expr of
       HsDo _ DoExpr _ -> check "do block" expr
       HsDo _ MDoExpr _ -> check "mdo block" expr
@@ -986,7 +989,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
       HsProc {} -> check "proc expression" expr
       _ -> return ()
 
-    checkCmd :: LHsCmd GhcPs -> P ()
+    checkCmd :: LHsCmd GhcPs -> PV ()
     checkCmd cmd = case unLoc cmd of
       HsCmdLam {} -> check "lambda command" cmd
       HsCmdCase {} -> check "case command" cmd
@@ -995,7 +998,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
       HsCmdDo {} -> check "do command" cmd
       _ -> return ()
 
-    check :: (HasSrcSpan a, Outputable a) => String -> a -> P ()
+    check :: (HasSrcSpan a, Outputable a) => String -> a -> PV ()
     check element a = do
       blockArguments <- getBit BlockArgumentsBit
       unless blockArguments $
@@ -1284,7 +1287,7 @@ checkValSigLhs lhs@(dL->L l _)
 
 checkDoAndIfThenElse'
   :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
-  => a -> Bool -> b -> Bool -> c -> P ()
+  => a -> Bool -> b -> Bool -> c -> PV ()
 checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr
  | semiThen || semiElse
     = do doAndIfThenElse <- getBit DoAndIfThenElseBit
@@ -1876,7 +1879,10 @@ checkMonadComp = do
 -- See Note [Parser-Validator]
 -- See Note [Ambiguous syntactic categories]
 newtype ExpCmdP =
-  ExpCmdP { runExpCmdP :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
+  ExpCmdP { runExpCmdPV :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
+
+runExpCmdP :: ExpCmdI b => ExpCmdP -> P (Located (b GhcPs))
+runExpCmdP p = runPV (runExpCmdPV p)
 
 ecFromExp :: LHsExpr GhcPs -> ExpCmdP
 ecFromExp a = ExpCmdP (ecFromExp' a)
@@ -1910,7 +1916,7 @@ class ExpCmdI b where
   checkBlockArguments :: Located (b GhcPs) -> PV ()
   -- | Check if -XDoAndIfThenElse is enabled.
   checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs)
-                                        -> Bool -> Located (b GhcPs) -> P ()
+                                        -> Bool -> Located (b GhcPs) -> PV ()
 
 instance ExpCmdI HsCmd where
   ecFromCmd' = return
@@ -2661,7 +2667,22 @@ failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg
 -----------------------------------------------------------------------------
 -- Misc utils
 
-type PV = P -- See Note [Parser-Validator]
+-- See Note [Parser-Validator]
+newtype PV a = PV (P a)
+  deriving (Functor, Applicative, Monad)
+
+runPV :: PV a -> P a
+runPV (PV m) = m
+
+instance MonadP PV where
+  addError srcspan msg =
+    PV $ addError srcspan msg
+  addFatalError srcspan msg =
+    PV $ addFatalError srcspan msg
+  getBit ext =
+    PV $ getBit ext
+  addAnnsAt loc anns =
+    PV $ addAnnsAt loc anns
 
 {- Note [Parser-Validator]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~