[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 17:34:17 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
686e06c5 by Vladislav Zavialov at 2020-08-06T13:34:05-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.
- - - - -
6770e199 by Vladislav Zavialov at 2020-08-06T13:34:05-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.
- - - - -
826d07db by Vladislav Zavialov at 2020-08-06T13:34:06-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.
- - - - -
0ddb4384 by Vladislav Zavialov at 2020-08-06T13:34:06-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
- - - - -
d2a43225 by Richard Eisenberg at 2020-08-06T13:34:06-04:00
Fail eagerly on a lev-poly datacon arg
Close #18534.
See commentary in the patch.
- - - - -
63348155 by Sylvain Henry at 2020-08-06T13:34:08-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/54d6387a65b6ca1b1d32891b697ec368fbb38eb3...63348155404c64334fa864454132630f9d2a4d7f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/54d6387a65b6ca1b1d32891b697ec368fbb38eb3...63348155404c64334fa864454132630f9d2a4d7f
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/673dc46d/attachment-0001.html>
More information about the ghc-commits
mailing list