[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Grammar for types and data/newtype constructors

Marge Bot gitlab at gitlab.haskell.org
Thu Aug 6 12:03:57 UTC 2020



 Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
2c812b7b by Vladislav Zavialov at 2020-08-06T08:03:45-04:00
Grammar for types and data/newtype constructors

Before this patch, we parsed types into a reversed sequence
of operators and operands. For example, (F x y + G a b * X)
would be parsed as [X, *, b, a, G, +, y, x, F],
using a simple grammar:

	tyapps
	  : tyapp
	  | tyapps tyapp

	tyapp
	  : atype
	  | PREFIX_AT atype
	  | tyop
	  | unpackedness

Then we used a hand-written state machine to assemble this
 either into a type,        using 'mergeOps',
     or into a constructor, using 'mergeDataCon'.

This is due to a syntactic ambiguity:

	data T1 a =          MkT1 a
	data T2 a = Ord a => MkT2 a

In T1, what follows after the = sign is a data/newtype constructor
declaration. However, in T2, what follows is a type (of kind
Constraint). We don't know which of the two we are parsing until we
encounter =>, and we cannot check for => without unlimited lookahead.

This poses a few issues when it comes to e.g. infix operators:

	data I1 = Int :+ Bool :+ Char          -- bad
	data I2 = Int :+ Bool :+ Char => MkI2  -- fine

By this issue alone we are forced into parsing into an intermediate
representation and doing a separate validation pass.

However, should that intermediate representation be as low-level as a
flat sequence of operators and operands?

Before GHC Proposal #229, the answer was Yes, due to some particularly
nasty corner cases:

	data T = ! A :+ ! B          -- used to be fine, hard to parse
	data T = ! A :+ ! B => MkT   -- bad

However, now the answer is No, as this corner case is gone:

	data T = ! A :+ ! B          -- bad
	data T = ! A :+ ! B => MkT   -- bad

This means we can write a proper grammar for types, overloading it in
the DisambECP style, see Note [Ambiguous syntactic categories].

With this patch, we introduce a new class, DisambTD. Just like
DisambECP is used to disambiguate between expressions, commands, and patterns,
DisambTD  is used to disambiguate between types and data/newtype constructors.

This way, we get a proper, declarative grammar for constructors and
types:

	infixtype
	  : ftype
	  | ftype tyop infixtype
	  | unpackedness infixtype

	ftype
	  : atype
	  | tyop
	  | ftype tyarg
	  | ftype PREFIX_AT tyarg

	tyarg
	  : atype
	  | unpackedness atype

And having a grammar for types means we are a step closer to using a
single grammar for types and expressions.

- - - - -
9f702f5e by Vladislav Zavialov at 2020-08-06T08:03:45-04:00
Clean up the story around runPV/runECP_P/runECP_PV

This patch started as a small documentation change, an attempt to make
Note [Parser-Validator] and Note [Ambiguous syntactic categories]
more clear and up-to-date.

But it turned out that runECP_P/runECP_PV are weakly motivated,
and it's easier to remove them than to find a good rationale/explanation
for their existence.

As the result, there's a bit of refactoring in addition to
a documentation update.

- - - - -
68504fdf by Vladislav Zavialov at 2020-08-06T08:03:46-04:00
Fix debug_ppr_ty ForAllTy (#18522)

Before this change, GHC would
pretty-print   forall k. forall a -> ()
          as   forall @k a. ()
which isn't even valid Haskell.

- - - - -
de222b0e by Vladislav Zavialov at 2020-08-06T08:03:46-04:00
Fix visible forall in ppr_ty (#18522)

Before this patch, this type:
  T :: forall k -> (k ~ k) => forall j -> k -> j -> Type
was printed incorrectly as:
  T :: forall k j -> (k ~ k) => k -> j -> Type

- - - - -
27aad4ab by Richard Eisenberg at 2020-08-06T08:03:46-04:00
Fail eagerly on a lev-poly datacon arg

Close #18534.

See commentary in the patch.

- - - - -
54d6387a by Sylvain Henry at 2020-08-06T08:03:48-04:00
Use a type alias for Ways

- - - - -


24 changed files:

- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Platform/Profile.hs
- compiler/GHC/Platform/Ways.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Unit/State.hs
- + testsuite/tests/ghc-api/T18522-dbg-ppr.hs
- + testsuite/tests/ghc-api/T18522-dbg-ppr.stdout
- testsuite/tests/ghc-api/all.T
- testsuite/tests/parser/should_fail/T12045d.stderr
- testsuite/tests/parser/should_fail/strictnessDataCon_B.stderr
- testsuite/tests/parser/should_fail/typeops_A.stderr
- testsuite/tests/parser/should_fail/typeops_C.stderr
- testsuite/tests/parser/should_fail/unpack_empty_type.stderr
- testsuite/tests/parser/should_fail/unpack_inside_type.stderr
- + testsuite/tests/polykinds/T18522-ppr.script
- + testsuite/tests/polykinds/T18522-ppr.stdout
- testsuite/tests/polykinds/all.T
- + testsuite/tests/typecheck/should_fail/T18534.hs
- + testsuite/tests/typecheck/should_fail/T18534.stderr
- testsuite/tests/typecheck/should_fail/all.T


Changes:

=====================================
compiler/GHC/Core/TyCo/Ppr.hs
=====================================
@@ -36,7 +36,8 @@ import {-# SOURCE #-} GHC.CoreToIface
 import {-# SOURCE #-} GHC.Core.DataCon
    ( dataConFullSig , dataConUserTyVarBinders, DataCon )
 
-import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern One, pattern Many )
+import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern One, pattern Many,
+                       splitForAllTysReq, splitForAllTysInvis )
 
 import GHC.Core.TyCon
 import GHC.Core.TyCo.Rep
@@ -268,19 +269,34 @@ debug_ppr_ty prec (CastTy ty co)
 debug_ppr_ty _ (CoercionTy co)
   = parens (text "CO" <+> ppr co)
 
-debug_ppr_ty prec ty@(ForAllTy {})
-  | (tvs, body) <- split ty
+-- Invisible forall:  forall {k} (a :: k). t
+debug_ppr_ty prec t
+  | (bndrs, body) <- splitForAllTysInvis t
+  , not (null bndrs)
   = maybeParen prec funPrec $
-    hang (text "forall" <+> fsep (map ppr tvs) <> dot)
-         -- The (map ppr tvs) will print kind-annotated
-         -- tvs, because we are (usually) in debug-style
-       2 (ppr body)
+    sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <> dot,
+          ppr body ]
   where
-    split ty | ForAllTy tv ty' <- ty
-             , (tvs, body) <- split ty'
-             = (tv:tvs, body)
-             | otherwise
-             = ([], ty)
+    -- (ppr tv) will print the binder kind-annotated
+    -- when in debug-style
+    ppr_bndr (Bndr tv InferredSpec)  = braces (ppr tv)
+    ppr_bndr (Bndr tv SpecifiedSpec) = ppr tv
+
+-- Visible forall:  forall x y -> t
+debug_ppr_ty prec t
+  | (bndrs, body) <- splitForAllTysReq t
+  , not (null bndrs)
+  = maybeParen prec funPrec $
+    sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <+> arrow,
+          ppr body ]
+  where
+    -- (ppr tv) will print the binder kind-annotated
+    -- when in debug-style
+    ppr_bndr (Bndr tv ()) = ppr tv
+
+-- Impossible case: neither visible nor invisible forall.
+debug_ppr_ty _ ForAllTy{}
+  = panic "debug_ppr_ty: neither splitForAllTysInvis nor splitForAllTysReq returned any binders"
 
 {-
 Note [Infix type variables]


=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -534,7 +534,7 @@ data DynFlags = DynFlags {
   homeUnitInstantiations:: [(ModuleName, Module)], -- ^ How to instantiate `homeUnitInstanceOfId` unit
 
   -- ways
-  ways                  :: Set Way,     -- ^ Way flags from the command line
+  ways                  :: Ways,         -- ^ Way flags from the command line
 
   -- For object splitting
   splitInfo             :: Maybe (String,Int),
@@ -1433,7 +1433,7 @@ defaultDynFlags mySettings llvmConfig =
         cfgWeightInfo = defaultCfgWeights
       }
 
-defaultWays :: Settings -> Set Way
+defaultWays :: Settings -> Ways
 defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings)
                        then Set.singleton WayDyn
                        else Set.empty


=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -441,6 +441,7 @@ splitIfaceSigmaTy ty
     (theta, tau)   = split_rho rho
 
     split_foralls (IfaceForAllTy bndr ty)
+        | isInvisibleArgFlag (binderArgFlag bndr)
         = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) }
     split_foralls rho = ([], rho)
 
@@ -448,6 +449,12 @@ splitIfaceSigmaTy ty
         = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
     split_rho tau = ([], tau)
 
+splitIfaceReqForallTy :: IfaceType -> ([IfaceForAllBndr], IfaceType)
+splitIfaceReqForallTy (IfaceForAllTy bndr ty)
+  | isVisibleArgFlag (binderArgFlag bndr)
+  = case splitIfaceReqForallTy ty of { (bndrs, rho) -> (bndr:bndrs, rho) }
+splitIfaceReqForallTy rho = ([], rho)
+
 suppressIfaceInvisibles :: PrintExplicitKinds -> [IfaceTyConBinder] -> [a] -> [a]
 suppressIfaceInvisibles (PrintExplicitKinds True) _tys xs = xs
 suppressIfaceInvisibles (PrintExplicitKinds False) tys xs = suppress tys xs
@@ -1184,8 +1191,23 @@ pprIfaceSigmaType show_forall ty
   = hideNonStandardTypes ppr_fn ty
   where
     ppr_fn iface_ty =
-      let (tvs, theta, tau) = splitIfaceSigmaTy iface_ty
-       in ppr_iface_forall_part show_forall tvs theta (ppr tau)
+      let (invis_tvs, theta, tau) = splitIfaceSigmaTy iface_ty
+          (req_tvs, tau') = splitIfaceReqForallTy tau
+          -- splitIfaceSigmaTy is recursive, so it will gather the binders after
+          -- the theta, i.e.  forall a. theta => forall b. tau
+          -- will give you    ([a,b], theta, tau).
+          --
+          -- This isn't right when it comes to visible forall (see
+          --  testsuite/tests/polykinds/T18522-ppr),
+          -- so we split off required binders separately,
+          -- using splitIfaceReqForallTy.
+          --
+          -- An alternative solution would be to make splitIfaceSigmaTy
+          -- non-recursive (see #18458).
+          -- Then it could handle both invisible and required binders, and
+          -- splitIfaceReqForallTy wouldn't be necessary here.
+       in ppr_iface_forall_part show_forall invis_tvs theta $
+          sep [pprIfaceForAll req_tvs, ppr tau']
 
 pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc
 pprUserIfaceForAll tvs


=====================================
compiler/GHC/Parser.y
=====================================
@@ -1080,7 +1080,7 @@ topdecl :: { LHsDecl GhcPs }
         -- The $(..) form is one possible form of infixexp
         -- but we treat an arbitrary expression just as if
         -- it had a $(..) wrapped around it
-        | infixexp                              {% runECP_P $1 >>= \ $1 ->
+        | infixexp                              {% runPV (unECP $1) >>= \ $1 ->
                                                    return $ sLL $1 $> $ mkSpliceDecl $1 }
 
 -- Type classes
@@ -1528,7 +1528,7 @@ decl_cls  : at_decl_cls                 { $1 }
 
           -- A 'default' signature used with the generic-programming extension
           | 'default' infixexp '::' sigtype
-                    {% runECP_P $2 >>= \ $2 ->
+                    {% runPV (unECP $2) >>= \ $2 ->
                        do { v <- checkValSigLhs $2
                           ; let err = text "in default signature" <> colon <+>
                                       quotes (ppr $2)
@@ -1671,8 +1671,8 @@ rules   :: { OrdList (LRuleDecl GhcPs) }
 
 rule    :: { LRuleDecl GhcPs }
         : STRING rule_activation rule_foralls infixexp '=' exp
-         {%runECP_P $4 >>= \ $4 ->
-           runECP_P $6 >>= \ $6 ->
+         {%runPV (unECP $4) >>= \ $4 ->
+           runPV (unECP $6) >>= \ $6 ->
            ams (sLL $1 $> $ HsRule { rd_ext = noExtField
                                    , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)
                                    , rd_act = (snd $2) `orElse` AlwaysActive
@@ -1800,19 +1800,19 @@ stringlist :: { Located (OrdList (Located StringLiteral)) }
 -----------------------------------------------------------------------------
 -- Annotations
 annotation :: { LHsDecl GhcPs }
-    : '{-# ANN' name_var aexp '#-}'      {% runECP_P $3 >>= \ $3 ->
+    : '{-# ANN' name_var aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->
                                             ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField
                                             (getANN_PRAGs $1)
                                             (ValueAnnProvenance $2) $3))
                                             [mo $1,mc $4] }
 
-    | '{-# ANN' 'type' tycon aexp '#-}'  {% runECP_P $4 >>= \ $4 ->
+    | '{-# ANN' 'type' tycon aexp '#-}'  {% runPV (unECP $4) >>= \ $4 ->
                                             ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField
                                             (getANN_PRAGs $1)
                                             (TypeAnnProvenance $3) $4))
                                             [mo $1,mj AnnType $2,mc $5] }
 
-    | '{-# ANN' 'module' aexp '#-}'      {% runECP_P $3 >>= \ $3 ->
+    | '{-# ANN' 'module' aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->
                                             ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField
                                                 (getANN_PRAGs $1)
                                                  ModuleAnnProvenance $3))
@@ -1966,22 +1966,28 @@ type :: { LHsType GhcPs }
 mult :: { LHsType GhcPs }
         : btype                  { $1 }
 
-
 btype :: { LHsType GhcPs }
-        : tyapps                        {% mergeOps (unLoc $1) }
-
-tyapps :: { Located [Located TyEl] } -- NB: This list is reversed
-        : tyapp                         { sL1 $1 [$1] }
-        | tyapps tyapp                  { sLL $1 $> $ $2 : unLoc $1 }
-
-tyapp :: { Located TyEl }
-        : atype                         { sL1 $1 $ TyElOpd (unLoc $1) }
-
-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
-        | PREFIX_AT atype               { sLL $1 $> $ (TyElKindApp (comb2 $1 $2) $2) }
-
-        | tyop                          { mapLoc TyElOpr $1 }
-        | unpackedness                  { sL1 $1 $ TyElUnpackedness (unLoc $1) }
+        : infixtype                     {% runPV $1 }
+
+infixtype :: { forall b. DisambTD b => PV (Located b) }
+        : ftype                         { $1 }
+        | ftype tyop infixtype          { $1 >>= \ $1 ->
+                                          $3 >>= \ $3 ->
+                                          mkHsOpTyPV $1 $2 $3 }
+        | unpackedness infixtype        { $2 >>= \ $2 ->
+                                          mkUnpackednessPV $1 $2 }
+
+ftype :: { forall b. DisambTD b => PV (Located b) }
+        : atype                         { mkHsAppTyHeadPV $1 }
+        | tyop                          { failOpFewArgs $1 }
+        | ftype tyarg                   { $1 >>= \ $1 ->
+                                          mkHsAppTyPV $1 $2 }
+        | ftype PREFIX_AT tyarg         { $1 >>= \ $1 ->
+                                          mkHsAppKindTyPV $1 (getLoc $2) $3 }
+
+tyarg :: { LHsType GhcPs }
+        : atype                         { $1 }
+        | unpackedness atype            {% addUnpackednessP $1 $2 }
 
 tyop :: { Located RdrName }
         : qtyconop                      { $1 }
@@ -2222,8 +2228,9 @@ forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }
         | {- empty -}                 { noLoc ([], Nothing) }
 
 constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs) }
-        : tyapps                           {% do { c <- mergeDataCon (unLoc $1)
-                                                 ; return $ sL1 $1 c } }
+        : infixtype       {% fmap (mapLoc (\b -> (dataConBuilderCon b,
+                                                  dataConBuilderDetails b)))
+                                  (runPV $1) }
 
 fielddecls :: { [LConDeclField GhcPs] }
         : {- empty -}     { [] }
@@ -2308,7 +2315,7 @@ There's an awkward overlap with a type signature.  Consider
 decl_no_th :: { LHsDecl GhcPs }
         : sigdecl               { $1 }
 
-        | infixexp     opt_sig rhs  {% runECP_P $1 >>= \ $1 ->
+        | infixexp     opt_sig rhs  {% runPV (unECP $1) >>= \ $1 ->
                                        do { (ann,r) <- checkValDef $1 (snd $2) $3;
                                         let { l = comb2 $1 $> };
                                         -- Depending upon what the pattern looks like we might get either
@@ -2332,7 +2339,7 @@ decl    :: { LHsDecl GhcPs }
         | splice_exp            { sLL $1 $> $ mkSpliceDecl $1 }
 
 rhs     :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) }
-        : '=' exp wherebinds    {% runECP_P $2 >>= \ $2 -> return $
+        : '=' exp wherebinds    {% runPV (unECP $2) >>= \ $2 -> return $
                                   sL (comb3 $1 $2 $3)
                                     ((mj AnnEqual $1 : (fst $ unLoc $3))
                                     ,GRHSs noExtField (unguardedRHS (comb3 $1 $2 $3) $2)
@@ -2346,7 +2353,7 @@ gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
         | gdrh                  { sL1 $1 [$1] }
 
 gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }
-        : '|' guardquals '=' exp  {% runECP_P $4 >>= \ $4 ->
+        : '|' guardquals '=' exp  {% runPV (unECP $4) >>= \ $4 ->
                                      ams (sL (comb2 $1 $>) $ GRHS noExtField (unLoc $2) $4)
                                          [mj AnnVbar $1,mj AnnEqual $3] }
 
@@ -2354,7 +2361,7 @@ sigdecl :: { LHsDecl GhcPs }
         :
         -- See Note [Declaration/signature overlap] for why we need infixexp here
           infixexp     '::' sigtype
-                        {% do { $1 <- runECP_P $1
+                        {% do { $1 <- runPV (unECP $1)
                               ; v <- checkValSigLhs $1
                               ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2]
                               ; return (sLL $1 $> $ SigD noExtField $
@@ -2450,30 +2457,30 @@ quasiquote :: { Located (HsSplice GhcPs) }
 exp   :: { ECP }
         : infixexp '::' sigtype
                                 { ECP $
-                                   runECP_PV $1 >>= \ $1 ->
+                                   unECP $1 >>= \ $1 ->
                                    rejectPragmaPV $1 >>
                                    amms (mkHsTySigPV (comb2 $1 $>) $1 $3)
                                        [mu AnnDcolon $2] }
-        | infixexp '-<' exp     {% runECP_P $1 >>= \ $1 ->
-                                   runECP_P $3 >>= \ $3 ->
+        | infixexp '-<' exp     {% runPV (unECP $1) >>= \ $1 ->
+                                   runPV (unECP $3) >>= \ $3 ->
                                    fmap ecpFromCmd $
                                    ams (sLL $1 $> $ HsCmdArrApp noExtField $1 $3
                                                         HsFirstOrderApp True)
                                        [mu Annlarrowtail $2] }
-        | infixexp '>-' exp     {% runECP_P $1 >>= \ $1 ->
-                                   runECP_P $3 >>= \ $3 ->
+        | infixexp '>-' exp     {% runPV (unECP $1) >>= \ $1 ->
+                                   runPV (unECP $3) >>= \ $3 ->
                                    fmap ecpFromCmd $
                                    ams (sLL $1 $> $ HsCmdArrApp noExtField $3 $1
                                                       HsFirstOrderApp False)
                                        [mu Annrarrowtail $2] }
-        | infixexp '-<<' exp    {% runECP_P $1 >>= \ $1 ->
-                                   runECP_P $3 >>= \ $3 ->
+        | infixexp '-<<' exp    {% runPV (unECP $1) >>= \ $1 ->
+                                   runPV (unECP $3) >>= \ $3 ->
                                    fmap ecpFromCmd $
                                    ams (sLL $1 $> $ HsCmdArrApp noExtField $1 $3
                                                       HsHigherOrderApp True)
                                        [mu AnnLarrowtail $2] }
-        | infixexp '>>-' exp    {% runECP_P $1 >>= \ $1 ->
-                                   runECP_P $3 >>= \ $3 ->
+        | infixexp '>>-' exp    {% runPV (unECP $1) >>= \ $1 ->
+                                   runPV (unECP $3) >>= \ $3 ->
                                    fmap ecpFromCmd $
                                    ams (sLL $1 $> $ HsCmdArrApp noExtField $3 $1
                                                       HsHigherOrderApp False)
@@ -2487,8 +2494,8 @@ infixexp :: { ECP }
                                { ECP $
                                  superInfixOp $
                                  $2 >>= \ $2 ->
-                                 runECP_PV $1 >>= \ $1 ->
-                                 runECP_PV $3 >>= \ $3 ->
+                                 unECP $1 >>= \ $1 ->
+                                 unECP $3 >>= \ $3 ->
                                  rejectPragmaPV $1 >>
                                  amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3)
                                      [mj AnnVal $2] }
@@ -2500,14 +2507,14 @@ exp10p :: { ECP }
 
 exp_prag(e) :: { ECP }
   : prag_e e  -- See Note [Pragmas and operator fixity]
-      {% runECP_P $2 >>= \ $2 ->
+      {% runPV (unECP $2) >>= \ $2 ->
          fmap ecpFromExp $
          ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2)
              (fst $ unLoc $1) }
 
 exp10 :: { ECP }
         : '-' fexp                      { ECP $
-                                           runECP_PV $2 >>= \ $2 ->
+                                           unECP $2 >>= \ $2 ->
                                            amms (mkHsNegAppPV (comb2 $1 $>) $2)
                                                [mj AnnMinus $1] }
         | fexp                         { $1 }
@@ -2590,16 +2597,16 @@ prag_e :: { Located ([AddAnn], HsPragE GhcPs) }
 fexp    :: { ECP }
         : fexp aexp                  { ECP $
                                           superFunArg $
-                                          runECP_PV $1 >>= \ $1 ->
-                                          runECP_PV $2 >>= \ $2 ->
+                                          unECP $1 >>= \ $1 ->
+                                          unECP $2 >>= \ $2 ->
                                           mkHsAppPV (comb2 $1 $>) $1 $2 }
 
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
         | fexp PREFIX_AT atype       { ECP $
-                                        runECP_PV $1 >>= \ $1 ->
+                                        unECP $1 >>= \ $1 ->
                                         amms (mkHsAppTypePV (comb2 $1 $>) $1 $3) [mj AnnAt $2] }
 
-        | 'static' aexp              {% runECP_P $2 >>= \ $2 ->
+        | 'static' aexp              {% runPV (unECP $2) >>= \ $2 ->
                                         fmap ecpFromExp $
                                         ams (sLL $1 $> $ HsStatic noExtField $2)
                                             [mj AnnStatic $1] }
@@ -2609,23 +2616,23 @@ aexp    :: { ECP }
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
         : qvar TIGHT_INFIX_AT aexp
                                 { ECP $
-                                   runECP_PV $3 >>= \ $3 ->
+                                   unECP $3 >>= \ $3 ->
                                    amms (mkHsAsPatPV (comb2 $1 $>) $1 $3) [mj AnnAt $2] }
 
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
         | PREFIX_TILDE aexp     { ECP $
-                                   runECP_PV $2 >>= \ $2 ->
+                                   unECP $2 >>= \ $2 ->
                                    amms (mkHsLazyPatPV (comb2 $1 $>) $2) [mj AnnTilde $1] }
         | PREFIX_BANG aexp      { ECP $
-                                   runECP_PV $2 >>= \ $2 ->
+                                   unECP $2 >>= \ $2 ->
                                    amms (mkHsBangPatPV (comb2 $1 $>) $2) [mj AnnBang $1] }
         | PREFIX_MINUS aexp     { ECP $
-                                   runECP_PV $2 >>= \ $2 ->
+                                   unECP $2 >>= \ $2 ->
                                    amms (mkHsNegAppPV (comb2 $1 $>) $2) [mj AnnMinus $1] }
 
         | '\\' apat apats '->' exp
                    {  ECP $
-                      runECP_PV $5 >>= \ $5 ->
+                      unECP $5 >>= \ $5 ->
                       amms (mkHsLamPV (comb2 $1 $>) (mkMatchGroup FromSource
                             [sLL $1 $> $ Match { m_ext = noExtField
                                                , m_ctxt = LambdaExpr
@@ -2633,7 +2640,7 @@ aexp    :: { ECP }
                                                , m_grhss = unguardedGRHSs $5 }]))
                           [mj AnnLam $1, mu AnnRarrow $4] }
         | 'let' binds 'in' exp          {  ECP $
-                                           runECP_PV $4 >>= \ $4 ->
+                                           unECP $4 >>= \ $4 ->
                                            amms (mkHsLetPV (comb2 $1 $>) (snd (unLoc $2)) $4)
                                                (mj AnnLet $1:mj AnnIn $3
                                                  :(fst $ unLoc $2)) }
@@ -2643,10 +2650,10 @@ aexp    :: { ECP }
                                    (mkMatchGroup FromSource (snd $ unLoc $3)))
                     (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }
         | 'if' exp optSemi 'then' exp optSemi 'else' exp
-                         {% runECP_P $2 >>= \ $2 ->
+                         {% runPV (unECP $2) >>= \ $2 ->
                             return $ ECP $
-                              runECP_PV $5 >>= \ $5 ->
-                              runECP_PV $8 >>= \ $8 ->
+                              unECP $5 >>= \ $5 ->
+                              unECP $8 >>= \ $8 ->
                               amms (mkHsIfPV (comb2 $1 $>) $2 (snd $3) $5 (snd $6) $8)
                                   (mj AnnIf $1:mj AnnThen $4
                                      :mj AnnElse $7
@@ -2657,7 +2664,7 @@ aexp    :: { ECP }
                                            ams (sLL $1 $> $ HsMultiIf noExtField
                                                      (reverse $ snd $ unLoc $2))
                                                (mj AnnIf $1:(fst $ unLoc $2)) }
-        | 'case' exp 'of' altslist    {% runECP_P $2 >>= \ $2 ->
+        | 'case' exp 'of' altslist    {% runPV (unECP $2) >>= \ $2 ->
                                          return $ ECP $
                                            $4 >>= \ $4 ->
                                            amms (mkHsCasePV (comb3 $1 $3 $4) $2 (mkMatchGroup
@@ -2681,8 +2688,8 @@ aexp    :: { ECP }
                                                         (snd $ unLoc $2)))
                                            (mj AnnMdo $1:(fst $ unLoc $2)) }
         | 'proc' aexp '->' exp
-                       {% (checkPattern <=< runECP_P) $2 >>= \ p ->
-                           runECP_P $4 >>= \ $4 at cmd ->
+                       {% (checkPattern <=< runPV) (unECP $2) >>= \ p ->
+                           runPV (unECP $4) >>= \ $4 at cmd ->
                            fmap ecpFromExp $
                            ams (sLL $1 $> $ HsProc noExtField p (sLL $1 $> $ HsCmdTop noExtField cmd))
                                             -- TODO: is LL right here?
@@ -2692,7 +2699,7 @@ aexp    :: { ECP }
 
 aexp1   :: { ECP }
         : aexp1 '{' fbinds '}' { ECP $
-                                  runECP_PV $1 >>= \ $1 ->
+                                  unECP $1 >>= \ $1 ->
                                   $3 >>= \ $3 ->
                                   amms (mkHsRecordPV (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3))
                                        (moc $2:mcc $4:(fst $3)) }
@@ -2716,7 +2723,7 @@ aexp2   :: { ECP }
         -- correct Haskell (you'd have to write '((+ 3), (4 -))')
         -- but the less cluttered version fell out of having texps.
         | '(' texp ')'                  { ECP $
-                                           runECP_PV $2 >>= \ $2 ->
+                                           unECP $2 >>= \ $2 ->
                                            amms (mkHsParPV (comb2 $1 $>) $2) [mop $1,mcp $3] }
         | '(' tup_exprs ')'             { ECP $
                                            $2 >>= \ $2 ->
@@ -2724,7 +2731,7 @@ aexp2   :: { ECP }
                                                 ((mop $1:fst $2) ++ [mcp $3]) }
 
         | '(#' texp '#)'                { ECP $
-                                           runECP_PV $2 >>= \ $2 ->
+                                           unECP $2 >>= \ $2 ->
                                            amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)]))
                                                 [mo $1,mc $3] }
         | '(#' tup_exprs '#)'           { ECP $
@@ -2744,18 +2751,18 @@ aexp2   :: { ECP }
         | TH_TY_QUOTE tyvar     {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
         | TH_TY_QUOTE gtycon    {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
         | TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) }
-        | '[|' exp '|]'       {% runECP_P $2 >>= \ $2 ->
+        | '[|' exp '|]'       {% runPV (unECP $2) >>= \ $2 ->
                                  fmap ecpFromExp $
                                  ams (sLL $1 $> $ HsBracket noExtField (ExpBr noExtField $2))
                                       (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
                                                     else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) }
-        | '[||' exp '||]'     {% runECP_P $2 >>= \ $2 ->
+        | '[||' exp '||]'     {% runPV (unECP $2) >>= \ $2 ->
                                  fmap ecpFromExp $
                                  ams (sLL $1 $> $ HsBracket noExtField (TExpBr noExtField $2))
                                       (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
         | '[t|' ktype '|]'    {% fmap ecpFromExp $
                                  ams (sLL $1 $> $ HsBracket noExtField (TypBr noExtField $2)) [mo $1,mu AnnCloseQ $3] }
-        | '[p|' infixexp '|]' {% (checkPattern <=< runECP_P) $2 >>= \p ->
+        | '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p ->
                                       fmap ecpFromExp $
                                       ams (sLL $1 $> $ HsBracket noExtField (PatBr noExtField p))
                                           [mo $1,mu AnnCloseQ $3] }
@@ -2765,7 +2772,7 @@ aexp2   :: { ECP }
         | quasiquote          { ECP $ mkHsSplicePV $1 }
 
         -- arrow notation extension
-        | '(|' aexp cmdargs '|)'  {% runECP_P $2 >>= \ $2 ->
+        | '(|' aexp cmdargs '|)'  {% runPV (unECP $2) >>= \ $2 ->
                                      fmap ecpFromCmd $
                                      ams (sLL $1 $> $ HsCmdArrForm noExtField $2 Prefix
                                                           Nothing (reverse $3))
@@ -2777,14 +2784,14 @@ splice_exp :: { LHsExpr GhcPs }
 
 splice_untyped :: { Located (HsSplice GhcPs) }
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
-        : PREFIX_DOLLAR aexp2   {% runECP_P $2 >>= \ $2 ->
+        : PREFIX_DOLLAR aexp2   {% runPV (unECP $2) >>= \ $2 ->
                                    ams (sLL $1 $> $ mkUntypedSplice DollarSplice $2)
                                        [mj AnnDollar $1] }
 
 splice_typed :: { Located (HsSplice GhcPs) }
         -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
         : PREFIX_DOLLAR_DOLLAR aexp2
-                                {% runECP_P $2 >>= \ $2 ->
+                                {% runPV (unECP $2) >>= \ $2 ->
                                    ams (sLL $1 $> $ mkTypedSplice DollarSplice $2)
                                        [mj AnnDollarDollar $1] }
 
@@ -2793,7 +2800,7 @@ cmdargs :: { [LHsCmdTop GhcPs] }
         | {- empty -}                   { [] }
 
 acmd    :: { LHsCmdTop GhcPs }
-        : aexp                  {% runECP_P $1 >>= \ cmd ->
+        : aexp                  {% runPV (unECP $1) >>= \ cmd ->
                                    runPV (checkCmdBlockArguments cmd) >>= \ _ ->
                                    return (sL1 cmd $ HsCmdTop noExtField cmd) }
 
@@ -2827,21 +2834,21 @@ texp :: { ECP }
         -- Meanwhile, the renamer checks that real sections appear
         -- inside parens.
         | infixexp qop
-                             {% runECP_P $1 >>= \ $1 ->
+                             {% runPV (unECP $1) >>= \ $1 ->
                                 runPV (rejectPragmaPV $1) >>
                                 runPV $2 >>= \ $2 ->
                                 return $ ecpFromExp $
                                 sLL $1 $> $ SectionL noExtField $1 $2 }
         | qopm infixexp      { ECP $
                                 superInfixOp $
-                                runECP_PV $2 >>= \ $2 ->
+                                unECP $2 >>= \ $2 ->
                                 $1 >>= \ $1 ->
                                 mkHsSectionR_PV (comb2 $1 $>) $1 $2 }
 
        -- View patterns get parenthesized above
         | exp '->' texp   { ECP $
-                             runECP_PV $1 >>= \ $1 ->
-                             runECP_PV $3 >>= \ $3 ->
+                             unECP $1 >>= \ $1 ->
+                             unECP $3 >>= \ $3 ->
                              amms (mkHsViewPatPV (comb2 $1 $>) $1 $3) [mu AnnRarrow $2] }
 
 -- Always at least one comma or bar.
@@ -2850,12 +2857,12 @@ texp :: { ECP }
 -- in GHC.Hs.Expr.
 tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) }
            : texp commas_tup_tail
-                           { runECP_PV $1 >>= \ $1 ->
+                           { unECP $1 >>= \ $1 ->
                              $2 >>= \ $2 ->
                              do { addAnnotation (gl $1) AnnComma (fst $2)
                                 ; return ([],Tuple ((sL1 $1 (Just $1)) : snd $2)) } }
 
-           | texp bars   { runECP_PV $1 >>= \ $1 -> return $
+           | texp bars   { unECP $1 >>= \ $1 -> return $
                             (mvbars (fst $2), Sum 1  (snd $2 + 1) $1) }
 
            | commas tup_tail
@@ -2865,7 +2872,7 @@ tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) }
                            ([],Tuple (map (\l -> L l Nothing) (fst $1) ++ $2)) } }
 
            | bars texp bars0
-                { runECP_PV $2 >>= \ $2 -> return $
+                { unECP $2 >>= \ $2 -> return $
                   (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) }
 
 -- Always starts with commas; always follows an expr
@@ -2879,11 +2886,11 @@ commas_tup_tail : commas tup_tail
 
 -- Always follows a comma
 tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] }
-          : texp commas_tup_tail { runECP_PV $1 >>= \ $1 ->
+          : texp commas_tup_tail { unECP $1 >>= \ $1 ->
                                    $2 >>= \ $2 ->
                                    addAnnotation (gl $1) AnnComma (fst $2) >>
                                    return ((L (gl $1) (Just $1)) : snd $2) }
-          | texp                 { runECP_PV $1 >>= \ $1 ->
+          | texp                 { unECP $1 >>= \ $1 ->
                                    return [L (gl $1) (Just $1)] }
           | {- empty -}          { return [noLoc Nothing] }
 
@@ -2894,48 +2901,48 @@ tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] }
 -- avoiding another shift/reduce-conflict.
 -- Never empty.
 list :: { forall b. DisambECP b => SrcSpan -> PV (Located b) }
-        : texp    { \loc -> runECP_PV $1 >>= \ $1 ->
+        : texp    { \loc -> unECP $1 >>= \ $1 ->
                             mkHsExplicitListPV loc [$1] }
         | lexps   { \loc -> $1 >>= \ $1 ->
                             mkHsExplicitListPV loc (reverse $1) }
-        | texp '..'  { \loc ->    runECP_PV $1 >>= \ $1 ->
+        | texp '..'  { \loc ->    unECP $1 >>= \ $1 ->
                                   ams (L loc $ ArithSeq noExtField Nothing (From $1))
                                       [mj AnnDotdot $2]
                                       >>= ecpFromExp' }
         | texp ',' exp '..' { \loc ->
-                                   runECP_PV $1 >>= \ $1 ->
-                                   runECP_PV $3 >>= \ $3 ->
+                                   unECP $1 >>= \ $1 ->
+                                   unECP $3 >>= \ $3 ->
                                    ams (L loc $ ArithSeq noExtField Nothing (FromThen $1 $3))
                                        [mj AnnComma $2,mj AnnDotdot $4]
                                        >>= ecpFromExp' }
-        | texp '..' exp  { \loc -> runECP_PV $1 >>= \ $1 ->
-                                   runECP_PV $3 >>= \ $3 ->
+        | texp '..' exp  { \loc -> unECP $1 >>= \ $1 ->
+                                   unECP $3 >>= \ $3 ->
                                    ams (L loc $ ArithSeq noExtField Nothing (FromTo $1 $3))
                                        [mj AnnDotdot $2]
                                        >>= ecpFromExp' }
         | texp ',' exp '..' exp { \loc ->
-                                   runECP_PV $1 >>= \ $1 ->
-                                   runECP_PV $3 >>= \ $3 ->
-                                   runECP_PV $5 >>= \ $5 ->
+                                   unECP $1 >>= \ $1 ->
+                                   unECP $3 >>= \ $3 ->
+                                   unECP $5 >>= \ $5 ->
                                    ams (L loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5))
                                        [mj AnnComma $2,mj AnnDotdot $4]
                                        >>= ecpFromExp' }
         | texp '|' flattenedpquals
              { \loc ->
                 checkMonadComp >>= \ ctxt ->
-                runECP_PV $1 >>= \ $1 ->
+                unECP $1 >>= \ $1 ->
                 ams (L loc $ mkHsComp ctxt (unLoc $3) $1)
                     [mj AnnVbar $2]
                     >>= ecpFromExp' }
 
 lexps :: { forall b. DisambECP b => PV [Located b] }
         : lexps ',' texp           { $1 >>= \ $1 ->
-                                     runECP_PV $3 >>= \ $3 ->
+                                     unECP $3 >>= \ $3 ->
                                      addAnnotation (gl $ head $ $1)
                                                             AnnComma (gl $2) >>
                                       return (((:) $! $3) $! $1) }
-        | texp ',' texp             { runECP_PV $1 >>= \ $1 ->
-                                      runECP_PV $3 >>= \ $3 ->
+        | texp ',' texp             { unECP $1 >>= \ $1 ->
+                                      unECP $3 >>= \ $3 ->
                                       addAnnotation (gl $1) AnnComma (gl $2) >>
                                       return [$3,$1] }
 
@@ -2985,20 +2992,20 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }   -- In reverse order, becau
 
 transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) }
                         -- Function is applied to a list of stmts *in order*
-    : 'then' exp              {% runECP_P $2 >>= \ $2 -> return $
+    : 'then' exp              {% runPV (unECP $2) >>= \ $2 -> return $
                                  sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) }
-    | 'then' exp 'by' exp     {% runECP_P $2 >>= \ $2 ->
-                                 runECP_P $4 >>= \ $4 ->
+    | 'then' exp 'by' exp     {% runPV (unECP $2) >>= \ $2 ->
+                                 runPV (unECP $4) >>= \ $4 ->
                                  return $ sLL $1 $> ([mj AnnThen $1,mj AnnBy  $3],
                                                      \ss -> (mkTransformByStmt ss $2 $4)) }
     | 'then' 'group' 'using' exp
-            {% runECP_P $4 >>= \ $4 ->
+            {% runPV (unECP $4) >>= \ $4 ->
                return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3],
                                    \ss -> (mkGroupUsingStmt ss $4)) }
 
     | 'then' 'group' 'by' exp 'using' exp
-            {% runECP_P $4 >>= \ $4 ->
-               runECP_P $6 >>= \ $6 ->
+            {% runPV (unECP $4) >>= \ $4 ->
+               runPV (unECP $6) >>= \ $6 ->
                return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5],
                                    \ss -> (mkGroupByUsingStmt ss $4 $6)) }
 
@@ -3072,7 +3079,7 @@ alt_rhs :: { forall b. DisambECP b => PV (Located ([AddAnn],GRHSs GhcPs (Located
                                       return $ sLL alt $> (fst $ unLoc $2, GRHSs noExtField (unLoc alt) (snd $ unLoc $2)) }
 
 ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) }
-        : '->' exp            { runECP_PV $2 >>= \ $2 ->
+        : '->' exp            { unECP $2 >>= \ $2 ->
                                 ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
                                     [mu AnnRarrow $1] }
         | gdpats              { $1 >>= \gdpats ->
@@ -3095,7 +3102,7 @@ ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }
 
 gdpat   :: { forall b. DisambECP b => PV (LGRHS GhcPs (Located b)) }
         : '|' guardquals '->' exp
-                                   { runECP_PV $4 >>= \ $4 ->
+                                   { unECP $4 >>= \ $4 ->
                                      ams (sL (comb2 $1 $>) $ GRHS noExtField (unLoc $2) $4)
                                          [mj AnnVbar $1,mu AnnRarrow $3] }
 
@@ -3104,15 +3111,15 @@ gdpat   :: { forall b. DisambECP b => PV (LGRHS GhcPs (Located b)) }
 -- Bangs inside are parsed as infix operator applications, so that
 -- we parse them right when bang-patterns are off
 pat     :: { LPat GhcPs }
-pat     :  exp          {% (checkPattern <=< runECP_P) $1 }
+pat     :  exp          {% (checkPattern <=< runPV) (unECP $1) }
 
 bindpat :: { LPat GhcPs }
-bindpat :  exp            {% -- See Note [Parser-Validator ReaderT SDoc] in GHC.Parser.PostProcess
+bindpat :  exp            {% -- See Note [Parser-Validator Hint] in GHC.Parser.PostProcess
                              checkPattern_msg (text "Possibly caused by a missing 'do'?")
-                                              (runECP_PV $1) }
+                                              (unECP $1) }
 
 apat   :: { LPat GhcPs }
-apat    : aexp                  {% (checkPattern <=< runECP_P) $1 }
+apat    : aexp                  {% (checkPattern <=< runPV) (unECP $1) }
 
 apats  :: { [LPat GhcPs] }
         : apat apats            { $1 : $2 }
@@ -3175,10 +3182,10 @@ stmt  :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }
                                                (mj AnnRec $1:(fst $ unLoc $2)) }
 
 qual  :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }
-    : bindpat '<-' exp                   { runECP_PV $3 >>= \ $3 ->
+    : bindpat '<-' exp                   { unECP $3 >>= \ $3 ->
                                            ams (sLL $1 $> $ mkPsBindStmt $1 $3)
                                                [mu AnnLarrow $2] }
-    | exp                                { runECP_PV $1 >>= \ $1 ->
+    | exp                                { unECP $1 >>= \ $1 ->
                                            return $ sL1 $1 $ mkBodyStmt $1 }
     | 'let' binds                        { ams (sLL $1 $> $ LetStmt noExtField (snd $ unLoc $2))
                                                (mj AnnLet $1:(fst $ unLoc $2)) }
@@ -3201,7 +3208,7 @@ fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located
         | '..'                          { return ([mj AnnDotdot $1],([],   Just (getLoc $1))) }
 
 fbind   :: { forall b. DisambECP b => PV (LHsRecField GhcPs (Located b)) }
-        : qvar '=' texp  { runECP_PV $3 >>= \ $3 ->
+        : qvar '=' texp  { unECP $3 >>= \ $3 ->
                            ams  (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False)
                                 [mj AnnEqual $2] }
                         -- RHS is a 'texp', allowing view patterns (#6038)
@@ -3227,7 +3234,7 @@ dbinds  :: { Located [LIPBind GhcPs] }
 --      | {- empty -}                  { [] }
 
 dbind   :: { LIPBind GhcPs }
-dbind   : ipvar '=' exp                {% runECP_P $3 >>= \ $3 ->
+dbind   : ipvar '=' exp                {% runPV (unECP $3) >>= \ $3 ->
                                           ams (sLL $1 $> (IPBind noExtField (Left $1) $3))
                                               [mj AnnEqual $2] }
 


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -68,7 +68,6 @@ module GHC.Parser.PostProcess (
         checkRecordSyntax,
         checkEmptyGADTs,
         addFatalError, hintBangPat,
-        TyEl(..), mergeOps, mergeDataCon,
         mkBangTy,
         UnpackednessPragma(..),
 
@@ -96,13 +95,19 @@ module GHC.Parser.PostProcess (
         -- Expression/command/pattern ambiguity resolution
         PV,
         runPV,
-        ECP(ECP, runECP_PV),
-        runECP_P,
+        ECP(ECP, unECP),
         DisambInfixOp(..),
         DisambECP(..),
         ecpFromExp,
         ecpFromCmd,
-        PatBuilder
+        PatBuilder,
+
+        -- Type/datacon ambiguity resolution
+        DisambTD(..),
+        addUnpackednessP,
+        DataConBuilder(),
+        dataConBuilderCon,
+        dataConBuilderDetails,
     ) where
 
 import GHC.Prelude
@@ -126,20 +131,20 @@ import GHC.Types.ForeignCall
 import GHC.Builtin.Names ( allNameStrings )
 import GHC.Types.SrcLoc
 import GHC.Types.Unique ( hasKey )
-import GHC.Data.OrdList ( OrdList, fromOL )
+import GHC.Data.OrdList
 import GHC.Utils.Outputable as Outputable
 import GHC.Data.FastString
 import GHC.Data.Maybe
 import GHC.Utils.Misc
 import GHC.Parser.Annotation
 import Data.List
+import Data.Foldable
 import GHC.Driver.Session ( WarningFlag(..), DynFlags )
 import GHC.Utils.Error ( Messages )
 
 import Control.Monad
 import Text.ParserCombinators.ReadP as ReadP
 import Data.Char
-import qualified Data.Monoid as Monoid
 import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
 import Data.Kind       ( Type )
 
@@ -559,30 +564,6 @@ context, so (C t1 t2) is a constraint and 'C' is a type constructor.
 As the result, in order to determine whether (C t1 t2) declares a data
 constructor, a type, or a context, we would need unlimited lookahead which
 'happy' is not so happy with.
-
-The solution that accounts for all of these issues is to initially parse data
-declarations and types as a reversed list of TyEl:
-
-  data TyEl = TyElOpr RdrName
-            | TyElOpd (HsType GhcPs)
-            | ...
-
-For example, both occurrences of (C ! D) in the following example are parsed
-into equal lists of TyEl:
-
-  data T = C ! D => C ! D   results in   [ TyElOpd (HsTyVar "D")
-                                         , TyElOpr "!"
-                                         , TyElOpd (HsTyVar "C") ]
-
-Note that elements are in reverse order. Also, 'C' is parsed as a type
-constructor (HsTyVar) even when it is a data constructor. We fix this in
-`tyConToDataCon`.
-
-By the time the list of TyEl is assembled, we have looked ahead enough to
-decide whether to reduce using `mergeOps` (for types) or `mergeDataCon` (for
-data constructors). These functions are where the actual job of parsing is
-done.
-
 -}
 
 -- | Reinterpret a type constructor, including type operators, as a data
@@ -798,7 +779,7 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It
 really doesn't matter!
 -}
 
-eitherToP :: Either (SrcSpan, SDoc) a -> P a
+eitherToP :: MonadP m => Either (SrcSpan, SDoc) a -> m a
 -- Adapts the Either monad to the P monad
 eitherToP (Left (loc, doc)) = addFatalError loc doc
 eitherToP (Right thing)     = return thing
@@ -1309,323 +1290,31 @@ isFunLhs e = go e [] []
                  _ -> return Nothing }
    go _ _ _ = return Nothing
 
--- | Either an operator or an operand.
-data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
-          | TyElKindApp SrcSpan (LHsType GhcPs)
-          -- See Note [TyElKindApp SrcSpan interpretation]
-          | TyElUnpackedness UnpackednessPragma
-
-
-{- Note [TyElKindApp SrcSpan interpretation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-A TyElKindApp captures type application written in haskell as
-
-    @ Foo
-
-where Foo is some type.
-
-The SrcSpan reflects both elements, and there are AnnAt and AnnVal API
-Annotations attached to this SrcSpan for the specific locations of
-each within it.
--}
-
-instance Outputable TyEl where
-  ppr (TyElOpr name) = ppr name
-  ppr (TyElOpd ty) = ppr ty
-  ppr (TyElKindApp _ ki) = text "@" <> ppr ki
-  ppr (TyElUnpackedness (UnpackednessPragma _ _ unpk)) = ppr unpk
-
--- | Extract a strictness/unpackedness annotation from the front of a reversed
--- 'TyEl' list.
-pUnpackedness
-  :: [Located TyEl] -- reversed TyEl
-  -> Maybe (SrcSpan, UnpackednessPragma,
-            [Located TyEl] {- remaining TyEl -})
-pUnpackedness (L l x1 : xs) | TyElUnpackedness up <- x1 = Just (l, up, xs)
-pUnpackedness _ = Nothing
-
-pBangTy
-  :: LHsType GhcPs  -- a type to be wrapped inside HsBangTy
-  -> [Located TyEl] -- reversed TyEl
-  -> ( Bool           {- has a strict mark been consumed? -}
-     , LHsType GhcPs  {- the resulting BangTy -}
-     , P ()           {- add annotations -}
-     , [Located TyEl] {- remaining TyEl -})
-pBangTy lt@(L l1 _) xs =
-  case pUnpackedness xs of
-    Nothing -> (False, lt, pure (), xs)
-    Just (l2, UnpackednessPragma anns prag unpk, xs') ->
-      let bl = combineSrcSpans l1 l2
-          bt = addUnpackedness (prag, unpk) lt
-      in (True, L bl bt, addAnnsAt bl anns, xs')
-
 mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs
 mkBangTy strictness =
   HsBangTy noExtField (HsSrcBang NoSourceText NoSrcUnpack strictness)
 
--- Result of parsing {-# UNPACK #-} or {-# NOUNPACK #-}
+-- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.
 data UnpackednessPragma =
   UnpackednessPragma [AddAnn] SourceText SrcUnpackedness
 
-addUnpackedness :: (SourceText, SrcUnpackedness) -> LHsType GhcPs -> HsType GhcPs
-addUnpackedness (prag, unpk) (L _ (HsBangTy x bang t))
-  | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang
-  = HsBangTy x (HsSrcBang prag unpk strictness) t
-addUnpackedness (prag, unpk) t
-  = HsBangTy noExtField (HsSrcBang prag unpk NoSrcStrict) t
-
--- | Merge a /reversed/ and /non-empty/ soup of operators and operands
---   into a type.
---
--- User input: @F x y + G a b * X@
--- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F]
--- Output corresponds to what the user wrote assuming all operators are of the
--- same fixity and right-associative.
---
--- It's a bit silly that we're doing it at all, as the renamer will have to
--- rearrange this, and it'd be easier to keep things separate.
---
--- See Note [Parsing data constructors is hard]
-mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
-mergeOps ((L l1 (TyElOpd t)) : xs)
-  | (_, t', addAnns, xs') <- pBangTy (L l1 t) xs
-  , null xs' -- We accept a BangTy only when there are no preceding TyEl.
-  = addAnns >> return t'
-mergeOps all_xs = go (0 :: Int) [] id all_xs
-  where
-    -- NB. When modifying clauses in 'go', make sure that the reasoning in
-    -- Note [Non-empty 'acc' in mergeOps clause [end]] is still correct.
-
-    -- clause [unpk]:
-    -- handle (NO)UNPACK pragmas
-    go k acc ops_acc ((L l (TyElUnpackedness (UnpackednessPragma anns unpkSrc unpk))):xs) =
-      if not (null acc) && null xs
-      then do { acc' <- eitherToP $ mergeOpsAcc acc
-              ; let a = ops_acc acc'
-                    strictMark = HsSrcBang unpkSrc unpk NoSrcStrict
-                    bl = combineSrcSpans l (getLoc a)
-                    bt = HsBangTy noExtField strictMark a
-              ; addAnnsAt bl anns
-              ; return (L bl bt) }
-      else addFatalError l unpkError
-      where
-        unpkSDoc = case unpkSrc of
-          NoSourceText -> ppr unpk
-          SourceText str -> text str <> text " #-}"
-        unpkError
-          | not (null xs) = unpkSDoc <+> text "cannot appear inside a type."
-          | null acc && k == 0 = unpkSDoc <+> text "must be applied to a type."
-          | otherwise =
-              -- See Note [Impossible case in mergeOps clause [unpk]]
-              panic "mergeOps.UNPACK: impossible position"
-
-    -- clause [opr]:
-    -- when we encounter an operator, we must have accumulated
-    -- something for its rhs, and there must be something left
-    -- to build its lhs.
-    go k acc ops_acc ((L l (TyElOpr op)):xs) =
-      if null acc || null (filter isTyElOpd xs)
-        then failOpFewArgs (L l op)
-        else do { acc' <- eitherToP (mergeOpsAcc acc)
-                ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc acc')) xs }
-      where
-        isTyElOpd (L _ (TyElOpd _)) = True
-        isTyElOpd _ = False
-
-    -- clause [opd]:
-    -- whenever an operand is encountered, it is added to the accumulator
-    go k acc ops_acc ((L l (TyElOpd a)):xs) = go k (HsValArg (L l a):acc) ops_acc xs
-
-    -- clause [tyapp]:
-    -- whenever a type application is encountered, it is added to the accumulator
-    go k acc ops_acc ((L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs
-
-    -- clause [end]
-    -- See Note [Non-empty 'acc' in mergeOps clause [end]]
-    go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc)
-                             ; return (ops_acc acc') }
-
-mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-         -> Either (SrcSpan, SDoc) (LHsType GhcPs)
-mergeOpsAcc [] = panic "mergeOpsAcc: empty input"
-mergeOpsAcc (HsTypeArg _ (L loc ki):_)
-  = Left (loc, text "Unexpected type application:" <+> ppr ki)
-mergeOpsAcc (HsValArg ty : xs) = go1 ty xs
-  where
-    go1 :: LHsType GhcPs
-        -> [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-        -> Either (SrcSpan, SDoc) (LHsType GhcPs)
-    go1 lhs []     = Right lhs
-    go1 lhs (x:xs) = case x of
-        HsValArg ty -> go1 (mkHsAppTy lhs ty) xs
-        HsTypeArg loc ki -> let ty = mkHsAppKindTy loc lhs ki
-                            in go1 ty xs
-        HsArgPar _ -> go1 lhs xs
-mergeOpsAcc (HsArgPar _: xs) = mergeOpsAcc xs
-
-{- Note [Impossible case in mergeOps clause [unpk]]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This case should never occur. Let us consider all possible
-variations of 'acc', 'xs', and 'k':
-
-  acc          xs        k
-==============================
-  null   |    null       0      -- "must be applied to a type"
-  null   |  not null     0      -- "must be applied to a type"
-not null |    null       0      -- successful parse
-not null |  not null     0      -- "cannot appear inside a type"
-  null   |    null      >0      -- handled in clause [opr]
-  null   |  not null    >0      -- "cannot appear inside a type"
-not null |    null      >0      -- successful parse
-not null |  not null    >0      -- "cannot appear inside a type"
-
-The (null acc && null xs && k>0) case is handled in clause [opr]
-by the following check:
-
-    if ... || null (filter isTyElOpd xs)
-     then failOpFewArgs (L l op)
-
-We know that this check has been performed because k>0, and by
-the time we reach the end of the list (null xs), the only way
-for (null acc) to hold is that there was not a single TyElOpd
-between the operator and the end of the list. But this case is
-caught by the check and reported as 'failOpFewArgs'.
--}
-
-{- Note [Non-empty 'acc' in mergeOps clause [end]]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In clause [end] we need to know that 'acc' is non-empty to call 'mergeAcc'
-without a check.
-
-Running 'mergeOps' with an empty input list is forbidden, so we do not consider
-this possibility. This means we'll hit at least one other clause before we
-reach clause [end].
-
-* Clauses [unpk] and [doc] do not call 'go' recursively, so we cannot hit
-  clause [end] from there.
-* Clause [opd] makes 'acc' non-empty, so if we hit clause [end] after it, 'acc'
-  will be non-empty.
-* Clause [opr] checks that (filter isTyElOpd xs) is not null - so we are going
-  to hit clause [opd] at least once before we reach clause [end], making 'acc'
-  non-empty.
-* There are no other clauses.
-
-Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause
-[end].
-
--}
-
-pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
-pInfixSide ((L l (TyElOpd t)):xs)
-  | (True, t', addAnns, xs') <- pBangTy (L l t) xs
-  = Just (t', addAnns, xs')
-pInfixSide (el:xs1)
-  | Just t1 <- pLHsTypeArg el
-  = go [t1] xs1
-   where
-     go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
-        -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])
-     go acc (el:xs)
-       | Just t <- pLHsTypeArg el
-       = go (t:acc) xs
-     go acc xs = case mergeOpsAcc acc of
-       Left _ -> Nothing
-       Right acc' -> Just (acc', pure (), xs)
-pInfixSide _ = Nothing
-
-pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs))
-pLHsTypeArg (L l (TyElOpd a)) = Just (HsValArg (L l a))
-pLHsTypeArg (L _ (TyElKindApp l a)) = Just (HsTypeArg l a)
-pLHsTypeArg _ = Nothing
-
-orErr :: Maybe a -> b -> Either b a
-orErr (Just a) _ = Right a
-orErr Nothing b = Left b
-
--- | Merge a /reversed/ and /non-empty/ soup of operators and operands
---   into a data constructor.
---
--- User input: @C !A B -- ^ doc@
--- Input to 'mergeDataCon': ["doc", B, !A, C]
--- Output: (C, PrefixCon [!A, B], "doc")
---
--- See Note [Parsing data constructors is hard]
-mergeDataCon
-      :: [Located TyEl]
-      -> P ( Located RdrName         -- constructor name
-           , HsConDeclDetails GhcPs  -- constructor field information
-           )
-mergeDataCon all_xs =
-  do { (addAnns, a) <- eitherToP res
-     ; addAnns
-     ; return a }
+-- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma.
+addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)
+addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do
+    let l' = combineSrcSpans lprag (getLoc ty)
+        t' = addUnpackedness ty
+    addAnnsAt l' anns
+    return (L l' t')
   where
-    -- The result of merging the list of reversed TyEl into a
-    -- data constructor, along with [AddAnn].
-    res = goFirst all_xs
-
-    goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
-      = do { data_con <- tyConToDataCon l tc
-           ; return (pure (), (data_con, PrefixCon [])) }
-    goFirst ((L l (TyElOpd (HsRecTy _ fields))):xs)
-      | [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs
-      = do { data_con <- tyConToDataCon l' tc
-           ; return (pure (), (data_con, RecCon (L l fields))) }
-    goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]
-      = return ( pure ()
-               , ( L l (getRdrName (tupleDataCon Boxed (length ts)))
-                 , PrefixCon (map hsLinear ts) ) )
-    goFirst ((L l (TyElOpd t)):xs)
-      | (_, t', addAnns, xs') <- pBangTy (L l t) xs
-      = go addAnns [t'] xs'
-    goFirst (L l (TyElKindApp _ _):_)
-      = goInfix Monoid.<> Left (l, kindAppErr)
-    goFirst xs
-      = go (pure ()) [] xs
-
-    go addAnns ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]
-      = do { data_con <- tyConToDataCon l tc
-           ; return (addAnns, (data_con, PrefixCon (map hsLinear ts))) }
-    go addAnns ts ((L l (TyElOpd t)):xs)
-      | (_, t', addAnns', xs') <- pBangTy (L l t) xs
-      = go (addAnns >> addAnns') (t':ts) xs'
-    go _ _ ((L _ (TyElOpr _)):_) =
-      -- Encountered an operator: backtrack to the beginning and attempt
-      -- to parse as an infix definition.
-      goInfix
-    go _ _ (L l (TyElKindApp _ _):_) =  goInfix Monoid.<> Left (l, kindAppErr)
-    go _ _ _ = Left malformedErr
-      where
-        malformedErr =
-          ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs)
-          , text "Cannot parse data constructor" <+>
-            text "in a data/newtype declaration:" $$
-            nest 2 (hsep . reverse $ map ppr all_xs))
-
-    goInfix =
-      do { let xs0 = all_xs
-         ; (rhs, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr
-         ; (op, xs3) <- case xs1 of
-              (L l (TyElOpr op)) : xs3 ->
-                do { data_con <- tyConToDataCon l op
-                   ; return (data_con, xs3) }
-              _ -> Left malformedErr
-         ; (lhs, lhs_addAnns, xs5) <- pInfixSide xs3 `orErr` malformedErr
-         ; unless (null xs5) (Left malformedErr)
-         ; let addAnns = lhs_addAnns >> rhs_addAnns
-         ; return (addAnns, (op, InfixCon (hsLinear lhs) (hsLinear rhs))) }
-      where
-        malformedErr =
-          ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs)
-          , text "Cannot parse an infix data constructor" <+>
-            text "in a data/newtype declaration:" $$
-            nest 2 (hsep . reverse $ map ppr all_xs))
-
-    kindAppErr =
-      text "Unexpected kind application" <+>
-      text "in a data/newtype declaration:" $$
-      nest 2 (hsep . reverse $ map ppr all_xs)
+    -- If we have a HsBangTy that only has a strictness annotation,
+    -- such as ~T or !T, then add the pragma to the existing HsBangTy.
+    --
+    -- Otherwise, wrap the type in a new HsBangTy constructor.
+    addUnpackedness (L _ (HsBangTy x bang t))
+      | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang
+      = HsBangTy x (HsSrcBang prag unpk strictness) t
+    addUnpackedness t
+      = HsBangTy noExtField (HsSrcBang prag unpk NoSrcStrict) t
 
 ---------------------------------------------------------------------------
 -- | Check for monad comprehensions
@@ -1645,7 +1334,6 @@ checkMonadComp = do
 -- See Note [Ambiguous syntactic categories]
 --
 
--- See Note [Parser-Validator]
 -- See Note [Ambiguous syntactic categories]
 --
 -- This newtype is required to avoid impredicative types in monadic
@@ -1659,10 +1347,7 @@ checkMonadComp = do
 --    P (forall b. DisambECP b => PV (Located b))
 --
 newtype ECP =
-  ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) }
-
-runECP_P :: DisambECP b => ECP -> P (Located b)
-runECP_P p = runPV (runECP_PV p)
+  ECP { unECP :: forall b. DisambECP b => PV (Located b) }
 
 ecpFromExp :: LHsExpr GhcPs -> ECP
 ecpFromExp a = ECP (ecpFromExp' a)
@@ -2053,9 +1738,145 @@ mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd)
 mkPatRec p _ =
   addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p
 
+-- | Disambiguate constructs that may appear when we do not know
+-- ahead of time whether we are parsing a type or a newtype/data constructor.
+--
+-- See Note [Ambiguous syntactic categories] for the general idea.
+--
+-- See Note [Parsing data constructors is hard] for the specific issue this
+-- particular class is solving.
+--
+class DisambTD b where
+  -- | Process the head of a type-level function/constructor application,
+  -- i.e. the @H@ in @H a b c at .
+  mkHsAppTyHeadPV :: LHsType GhcPs -> PV (Located b)
+  -- | Disambiguate @f x@ (function application or prefix data constructor).
+  mkHsAppTyPV :: Located b -> LHsType GhcPs -> PV (Located b)
+  -- | Disambiguate @f \@t@ (visible kind application)
+  mkHsAppKindTyPV :: Located b -> SrcSpan -> LHsType GhcPs -> PV (Located b)
+  -- | Disambiguate @f \# x@ (infix operator)
+  mkHsOpTyPV :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> PV (Located b)
+  -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)
+  mkUnpackednessPV :: Located UnpackednessPragma -> Located b -> PV (Located b)
+
+instance DisambTD (HsType GhcPs) where
+  mkHsAppTyHeadPV = return
+  mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)
+  mkHsAppKindTyPV t l_at ki = return (mkHsAppKindTy l' t ki)
+    where l' = combineSrcSpans l_at (getLoc ki)
+  mkHsOpTyPV t1 op t2 = return (mkLHsOpTy t1 op t2)
+  mkUnpackednessPV = addUnpackednessP
+
+-- | An accumulator to build a prefix data constructor,
+--   e.g. when parsing @MkT A B C@, the accumulator will evolve as follows:
+--
+--  @
+--  1. PrefixDataConBuilder []        MkT
+--  2. PrefixDataConBuilder [A]       MkT
+--  3. PrefixDataConBuilder [A, B]    MkT
+--  4. PrefixDataConBuilder [A, B, C] MkT
+--  @
+--
+--  There are two reasons we have a separate builder type instead of using
+--  @HsConDeclDetails GhcPs@ directly:
+--
+--  1. It's faster, because 'OrdList' gives us constant-time snoc.
+--  2. Having a separate type helps ensure that we don't forget to finalize a
+--     'RecTy' into a 'RecCon' (we do that in 'dataConBuilderDetails').
+--
+--  See Note [PatBuilder] for another builder type used in the parser.
+--  Here the technique is similar, but the motivation is different.
+data DataConBuilder
+  = PrefixDataConBuilder
+      (OrdList (LHsType GhcPs))  -- Data constructor fields
+      (Located RdrName)          -- Data constructor name
+  | InfixDataConBuilder
+      (LHsType GhcPs)   -- LHS field
+      (Located RdrName) -- Data constructor name
+      (LHsType GhcPs)   -- RHS field
+
+dataConBuilderCon :: DataConBuilder -> Located RdrName
+dataConBuilderCon (PrefixDataConBuilder _ dc) = dc
+dataConBuilderCon (InfixDataConBuilder _ dc _) = dc
+
+dataConBuilderDetails :: DataConBuilder -> HsConDeclDetails GhcPs
+
+-- Detect when the record syntax is used:
+--   data T = MkT { ... }
+dataConBuilderDetails (PrefixDataConBuilder flds _)
+  | [L l_t (HsRecTy _ fields)] <- toList flds
+  = RecCon (L l_t fields)
+
+-- Normal prefix constructor, e.g.  data T = MkT A B C
+dataConBuilderDetails (PrefixDataConBuilder flds _)
+  = PrefixCon (map hsLinear (toList flds))
+
+-- Infix constructor, e.g. data T = Int :! Bool
+dataConBuilderDetails (InfixDataConBuilder lhs _ rhs)
+  = InfixCon (hsLinear lhs) (hsLinear rhs)
+
+instance Outputable DataConBuilder where
+  ppr (PrefixDataConBuilder flds data_con) =
+    hang (ppr data_con) 2 (sep (map ppr (toList flds)))
+  ppr (InfixDataConBuilder lhs data_con rhs) =
+    ppr lhs <+> ppr data_con <+> ppr rhs
+
+instance DisambTD DataConBuilder where
+  mkHsAppTyHeadPV = tyToDataConBuilder
+
+  mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t =
+    return $
+      L (combineSrcSpans l (getLoc t))
+        (PrefixDataConBuilder (flds `snocOL` t) fn)
+  mkHsAppTyPV (L _ InfixDataConBuilder{}) _ =
+    -- This case is impossible because of the way
+    -- the grammar in Parser.y is written (see infixtype/ftype).
+    panic "mkHsAppTyPV: InfixDataConBuilder"
+
+  mkHsAppKindTyPV lhs l_at ki =
+    addFatalError l_at $
+    hang (text "Unexpected kind application in a data/newtype declaration:") 2
+      (ppr lhs <+> text "@" <> ppr ki)
+
+  mkHsOpTyPV lhs (L l_tc tc) rhs = do
+      check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative
+      data_con <- eitherToP $ tyConToDataCon l_tc tc
+      return $ L l (InfixDataConBuilder lhs data_con rhs)
+    where
+      l = combineLocs lhs rhs
+      check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
+      check_no_ops (HsOpTy{}) =
+        addError l $
+          hang (text "Cannot parse an infix data constructor in a data/newtype declaration:")
+            2 (ppr lhs <+> ppr tc <+> ppr rhs)
+      check_no_ops _ = return ()
+
+  mkUnpackednessPV unpk constr_stuff
+    | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff
+    = -- When the user writes  data T = {-# UNPACK #-} Int :+ Bool
+      --   we apply {-# UNPACK #-} to the LHS
+      do lhs' <- addUnpackednessP unpk lhs
+         let l = combineLocs unpk constr_stuff
+         return $ L l (InfixDataConBuilder lhs' data_con rhs)
+    | otherwise =
+      do addError (getLoc unpk) $
+           text "{-# UNPACK #-} cannot be applied to a data constructor."
+         return constr_stuff
+
+tyToDataConBuilder :: LHsType GhcPs -> PV (Located DataConBuilder)
+tyToDataConBuilder (L l (HsTyVar _ NotPromoted (L _ v))) = do
+  data_con <- eitherToP $ tyConToDataCon l v
+  return $ L l (PrefixDataConBuilder nilOL data_con)
+tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do
+  let data_con = L l (getRdrName (tupleDataCon Boxed (length ts)))
+  return $ L l (PrefixDataConBuilder (toOL ts) data_con)
+tyToDataConBuilder t =
+  addFatalError (getLoc t) $
+    hang (text "Cannot parse data constructor in a data/newtype declaration:")
+    2 (ppr t)
+
 {- Note [Ambiguous syntactic categories]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 There are places in the grammar where we do not know whether we are parsing an
 expression or a pattern without unlimited lookahead (which we do not have in
 'happy'):
@@ -2150,6 +1971,21 @@ position and shadows the previous $1. We can do this because internally
 is to be able to write (sLL $1 $>) later on. The alternative would be to
 write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer
 to the last fresh name as $>.
+
+Finally, we instantiate the polymorphic type to a concrete one, and run the
+parser-validator, for example:
+
+    stmt   :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }
+    e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
+            : stmt {% runPV $1 }
+
+In e_stmt, three things happen:
+
+  1. we instantiate: b ~ HsExpr GhcPs
+  2. we embed the PV computation into P by using runPV
+  3. we run validation by using a monadic production, {% ... }
+
+At this point the ambiguity is resolved.
 -}
 
 
@@ -2306,7 +2142,6 @@ Alternative VII, a product type
 We could avoid the intermediate representation of Alternative VI by parsing
 into a product of interpretations directly:
 
-    -- See Note [Parser-Validator]
     type ExpCmdPat = ( PV (LHsExpr GhcPs)
                      , PV (LHsCmd GhcPs)
                      , PV (LHsPat GhcPs) )
@@ -2326,7 +2161,6 @@ We can easily define ambiguities between arbitrary subsets of interpretations.
 For example, when we know ahead of type that only an expression or a command is
 possible, but not a pattern, we can use a smaller type:
 
-    -- See Note [Parser-Validator]
     type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs))
 
     checkExpOf2 (e, _) = e  -- interpret as an expression
@@ -2809,7 +2643,7 @@ warnStarBndr span = addWarning Opt_WarnStarBinder span msg
            <+> text "modules with StarIsType,"
         $$ text "    including the definition module, you must qualify it."
 
-failOpFewArgs :: Located RdrName -> P a
+failOpFewArgs :: MonadP m => Located RdrName -> m a
 failOpFewArgs (L loc op) =
   do { star_is_type <- getBit StarIsTypeBit
      ; let msg = too_few $$ starInfo star_is_type op
@@ -2836,7 +2670,25 @@ data PV_Accum =
 
 data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum
 
--- See Note [Parser-Validator]
+-- During parsing, we make use of several monadic effects: reporting parse errors,
+-- accumulating warnings, adding API annotations, and checking for extensions. These
+-- effects are captured by the 'MonadP' type class.
+--
+-- Sometimes we need to postpone some of these effects to a later stage due to
+-- ambiguities described in Note [Ambiguous syntactic categories].
+-- We could use two layers of the P monad, one for each stage:
+--
+--   abParser :: forall x. DisambAB x => P (P x)
+--
+-- The outer layer of P consumes the input and builds the inner layer, which
+-- validates the input. But this type is not particularly helpful, as it obscures
+-- the fact that the inner layer of P never consumes any input.
+--
+-- For clarity, we introduce the notion of a parser-validator: a parser that does
+-- not consume any input, but may fail or use other effects. Thus we have:
+--
+--   abParser :: forall x. DisambAB x => P (PV x)
+--
 newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a }
 
 instance Functor PV where
@@ -2910,36 +2762,6 @@ instance MonadP PV where
         PV_Ok acc' ()
   addAnnotation _ _ _ = return ()
 
-{- Note [Parser-Validator]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When resolving ambiguities, we need to postpone failure to make a choice later.
-For example, if we have ambiguity between some A and B, our parser could be
-
-  abParser :: P (Maybe A, Maybe B)
-
-This way we can represent four possible outcomes of parsing:
-
-    (Just a, Nothing)       -- definitely A
-    (Nothing, Just b)       -- definitely B
-    (Just a, Just b)        -- either A or B
-    (Nothing, Nothing)      -- neither A nor B
-
-However, if we want to report informative parse errors, accumulate warnings,
-and add API annotations, we are better off using 'P' instead of 'Maybe':
-
-  abParser :: P (P A, P B)
-
-So we have an outer layer of P that consumes the input and builds the inner
-layer, which validates the input.
-
-For clarity, we introduce the notion of a parser-validator: a parser that does
-not consume any input, but may fail or use other effects. Thus we have:
-
-  abParser :: P (PV A, PV B)
-
--}
-
 {- Note [Parser-Validator Hint]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 A PV computation is parametrized by a hint for error messages, which can be set


=====================================
compiler/GHC/Platform/Profile.hs
=====================================
@@ -13,8 +13,6 @@ import GHC.Prelude
 import GHC.Platform
 import GHC.Platform.Ways
 
-import Data.Set
-
 -- | A platform profile fully describes the kind of objects that are generated
 -- for a platform.
 --
@@ -22,8 +20,8 @@ import Data.Set
 -- (profiling, debug, dynamic) also modify the ABI.
 --
 data Profile = Profile
-   { profilePlatform :: !Platform  -- ^ Platform
-   , profileWays     :: !(Set Way) -- ^ Ways
+   { profilePlatform :: !Platform -- ^ Platform
+   , profileWays     :: !Ways     -- ^ Ways
    }
 
 -- | Get platform constants


=====================================
compiler/GHC/Platform/Ways.hs
=====================================
@@ -20,6 +20,7 @@
 -- this compilation.
 module GHC.Platform.Ways
    ( Way(..)
+   , Ways
    , hasWay
    , allowed_combination
    , wayGeneralFlags
@@ -61,12 +62,14 @@ data Way
   | WayDyn           -- ^ Dynamic linking
   deriving (Eq, Ord, Show)
 
+type Ways = Set Way
+
 -- | Test if a ways is enabled
-hasWay :: Set Way -> Way -> Bool
+hasWay :: Ways -> Way -> Bool
 hasWay ws w = Set.member w ws
 
 -- | Check if a combination of ways is allowed
-allowed_combination :: Set Way -> Bool
+allowed_combination :: Ways -> Bool
 allowed_combination ways = not disallowed
   where
    disallowed = or [ hasWay ways x && hasWay ways y
@@ -76,13 +79,13 @@ allowed_combination ways = not disallowed
    couples = [] -- we don't have any disallowed combination of ways nowadays
 
 -- | Unique tag associated to a list of ways
-waysTag :: Set Way -> String
+waysTag :: Ways -> String
 waysTag = concat . intersperse "_" . map wayTag . Set.toAscList
 
 -- | Unique build-tag associated to a list of ways
 --
 -- RTS only ways are filtered out because they have no impact on the build.
-waysBuildTag :: Set Way -> String
+waysBuildTag :: Ways -> String
 waysBuildTag ws = waysTag (Set.filter (not . wayRTSOnly) ws)
 
 
@@ -195,7 +198,7 @@ foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO Int
 -- | Return host "full" ways (i.e. ways that have an impact on the compilation,
 -- not RTS only ways). These ways must be used when compiling codes targeting
 -- the internal interpreter.
-hostFullWays :: Set Way
+hostFullWays :: Ways
 hostFullWays = Set.unions
    [ if hostIsDynamic  then Set.singleton WayDyn  else Set.empty
    , if hostIsProfiled then Set.singleton WayProf else Set.empty


=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -74,7 +74,6 @@ import GHC.Types.SrcLoc
 import GHC.Data.List.SetOps
 import GHC.Driver.Session
 import GHC.Types.Unique
-import GHC.Core.ConLike( ConLike(..) )
 import GHC.Types.Basic
 import qualified GHC.LanguageExtensions as LangExt
 
@@ -3819,15 +3818,14 @@ checkValidTyCl tc
   where
     recovery_code -- See Note [Recover from validity error]
       = do { traceTc "Aborted validity for tycon" (ppr tc)
-           ; return (concatMap mk_fake_tc $
-                     ATyCon tc : implicitTyConThings tc) }
+           ; return (map mk_fake_tc $
+                     tc : child_tycons tc) }
 
-    mk_fake_tc (ATyCon tc)
-      | isClassTyCon tc = [tc]   -- Ugh! Note [Recover from validity error]
-      | otherwise       = [makeRecoveryTyCon tc]
-    mk_fake_tc (AConLike (RealDataCon dc))
-                        = [makeRecoveryTyCon (promoteDataCon dc)]
-    mk_fake_tc _        = []
+    mk_fake_tc tc
+      | isClassTyCon tc = tc   -- Ugh! Note [Recover from validity error]
+      | otherwise       = makeRecoveryTyCon tc
+
+    child_tycons tc = tyConATs tc ++ map promoteDataCon (tyConDataCons tc)
 
 {- Note [Recover from validity error]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3852,6 +3850,8 @@ Some notes:
   and so there was an internal error when we met 'MkT' in the body of
   'S'.
 
+  Similarly for associated types.
+
 * Painfully, we *don't* want to do this for classes.
   Consider tcfail041:
      class (?x::Int) => C a where ...
@@ -3864,6 +3864,14 @@ Some notes:
   This is really bogus; now we have in scope a Class that is invalid
   in some way, with unknown downstream consequences.  A better
   alternative might be to make a fake class TyCon.  A job for another day.
+
+* Previously, we used implicitTyConThings to snaffle out the parts
+  to add to the context. The problem is that this also grabs data con
+  wrapper Ids. These could be filtered out. But, painfully, getting
+  the wrapper Ids checks the DataConRep, and forcing the DataConRep
+  can panic if there is a levity-polymorphic argument. This is #18534.
+  We don't need the wrapper Ids here anyway. So the code just takes what
+  it needs, via child_tycons.
 -}
 
 -------------------------
@@ -4050,8 +4058,13 @@ checkValidDataCon dflags existential_ok tc con
           -- regardless of whether or not UnliftedNewtypes is enabled. A
           -- later check in checkNewDataCon handles this, producing a
           -- better error message than checkForLevPoly would.
-        ; unless (isNewTyCon tc)
-            (mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con))
+        ; unless (isNewTyCon tc) $
+            checkNoErrs $
+            mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con)
+            -- the checkNoErrs is to prevent a panic in isVanillaDataCon
+            -- (called a a few lines down), which can fall over if there is a
+            -- bang on a levity-polymorphic argument. This is #18534,
+            -- typecheck/should_fail/T18534
 
           -- Extra checks for newtype data constructors. Importantly, these
           -- checks /must/ come before the call to checkValidType below. This


=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -315,7 +315,7 @@ instance Monoid UnitVisibility where
 -- | Unit configuration
 data UnitConfig = UnitConfig
    { unitConfigPlatformArchOS :: !ArchOS        -- ^ Platform arch and OS
-   , unitConfigWays           :: !(Set Way)     -- ^ Ways to use
+   , unitConfigWays           :: !Ways          -- ^ Ways to use
    , unitConfigProgramName    :: !String
       -- ^ Name of the compiler (e.g. "GHC", "GHCJS"). Used to fetch environment
       -- variables such as "GHC[JS]_PACKAGE_PATH".


=====================================
testsuite/tests/ghc-api/T18522-dbg-ppr.hs
=====================================
@@ -0,0 +1,50 @@
+{-# LANGUAGE TemplateHaskell, ExplicitForAll, PolyKinds #-}
+
+module Main where
+
+import Language.Haskell.TH (runQ)
+import GHC.Types.Basic
+import GHC.ThToHs
+import GHC.Driver.Session
+import GHC.Core.TyCo.Ppr
+import GHC.Utils.Outputable
+import GHC.Tc.Module
+import GHC.Tc.Utils.Zonk
+import GHC.Utils.Error
+import GHC.Driver.Types
+import GHC
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.Either (fromRight)
+import Control.Monad.IO.Class (liftIO)
+import System.Environment (getArgs)
+
+main :: IO ()
+main = do
+  [libdir] <- getArgs
+  runGhc (Just libdir) $ do
+    initial_dflags <- getSessionDynFlags
+    setSessionDynFlags $ initial_dflags
+      `dopt_set` Opt_D_ppr_debug
+      `gopt_set` Opt_SuppressUniques
+      `gopt_set` Opt_SuppressModulePrefixes
+      `gopt_set` Opt_SuppressVarKinds
+      `xopt_set` LangExt.KindSignatures
+      `xopt_set` LangExt.PolyKinds
+      `xopt_set` LangExt.RankNTypes
+    hsc_env <- getSession
+    let dflags = hsc_dflags hsc_env
+    liftIO $ do
+      th_t <- runQ [t| forall k {j}.
+                       forall (a :: k) (b :: j) ->
+                       () |]
+      let hs_t = fromRight (error "convertToHsType") $
+                 convertToHsType Generated noSrcSpan th_t
+      ((warnings, errors), mres) <-
+        tcRnType hsc_env SkolemiseFlexi True hs_t
+      case mres of
+        Nothing -> do
+          printBagOfErrors dflags warnings
+          printBagOfErrors dflags errors
+        Just (t, _) -> do
+          putStrLn $ showSDoc dflags (debugPprType t)


=====================================
testsuite/tests/ghc-api/T18522-dbg-ppr.stdout
=====================================
@@ -0,0 +1,2 @@
+forall k{tv}[tv] {j{tv}[tv]}.
+forall a{tv}[tv] b{tv}[tv] -> (){(w) tc}


=====================================
testsuite/tests/ghc-api/all.T
=====================================
@@ -20,3 +20,7 @@ test('T9015', extra_run_opts('"' + config.libdir + '"'),
 test('T11579', extra_run_opts('"' + config.libdir + '"'), compile_and_run,
      ['-package ghc'])
 test('T12099', normal, compile_and_run, ['-package ghc'])
+test('T18522-dbg-ppr',
+  extra_run_opts('"' + config.libdir + '"'),
+  compile_and_run,
+  ['-package ghc'])


=====================================
testsuite/tests/parser/should_fail/T12045d.stderr
=====================================
@@ -1,4 +1,3 @@
 
 T12045d.hs:11:16: error:
-    Unexpected kind application in a data/newtype declaration:
-      MkD @Nat Bool
+    Unexpected kind application in a data/newtype declaration: MkD @Nat


=====================================
testsuite/tests/parser/should_fail/strictnessDataCon_B.stderr
=====================================
@@ -1,3 +1,2 @@
 
-strictnessDataCon_B.hs:1:27: error:
-    {-# UNPACK #-} cannot appear inside a type.
+strictnessDataCon_B.hs:1:42: error: parse error on input ‘}’


=====================================
testsuite/tests/parser/should_fail/typeops_A.stderr
=====================================
@@ -1,2 +1,3 @@
 
-typeops_A.hs:1:12: error: Operator applied to too few arguments: +
+typeops_A.hs:2:1: error:
+    parse error (possibly incorrect indentation or mismatched brackets)


=====================================
testsuite/tests/parser/should_fail/typeops_C.stderr
=====================================
@@ -1,2 +1,2 @@
 
-typeops_C.hs:1:12: error: Operator applied to too few arguments: +
+typeops_C.hs:1:14: error: Operator applied to too few arguments: +


=====================================
testsuite/tests/parser/should_fail/unpack_empty_type.stderr
=====================================
@@ -1,3 +1,2 @@
 
-unpack_empty_type.hs:3:19: error:
-    {-# UNPACK #-} must be applied to a type.
+unpack_empty_type.hs:3:34: error: parse error on input ‘}’


=====================================
testsuite/tests/parser/should_fail/unpack_inside_type.stderr
=====================================
@@ -1,3 +1,7 @@
 
 unpack_inside_type.hs:3:25: error:
-    {-# UNPACK #-} cannot appear inside a type.
+    • Unexpected UNPACK annotation: {-# UNPACK #-}Int
+      UNPACK annotation cannot appear nested inside a type
+    • In the first argument of ‘Maybe’, namely ‘({-# UNPACK #-}Int)’
+      In the type ‘Maybe ({-# UNPACK #-}Int)’
+      In the definition of data constructor ‘T’


=====================================
testsuite/tests/polykinds/T18522-ppr.script
=====================================
@@ -0,0 +1,4 @@
+:set -XPolyKinds -XDataKinds -XRankNTypes -XTypeFamilies
+import Data.Kind (Type)
+type family T :: forall k -> (k ~ k) => forall j -> k -> j -> Type
+:k T


=====================================
testsuite/tests/polykinds/T18522-ppr.stdout
=====================================
@@ -0,0 +1 @@
+T :: forall k -> (k ~ k) => forall j -> k -> j -> *


=====================================
testsuite/tests/polykinds/all.T
=====================================
@@ -223,3 +223,4 @@ test('T18300', normal, compile_fail, [''])
 test('T18451', normal, compile_fail, [''])
 test('T18451a', normal, compile_fail, [''])
 test('T18451b', normal, compile_fail, [''])
+test('T18522-ppr', normal, ghci_script, ['T18522-ppr.script'])


=====================================
testsuite/tests/typecheck/should_fail/T18534.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE PolyKinds #-}
+
+module Test where
+
+import GHC.Exts
+
+data Test (a :: TYPE r) = Test !a


=====================================
testsuite/tests/typecheck/should_fail/T18534.stderr
=====================================
@@ -0,0 +1,7 @@
+
+T18534.hs:7:27: error:
+    • A levity-polymorphic type is not allowed here:
+        Type: a
+        Kind: TYPE r
+    • In the definition of data constructor ‘Test’
+      In the data type declaration for ‘Test’


=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -578,3 +578,4 @@ test('T18357', normal, compile_fail, [''])
 test('T18357a', normal, compile_fail, [''])
 test('T18357b', normal, compile_fail, [''])
 test('T18455', normal, compile_fail, [''])
+test('T18534', normal, compile_fail, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/829f48c0181168c8012eb976135746a473878ec6...54d6387a65b6ca1b1d32891b697ec368fbb38eb3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/829f48c0181168c8012eb976135746a473878ec6...54d6387a65b6ca1b1d32891b697ec368fbb38eb3
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200806/c393b610/attachment-0001.html>


More information about the ghc-commits mailing list