diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2016-05-25 00:09:34 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2016-06-06 21:52:49 +0200 |
| commit | a13cb27960f9bdb0bc9eececf9159f034f113481 (patch) | |
| tree | 1f6d154698f022b76042b1b796ca0ed959a2b201 | |
| parent | 1937ef1c506b538f0f93cd290fa4a42fc85ab769 (diff) | |
| download | haskell-a13cb27960f9bdb0bc9eececf9159f034f113481.tar.gz | |
Merge MatchFixity and HsMatchContext
Summary:
MatchFixity was introduced to facilitate use of API Annotations.
HsMatchContext does the same thing with more detail, but is chased
through all over the place to provide context when processing a Match.
Since we already have MatchFixity in the Match, it may as well provide
the full context.
updates submodule haddock
Test Plan: ./validate
Reviewers: austin, goldfire, bgamari
Subscribers: thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D2271
GHC Trac Issues: #12105
(cherry picked from commit 306ecad591951521ac3f5888ca8be85bf749d271)
39 files changed, 459 insertions, 338 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 02074e5a3e..d3364332c5 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -1328,8 +1328,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun (ppr_match, pref) = case kind of - FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) - _ -> (pprMatchContext kind, \ pp -> pp) + FunRhs (L _ fun) _ -> (pprMatchContext kind, + \ pp -> ppr fun <+> pp) + _ -> (pprMatchContext kind, \ pp -> pp) ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc ppr_pats kind pats diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 00b111abbb..c27168a042 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -124,7 +124,9 @@ dsHsBind dflags dsHsBind dflags (FunBind { fun_id = L _ fun, fun_matches = matches , fun_co_fn = co_fn, fun_tick = tick }) - = do { (args, body) <- matchWrapper (FunRhs (idName fun)) Nothing matches + = do { (args, body) <- matchWrapper + (FunRhs (noLoc $ idName fun) Prefix) + Nothing matches ; let body' = mkOptTickBox tick body ; rhs <- dsHsWrapper co_fn (mkLams args body') ; let core_binds@(id,_) = makeCorePair dflags fun False 0 rhs @@ -313,7 +315,9 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts = putSrcSpanDs bind_loc $ addDictsDs (toTcTypeBag (listToBag dicts)) $ -- addDictsDs: push type constraints deeper for pattern match check - do { (args, body) <- matchWrapper (FunRhs (idName global)) Nothing matches + do { (args, body) <- matchWrapper + (FunRhs (noLoc $ idName global) Prefix) + Nothing matches ; let body' = mkOptTickBox tick body ; fun_rhs <- dsHsWrapper co_fn $ mkLams args body' diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index c33b867358..85177ee679 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -149,13 +149,14 @@ dsUnliftedBind (AbsBindsSig { abs_tvs = [] ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body ; return (mkCoreLets ds_binds body') } -dsUnliftedBind (FunBind { fun_id = L _ fun +dsUnliftedBind (FunBind { fun_id = L l fun , fun_matches = matches , fun_co_fn = co_fn , fun_tick = tick }) body -- Can't be a bang pattern (that looks like a PatBind) -- so must be simply unboxed - = do { (args, rhs) <- matchWrapper (FunRhs (idName fun)) Nothing matches + = do { (args, rhs) <- matchWrapper (FunRhs (L l $ idName fun) Prefix) + Nothing matches ; MASSERT( null args ) -- Functions aren't lifted ; MASSERT( isIdHsWrapper co_fn ) ; let rhs' = mkOptTickBox tick rhs @@ -685,7 +686,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields , pat_args = PrefixCon $ map nlVarPat arg_ids , pat_arg_tys = in_inst_tys , pat_wrap = req_wrap } - ; return (mkSimpleMatch [pat] wrapped_rhs) } + ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } -- Here is where we desugar the Template Haskell brackets and escapes @@ -909,7 +910,8 @@ dsDo stmts ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty ; let fun = L noSrcSpan $ HsLam $ - MG { mg_alts = noLoc [mkSimpleMatch pats body'] + MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats + body'] , mg_arg_tys = arg_tys , mg_res_ty = body_ty , mg_origin = Generated } @@ -940,7 +942,9 @@ dsDo stmts rets = map noLoc rec_rets mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] mfix_arg = noLoc $ HsLam - (MG { mg_alts = noLoc [mkSimpleMatch [mfix_pat] body] + (MG { mg_alts = noLoc [mkSimpleMatch + LambdaExpr + [mfix_pat] body] , mg_arg_tys = [tup_ty], mg_res_ty = body_ty , mg_origin = Generated }) mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 370e310204..91489b7bc7 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1553,7 +1553,7 @@ repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds)))) do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyms ss lam } -repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m) +repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m) ----------------------------------------------------------------------------- diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 63904ed219..8d85ca9332 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -142,7 +142,7 @@ cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName)) cvtDec (TH.ValD pat body ds) | TH.VarP s <- pat = do { s' <- vNameL s - ; cl' <- cvtClause (Clause [] body ds) + ; cl' <- cvtClause (FunRhs s' Prefix) (Clause [] body ds) ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] } | otherwise @@ -161,7 +161,7 @@ cvtDec (TH.FunD nm cls) <+> text "has no equations") | otherwise = do { nm' <- vNameL nm - ; cls' <- mapM cvtClause cls + ; cls' <- mapM (cvtClause (FunRhs nm' Prefix)) cls ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' } cvtDec (TH.SigD nm typ) @@ -354,7 +354,7 @@ cvtDec (TH.DefaultSigD nm typ) cvtDec (TH.PatSynD nm args dir pat) = do { nm' <- cNameL nm ; args' <- cvtArgs args - ; dir' <- cvtDir dir + ; dir' <- cvtDir nm' dir ; pat' <- cvtPat pat ; returnJustL $ Hs.ValD $ PatSynBind $ PSB nm' placeHolderType args' pat' dir' } @@ -366,10 +366,10 @@ cvtDec (TH.PatSynD nm args dir pat) ; vars' <- mapM (vNameL . mkNameS . nameBase) sels ; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' } - cvtDir Unidir = return Unidirectional - cvtDir ImplBidir = return ImplicitBidirectional - cvtDir (ExplBidir cls) = - do { ms <- mapM cvtClause cls + cvtDir _ Unidir = return Unidirectional + cvtDir _ ImplBidir = return ImplicitBidirectional + cvtDir n (ExplBidir cls) = + do { ms <- mapM (cvtClause (FunRhs n Prefix)) cls ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms } cvtDec (TH.PatSynSigD nm ty) @@ -730,12 +730,13 @@ cvtLocalDecs doc ds ; unless (null bads) (failWith (mkBadDecMsg doc bads)) ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) } -cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) -cvtClause (Clause ps body wheres) +cvtClause :: HsMatchContext RdrName + -> TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) +cvtClause ctxt (Clause ps body wheres) = do { ps' <- cvtPats ps ; g' <- cvtGuard body ; ds' <- cvtLocalDecs (text "a where clause") wheres - ; returnL $ Hs.Match NonFunBindMatch ps' Nothing + ; returnL $ Hs.Match ctxt ps' Nothing (GRHSs g' (noLoc ds')) } @@ -756,8 +757,9 @@ cvtl e = wrapL (cvt e) cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y ; return $ HsApp x' y' } cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e - ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) } - cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms + ; return $ HsLam (mkMatchGroup FromSource + [mkSimpleMatch LambdaExpr ps' e'])} + cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms ; return $ HsLamCase (mkMatchGroup FromSource ms') } cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } @@ -777,7 +779,7 @@ cvtl e = wrapL (cvt e) ; return $ HsMultiIf placeHolderType alts' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds ; e' <- cvtl e; return $ HsLet (noLoc ds') e' } - cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms + cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms ; return $ HsCase e' (mkMatchGroup FromSource ms') } cvt (DoE ss) = cvtHsDo DoExpr ss cvt (CompE ss) = cvtHsDo ListComp ss @@ -950,12 +952,13 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' n where cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } -cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) -cvtMatch (TH.Match p body decs) +cvtMatch :: HsMatchContext RdrName + -> TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) +cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (text "a where clause") decs - ; returnL $ Hs.Match NonFunBindMatch [p'] Nothing + ; returnL $ Hs.Match ctxt [p'] Nothing (GRHSs g' (noLoc decs')) } cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)] diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index ce3d3c7d2e..5383ee5c6b 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -22,7 +22,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) -import PlaceHolder ( PostTc,PostRn,DataId ) +import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId ) import HsTypes import PprCore () import CoreSyn @@ -405,12 +405,14 @@ Specifically, it's just an error thunk -} -instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where +instance (OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsLocalBindsLR idL idR) where ppr (HsValBinds bs) = ppr bs ppr (HsIPBinds bs) = ppr bs ppr EmptyLocalBinds = empty -instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where +instance (OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsValBindsLR idL idR) where ppr (ValBindsIn binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs) @@ -425,12 +427,14 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR id pp_rec Recursive = text "rec" pp_rec NonRecursive = text "nonrec" -pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc +pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR) + => LHsBindsLR idL idR -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty | otherwise = pprDeclList (map ppr (bagToList binds)) -pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2) +pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR, + OutputableBndrId id2) => LHsBindsLR idL idR -> [LSig id2] -> [SDoc] -- pprLHsBindsForUser is different to pprLHsBinds because -- a) No braces: 'let' and 'where' include a list of HsBindGroups @@ -491,7 +495,6 @@ plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2) plusHsValBinds _ _ = panic "HsBinds.plusHsValBinds" - {- What AbsBinds means ~~~~~~~~~~~~~~~~~~~ @@ -518,10 +521,12 @@ So the desugarer tries to do a better job: in (fm,gm) -} -instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where +instance (OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsBindLR idL idR) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc +ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR) + => HsBindLR idL idR -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss @@ -534,7 +539,7 @@ ppr_monobind (FunBind { fun_id = fun, = pprTicks empty (if null ticks then empty else text "-- ticks = " <> ppr ticks) $$ ifPprDebug (pprBndr LetBind (unLoc fun)) - $$ pprFunBind (unLoc fun) matches + $$ pprFunBind matches $$ ifPprDebug (ppr wrap) ppr_monobind (PatSynBind psb) = ppr psb ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars @@ -574,8 +579,10 @@ instance (OutputableBndr id) => Outputable (ABExport id) where , nest 2 (pprTcSpecPrags prags) , nest 2 (text "wrap:" <+> ppr wrap)] -instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where - ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir }) +instance (OutputableBndr idL, OutputableBndrId idR) + => Outputable (PatSynBind idL idR) where + ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, + psb_dir = dir }) = ppr_lhs <+> ppr_rhs where ppr_lhs = text "pattern" <+> ppr_details @@ -592,7 +599,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL Unidirectional -> ppr_simple (text "<-") ImplicitBidirectional -> ppr_simple equals ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$ - (nest 2 $ pprFunBind psyn mg) + (nest 2 $ pprFunBind mg) pprTicks :: SDoc -> SDoc -> SDoc -- Print stuff about ticks only when -dppr-debug is on, to avoid @@ -642,11 +649,11 @@ data IPBind id = IPBind (Either (Located HsIPName) id) (LHsExpr id) deriving instance (DataId name) => Data (IPBind name) -instance (OutputableBndr id) => Outputable (HsIPBinds id) where +instance (OutputableBndrId id) => Outputable (HsIPBinds id) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) $$ ifPprDebug (ppr ds) -instance (OutputableBndr id) => Outputable (IPBind id) where +instance (OutputableBndrId id) => Outputable (IPBind id) where ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) where name = case lr of Left (L _ ip) -> pprBndr LetBind ip @@ -878,10 +885,10 @@ signatures. Since some of the signatures contain a list of names, testing for equality is not enough -- we have to check if they overlap. -} -instance (OutputableBndr name) => Outputable (Sig name) where +instance (OutputableBndrId name) => Outputable (Sig name) where ppr sig = ppr_sig sig -ppr_sig :: OutputableBndr name => Sig name -> SDoc +ppr_sig :: (OutputableBndrId name) => Sig name -> SDoc ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (ClassOpSig is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index c6026c484e..7bf10c9137 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -96,7 +96,7 @@ import Name import BasicTypes import Coercion import ForeignCall -import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId ) +import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId ) import NameSet -- others: @@ -246,7 +246,7 @@ appendGroups hs_vects = vects1 ++ vects2, hs_docs = docs1 ++ docs2 } -instance OutputableBndr name => Outputable (HsDecl name) where +instance (OutputableBndrId name) => Outputable (HsDecl name) where ppr (TyClD dcl) = ppr dcl ppr (ValD binds) = ppr binds ppr (DefD def) = ppr def @@ -262,7 +262,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where ppr (DocD doc) = ppr doc ppr (RoleAnnotD ra) = ppr ra -instance OutputableBndr name => Outputable (HsGroup name) where +instance (OutputableBndrId name) => Outputable (HsGroup name) where ppr (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_derivds = deriv_decls, @@ -307,7 +307,7 @@ data SpliceDecl id SpliceExplicitFlag deriving instance (DataId id) => Data (SpliceDecl id) -instance OutputableBndr name => Outputable (SpliceDecl name) where +instance (OutputableBndrId name) => Outputable (SpliceDecl name) where ppr (SpliceDecl (L _ e) _) = pprSplice e {- @@ -623,8 +623,7 @@ hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ -instance OutputableBndr name - => Outputable (TyClDecl name) where +instance (OutputableBndrId name) => Outputable (TyClDecl name) where ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs }) @@ -652,7 +651,7 @@ instance OutputableBndr name <+> pp_vanilla_decl_head lclas tyvars (unLoc context) <+> pprFundeps (map unLoc fds) -instance OutputableBndr name => Outputable (TyClGroup name) where +instance (OutputableBndrId name) => Outputable (TyClGroup name) where ppr (TyClGroup { group_tyclds = tyclds , group_roles = roles , group_instds = instds @@ -662,7 +661,7 @@ instance OutputableBndr name => Outputable (TyClGroup name) where ppr roles $$ ppr instds -pp_vanilla_decl_head :: OutputableBndr name +pp_vanilla_decl_head :: (OutputableBndrId name) => Located name -> LHsQTyVars name -> HsContext name @@ -928,10 +927,11 @@ resultVariableName :: FamilyResultSig a -> Maybe a resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig resultVariableName _ = Nothing -instance (OutputableBndr name) => Outputable (FamilyDecl name) where +instance (OutputableBndrId name) => Outputable (FamilyDecl name) where ppr = pprFamilyDecl TopLevel -pprFamilyDecl :: OutputableBndr name => TopLevelFlag -> FamilyDecl name -> SDoc +pprFamilyDecl :: (OutputableBndrId name) + => TopLevelFlag -> FamilyDecl name -> SDoc pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon , fdTyVars = tyvars , fdResultSig = L _ result @@ -1126,7 +1126,7 @@ hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) -pp_data_defn :: OutputableBndr name +pp_data_defn :: (OutputableBndrId name) => (HsContext name -> SDoc) -- Printing the header -> HsDataDefn name -> SDoc @@ -1148,23 +1148,23 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context Just (L _ ds) -> hsep [ text "deriving" , parens (interpp'SP ds)] -instance OutputableBndr name => Outputable (HsDataDefn name) where +instance (OutputableBndrId name) => Outputable (HsDataDefn name) where ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d instance Outputable NewOrData where ppr NewType = text "newtype" ppr DataType = text "data" -pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc +pp_condecls :: (OutputableBndrId name) => [LConDecl name] -> SDoc pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) pp_condecls cs -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) -instance (OutputableBndr name) => Outputable (ConDecl name) where +instance (OutputableBndrId name) => Outputable (ConDecl name) where ppr = pprConDecl -pprConDecl :: OutputableBndr name => ConDecl name -> SDoc +pprConDecl :: (OutputableBndrId name) => ConDecl name -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con , con_qvars = mtvs , con_cxt = mcxt @@ -1346,10 +1346,11 @@ data InstDecl name -- Both class and family instances { tfid_inst :: TyFamInstDecl name } deriving instance (DataId id) => Data (InstDecl id) -instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where +instance (OutputableBndrId name) => Outputable (TyFamInstDecl name) where ppr = pprTyFamInstDecl TopLevel -pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc +pprTyFamInstDecl :: (OutputableBndrId name) + => TopLevelFlag -> TyFamInstDecl name -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn @@ -1357,22 +1358,23 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = text "instance" ppr_instance_keyword NotTopLevel = empty -ppr_fam_inst_eqn :: OutputableBndr name => LTyFamInstEqn name -> SDoc +ppr_fam_inst_eqn :: (OutputableBndrId name) => LTyFamInstEqn name -> SDoc ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon , tfe_pats = pats , tfe_rhs = rhs })) = pp_fam_inst_lhs tycon pats [] <+> equals <+> ppr rhs -ppr_fam_deflt_eqn :: OutputableBndr name => LTyFamDefltEqn name -> SDoc +ppr_fam_deflt_eqn :: (OutputableBndrId name) => LTyFamDefltEqn name -> SDoc ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon , tfe_pats = tvs , tfe_rhs = rhs })) = text "type" <+> pp_vanilla_decl_head tycon tvs [] <+> equals <+> ppr rhs -instance (OutputableBndr name) => Outputable (DataFamInstDecl name) where +instance (OutputableBndrId name) => Outputable (DataFamInstDecl name) where ppr = pprDataFamInstDecl TopLevel -pprDataFamInstDecl :: OutputableBndr name => TopLevelFlag -> DataFamInstDecl name -> SDoc +pprDataFamInstDecl :: (OutputableBndrId name) + => TopLevelFlag -> DataFamInstDecl name -> SDoc pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon , dfid_pats = pats , dfid_defn = defn }) @@ -1384,7 +1386,7 @@ pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) }) = ppr nd -pp_fam_inst_lhs :: OutputableBndr name +pp_fam_inst_lhs :: (OutputableBndrId name) => Located name -> HsTyPats name -> HsContext name @@ -1393,7 +1395,7 @@ pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) context -- explicit type pat = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing) , hsep (map (pprParendHsType.unLoc) typats)] -instance (OutputableBndr name) => Outputable (ClsInstDecl name) where +instance (OutputableBndrId name) => Outputable (ClsInstDecl name) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats , cid_overlap_mode = mbOverlap @@ -1422,7 +1424,7 @@ ppOverlapPragma mb = Just (L _ (Incoherent _)) -> text "{-# INCOHERENT #-}" -instance (OutputableBndr name) => Outputable (InstDecl name) where +instance (OutputableBndrId name) => Outputable (InstDecl name) where ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl ppr (DataFamInstD { dfid_inst = decl }) = ppr decl @@ -1460,7 +1462,7 @@ data DerivDecl name = DerivDecl } deriving instance (DataId name) => Data (DerivDecl name) -instance (OutputableBndr name) => Outputable (DerivDecl name) where +instance (OutputableBndrId name) => Outputable (DerivDecl name) where ppr (DerivDecl ty o) = hsep [text "deriving instance", ppOverlapPragma o, ppr ty] @@ -1486,8 +1488,7 @@ data DefaultDecl name -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (DefaultDecl name) -instance (OutputableBndr name) - => Outputable (DefaultDecl name) where +instance (OutputableBndrId name) => Outputable (DefaultDecl name) where ppr (DefaultDecl tys) = text "default" <+> parens (interpp'SP tys) @@ -1588,7 +1589,7 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- pretty printing of foreign declarations -- -instance OutputableBndr name => Outputable (ForeignDecl name) where +instance (OutputableBndrId name) => Outputable (ForeignDecl name) where ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) = hang (text "foreign import" <+> ppr fimport <+> ppr n) 2 (dcolon <+> ppr ty) @@ -1679,10 +1680,10 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] pprFullRuleName :: Located (SourceText, RuleName) -> SDoc pprFullRuleName (L _ (_, n)) = doubleQuotes $ ftext n -instance OutputableBndr name => Outputable (RuleDecls name) where +instance (OutputableBndrId name) => Outputable (RuleDecls name) where ppr (HsRules _ rules) = ppr rules -instance OutputableBndr name => Outputable (RuleDecl name) where +instance (OutputableBndrId name) => Outputable (RuleDecl name) where ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) = sep [text "{-# RULES" <+> pprFullRuleName name <+> ppr act, @@ -1692,7 +1693,7 @@ instance OutputableBndr name => Outputable (RuleDecl name) where pp_forall | null ns = empty | otherwise = forAllLit <+> fsep (map ppr ns) <> dot -instance OutputableBndr name => Outputable (RuleBndr name) where +instance (OutputableBndrId name) => Outputable (RuleBndr name) where ppr (RuleBndr name) = ppr name ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty @@ -1777,7 +1778,7 @@ lvectInstDecl (L _ (HsVectInstIn _)) = True lvectInstDecl (L _ (HsVectInstOut _)) = True lvectInstDecl _ = False -instance OutputableBndr name => Outputable (VectDecl name) where +instance (OutputableBndrId name) => Outputable (VectDecl name) where ppr (HsVect _ v rhs) = sep [text "{-# VECTORISE" <+> ppr v, nest 4 $ @@ -1889,7 +1890,7 @@ data AnnDecl name = HsAnnotation -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (AnnDecl name) -instance (OutputableBndr name) => Outputable (AnnDecl name) where +instance (OutputableBndrId name) => Outputable (AnnDecl name) where ppr (HsAnnotation _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 0937d29f65..79cf079882 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -10,6 +10,7 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveFunctor #-} -- | Abstract Haskell syntax for expressions. module HsExpr where @@ -20,7 +21,8 @@ module HsExpr where import HsDecls import HsPat import HsLit -import PlaceHolder ( PostTc,PostRn,DataId ) +import PlaceHolder ( PostTc,PostRn,DataId,DataIdPost, + NameOrRdrName,OutputableBndrId ) import HsTypes import HsBinds @@ -42,7 +44,7 @@ import FastString import Type -- libraries: -import Data.Data hiding (Fixity) +import Data.Data hiding (Fixity(..)) import Data.Maybe (isNothing) {- @@ -117,7 +119,7 @@ mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name -- don't care about filling in syn_arg_wraps because we're clearly -- not past the typechecker -instance OutputableBndr id => Outputable (SyntaxExpr id) where +instance (OutputableBndrId id) => Outputable (SyntaxExpr id) where ppr (SyntaxExpr { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) @@ -741,16 +743,16 @@ RenamedSource that the API Annotations cannot be used directly with RenamedSource, so this allows a simple mapping to be used based on the location. -} -instance OutputableBndr id => Outputable (HsExpr id) where +instance (OutputableBndrId id) => Outputable (HsExpr id) where ppr expr = pprExpr expr ----------------------- -- pprExpr, pprLExpr, pprBinds call pprDeeper; -- the underscore versions do not -pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc pprLExpr (L _ e) = pprExpr e -pprExpr :: OutputableBndr id => HsExpr id -> SDoc +pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e | otherwise = pprDeeper (ppr_expr e) @@ -766,15 +768,15 @@ isQuietHsExpr (HsAppTypeOut _ _) = True isQuietHsExpr (OpApp _ _ _ _) = True isQuietHsExpr _ = False -pprBinds :: (OutputableBndr idL, OutputableBndr idR) +pprBinds :: (OutputableBndrId idL, OutputableBndrId idR) => HsLocalBindsLR idL idR -> SDoc pprBinds b = pprDeeper (ppr b) ----------------------- -ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc +ppr_lexpr :: (OutputableBndrId id) => LHsExpr id -> SDoc ppr_lexpr e = ppr_expr (unLoc e) -ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc +ppr_expr :: forall id. (OutputableBndrId id) => HsExpr id -> SDoc ppr_expr (HsVar (L _ v)) = pprPrefixOcc v ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv) ppr_expr (HsIPVar v) = ppr v @@ -841,15 +843,15 @@ ppr_expr (ExplicitTuple exprs boxity) punc [] = empty ppr_expr (HsLam matches) - = pprMatches (LambdaExpr :: HsMatchContext id) matches + = pprMatches matches ppr_expr (HsLamCase matches) = sep [ sep [text "\\case {"], - nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] + nest 2 (pprMatches matches <+> char '}') ] ppr_expr (HsCase expr matches) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], - nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] + nest 2 (pprMatches matches <+> char '}') ] ppr_expr (HsIf _ e1 e2 e3) = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], @@ -959,9 +961,9 @@ ppr_expr (HsRecFld f) = ppr f -- We must tiresomely make the "id" parameter to the LHsWcType existential -- because it's different in the HsAppType case and the HsAppTypeOut case -data LHsWcTypeX = forall id. OutputableBndr id => LHsWcTypeX (LHsWcType id) +data LHsWcTypeX = forall id. (OutputableBndrId id) => LHsWcTypeX (LHsWcType id) -ppr_apps :: OutputableBndr id +ppr_apps :: (OutputableBndrId id) => HsExpr id -> [Either (LHsExpr id) LHsWcTypeX] -> SDoc @@ -993,16 +995,16 @@ fixities should do the job, except in debug mode (-dppr-debug) so we can see the structure of the parse tree. -} -pprDebugParendExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprDebugParendExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc pprDebugParendExpr expr = getPprStyle (\sty -> if debugStyle sty then pprParendLExpr expr else pprLExpr expr) -pprParendLExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprParendLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc pprParendLExpr (L _ e) = pprParendExpr e -pprParendExpr :: OutputableBndr id => HsExpr id -> SDoc +pprParendExpr :: (OutputableBndrId id) => HsExpr id -> SDoc pprParendExpr expr | hsExprNeedsParens expr = parens (pprExpr expr) | otherwise = pprExpr expr @@ -1160,16 +1162,16 @@ data HsCmdTop id (CmdSyntaxTable id) -- See Note [CmdSyntaxTable] deriving instance (DataId id) => Data (HsCmdTop id) -instance OutputableBndr id => Outputable (HsCmd id) where +instance (OutputableBndrId id) => Outputable (HsCmd id) where ppr cmd = pprCmd cmd ----------------------- -- pprCmd and pprLCmd call pprDeeper; -- the underscore versions do not -pprLCmd :: OutputableBndr id => LHsCmd id -> SDoc +pprLCmd :: (OutputableBndrId id) => LHsCmd id -> SDoc pprLCmd (L _ c) = pprCmd c -pprCmd :: OutputableBndr id => HsCmd id -> SDoc +pprCmd :: (OutputableBndrId id) => HsCmd id -> SDoc pprCmd c | isQuietHsCmd c = ppr_cmd c | otherwise = pprDeeper (ppr_cmd c) @@ -1183,10 +1185,10 @@ isQuietHsCmd (HsCmdApp _ _) = True isQuietHsCmd _ = False ----------------------- -ppr_lcmd :: OutputableBndr id => LHsCmd id -> SDoc +ppr_lcmd :: (OutputableBndrId id) => LHsCmd id -> SDoc ppr_lcmd c = ppr_cmd (unLoc c) -ppr_cmd :: forall id. OutputableBndr id => HsCmd id -> SDoc +ppr_cmd :: forall id. (OutputableBndrId id) => HsCmd id -> SDoc ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c) ppr_cmd (HsCmdApp c e) @@ -1197,11 +1199,11 @@ ppr_cmd (HsCmdApp c e) collect_args fun args = (fun, args) ppr_cmd (HsCmdLam matches) - = pprMatches (LambdaExpr :: HsMatchContext id) matches + = pprMatches matches ppr_cmd (HsCmdCase expr matches) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], - nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] + nest 2 (pprMatches matches <+> char '}') ] ppr_cmd (HsCmdIf _ e ct ce) = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], @@ -1237,13 +1239,13 @@ ppr_cmd (HsCmdArrForm op _ args) = hang (text "(|" <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> text "|)") -pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc +pprCmdArg :: (OutputableBndrId id) => HsCmdTop id -> SDoc pprCmdArg (HsCmdTop cmd@(L _ (HsCmdArrForm _ Nothing [])) _ _ _) = ppr_lcmd cmd pprCmdArg (HsCmdTop cmd _ _ _) = parens (ppr_lcmd cmd) -instance OutputableBndr id => Outputable (HsCmdTop id) where +instance (OutputableBndrId id) => Outputable (HsCmdTop id) where ppr = pprCmdArg {- @@ -1295,8 +1297,8 @@ type LMatch id body = Located (Match id body) -- For details on above see note [Api annotations] in ApiAnnotation data Match id body = Match { - m_fixity :: MatchFixity id, - -- See note [m_fixity in Match] + m_ctxt :: HsMatchContext (NameOrRdrName id), + -- See note [m_ctxt in Match] m_pats :: [LPat id], -- The patterns m_type :: (Maybe (LHsType id)), -- A type signature for the result of the match @@ -1307,9 +1309,18 @@ data Match id body deriving instance (Data body,DataId id) => Data (Match id body) {- -Note [m_fixity in Match] +Note [m_ctxt in Match] ~~~~~~~~~~~~~~~~~~~~~~ +A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and +so on. + +In order to simplify tooling processing and pretty print output, the provenance +is captured in an HsMatchContext. + +This is particularly important for the API Annotations for a multi-equation +FunBind. + The parser initially creates a FunBind with a single Match in it for every function definition it sees. @@ -1330,20 +1341,14 @@ Example infix function definition requiring individual API Annotations ( &&& ) [] ys = ys + -} --- |When a Match is part of a FunBind, it captures one complete equation for the --- function. As such it has the function name, and its fixity. -data MatchFixity id - = NonFunBindMatch - | FunBindMatch (Located id) -- of the Id - Bool -- is infix -deriving instance (DataId id) => Data (MatchFixity id) isInfixMatch :: Match id body -> Bool -isInfixMatch match = case m_fixity match of - FunBindMatch _ True -> True - _ -> False +isInfixMatch match = case m_ctxt match of + FunRhs _ Infix -> True + _ -> False isEmptyMatchGroup :: MatchGroup id body -> Bool isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms @@ -1391,35 +1396,35 @@ deriving instance (Data body,DataId id) => Data (GRHS id body) -- We know the list must have at least one @Match@ in it. -pprMatches :: (OutputableBndr idL, OutputableBndr idR, Outputable body) - => HsMatchContext idL -> MatchGroup idR body -> SDoc -pprMatches ctxt (MG { mg_alts = matches }) - = vcat (map (pprMatch ctxt) (map unLoc (unLoc matches))) +pprMatches :: (OutputableBndrId idR, Outputable body) + => MatchGroup idR body -> SDoc +pprMatches MG { mg_alts = matches } + = vcat (map pprMatch (map unLoc (unLoc matches))) -- Don't print the type; it's only a place-holder before typechecking -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body) - => idL -> MatchGroup idR body -> SDoc -pprFunBind fun matches = pprMatches (FunRhs fun) matches +pprFunBind :: (OutputableBndrId idR, Outputable body) + => MatchGroup idR body -> SDoc +pprFunBind matches = pprMatches matches -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr id body. (OutputableBndr bndr, OutputableBndr id, Outputable body) +pprPatBind :: forall bndr id body. (OutputableBndrId bndr, + OutputableBndrId id, Outputable body) => LPat bndr -> GRHSs id body -> SDoc pprPatBind pat (grhss) = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)] -pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body) - => HsMatchContext idL -> Match idR body -> SDoc -pprMatch ctxt match +pprMatch :: (OutputableBndrId idR, Outputable body) => Match idR body -> SDoc +pprMatch match = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) , nest 2 ppr_maybe_ty , nest 2 (pprGRHSs ctxt (m_grhss match)) ] where - is_infix = isInfixMatch match + ctxt = m_ctxt match (herald, other_pats) = case ctxt of - FunRhs fun - | not is_infix -> (pprPrefixOcc fun, m_pats match) + FunRhs (L _ fun) fixity + | fixity == Prefix -> (pprPrefixOcc fun, m_pats match) -- f x y z = e -- Not pprBndr; the AbsBinds will -- have printed the signature @@ -1444,14 +1449,14 @@ pprMatch ctxt match Nothing -> empty -pprGRHSs :: (OutputableBndr idR, Outputable body) +pprGRHSs :: (OutputableBndrId idR, Outputable body) => HsMatchContext idL -> GRHSs idR body -> SDoc pprGRHSs ctxt (GRHSs grhss (L _ binds)) = vcat (map (pprGRHS ctxt . unLoc) grhss) $$ ppUnless (isEmptyLocalBinds binds) (text "where" $$ nest 4 (pprBinds binds)) -pprGRHS :: (OutputableBndr idR, Outputable body) +pprGRHS :: (OutputableBndrId idR, Outputable body) => HsMatchContext idL -> GRHS idR body -> SDoc pprGRHS ctxt (GRHS [] body) = pp_rhs ctxt body @@ -1777,15 +1782,15 @@ In any other context than 'MonadComp', the fields for most of these 'SyntaxExpr's stay bottom. -} -instance (OutputableBndr idL) - => Outputable (ParStmtBlock idL idR) where +instance (OutputableBndrId idL) => Outputable (ParStmtBlock idL idR) where ppr (ParStmtBlock stmts _ _) = interpp'SP stmts -instance (OutputableBndr idL, OutputableBndr idR, Outputable body) +instance (OutputableBndrId idL, OutputableBndrId idR, Outputable body) => Outputable (StmtLR idL idR body) where ppr stmt = pprStmt stmt -pprStmt :: forall idL idR body . (OutputableBndr idL, OutputableBndr idR, Outputable body) +pprStmt :: forall idL idR body . (OutputableBndrId idL, OutputableBndrId idR, + Outputable body) => (StmtLR idL idR body) -> SDoc pprStmt (LastStmt expr ret_stripped _) = ifPprDebug (text "[last]") <+> @@ -1848,7 +1853,8 @@ pprStmt (ApplicativeStmt args mb_join _) (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])) (error "pprStmt")) -pprTransformStmt :: OutputableBndr id => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc +pprTransformStmt :: (OutputableBndrId id) + => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc pprTransformStmt bndrs using by = sep [ text "then" <+> ifPprDebug (braces (ppr bndrs)) , nest 2 (ppr using) @@ -1864,7 +1870,7 @@ pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty pprBy (Just e) = text "by" <+> ppr e -pprDo :: (OutputableBndr id, Outputable body) +pprDo :: (OutputableBndrId id, Outputable body) => HsStmtContext any -> [LStmt id body] -> SDoc pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts @@ -1875,7 +1881,7 @@ pprDo PArrComp stmts = paBrackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt -ppr_do_stmts :: (OutputableBndr idL, OutputableBndr idR, Outputable body) +ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) => [LStmtLR idL idR body] -> SDoc -- Print a bunch of do stmts, with explicit braces and semicolons, -- so that we are not vulnerable to layout bugs @@ -1883,7 +1889,7 @@ ppr_do_stmts stmts = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts)) <+> rbrace -pprComp :: (OutputableBndr id, Outputable body) +pprComp :: (OutputableBndrId id, Outputable body) => [LStmt id body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | not (null quals) @@ -1892,7 +1898,7 @@ pprComp quals -- Prints: body | qual1, ..., qualn | otherwise = pprPanic "pprComp" (pprQuals quals) -pprQuals :: (OutputableBndr id, Outputable body) +pprQuals :: (OutputableBndrId id, Outputable body) => [LStmt id body] -> SDoc -- Show list comprehension qualifiers separated by commas pprQuals quals = interpp'SP quals @@ -2009,13 +2015,14 @@ splices. In contrast, when pretty printing the output of the type checker, we sense, although I hate to add another constructor to HsExpr. -} -instance OutputableBndr id => Outputable (HsSplice id) where +instance (OutputableBndrId id) => Outputable (HsSplice id) where ppr s = pprSplice s -pprPendingSplice :: OutputableBndr id => SplicePointName -> LHsExpr id -> SDoc +pprPendingSplice :: (OutputableBndrId id) + => SplicePointName -> LHsExpr id -> SDoc pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) -pprSplice :: OutputableBndr id => HsSplice id -> SDoc +pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc pprSplice (HsTypedSplice n e) = ppr_splice (text "$$") n e pprSplice (HsUntypedSplice n e) = ppr_splice (text "$") n e pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s @@ -2025,7 +2032,7 @@ ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <> char '[' <> ppr quoter <> vbar <> ppr quote <> text "|]" -ppr_splice :: OutputableBndr id => SDoc -> id -> LHsExpr id -> SDoc +ppr_splice :: (OutputableBndrId id) => SDoc -> id -> LHsExpr id -> SDoc ppr_splice herald n e = herald <> ifPprDebug (brackets (ppr n)) <> eDoc where @@ -2052,11 +2059,11 @@ isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True isTypedBracket _ = False -instance OutputableBndr id => Outputable (HsBracket id) where +instance (OutputableBndrId id) => Outputable (HsBracket id) where ppr = pprHsBracket -pprHsBracket :: OutputableBndr id => HsBracket id -> SDoc +pprHsBracket :: (OutputableBndrId id) => HsBracket id -> SDoc pprHsBracket (ExpBr e) = thBrackets empty (ppr e) pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) @@ -2098,7 +2105,7 @@ data ArithSeqInfo id (LHsExpr id) deriving instance (DataId id) => Data (ArithSeqInfo id) -instance OutputableBndr id => Outputable (ArithSeqInfo id) where +instance (OutputableBndrId id) => Outputable (ArithSeqInfo id) where ppr (From e1) = hcat [ppr e1, pp_dotdot] ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] @@ -2116,40 +2123,49 @@ pp_dotdot = text " .. " ************************************************************************ -} -data HsMatchContext id -- Context of a Match - = FunRhs id -- Function binding for f - | LambdaExpr -- Patterns of a lambda - | CaseAlt -- Patterns and guards on a case alternative - | IfAlt -- Guards of a multi-way if alternative - | ProcExpr -- Patterns of a proc - | PatBindRhs -- A pattern binding eg [y] <- e = e +data FunctionFixity = Prefix | Infix deriving (Typeable,Data,Eq) - | RecUpd -- Record update [used only in DsExpr to +instance Outputable FunctionFixity where + ppr Prefix = text "Prefix" + ppr Infix = text "Infix" + +-- | Context of a Match +data HsMatchContext id + = FunRhs (Located id) FunctionFixity -- ^Function binding for f, fixity + | LambdaExpr -- ^Patterns of a lambda + | CaseAlt -- ^Patterns and guards on a case alternative + | IfAlt -- ^Guards of a multi-way if alternative + | ProcExpr -- ^Patterns of a proc + | PatBindRhs -- ^A pattern binding eg [y] <- e = e + + | RecUpd -- ^Record update [used only in DsExpr to -- tell matchWrapper what sort of -- runtime error message to generate] - | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt, list comprehension, + | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension, -- pattern guard, etc - | ThPatSplice -- A Template Haskell pattern splice - | ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |] - | PatSyn -- A pattern synonym declaration - deriving Data + | ThPatSplice -- ^A Template Haskell pattern splice + | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] + | PatSyn -- ^A pattern synonym declaration + deriving Functor +deriving instance (DataIdPost id) => Data (HsMatchContext id) data HsStmtContext id = ListComp | MonadComp - | PArrComp -- Parallel array comprehension + | PArrComp -- ^Parallel array comprehension - | DoExpr -- do { ... } - | MDoExpr -- mdo { ... } ie recursive do-expression - | ArrowExpr -- do-notation in an arrow-command context + | DoExpr -- ^do { ... } + | MDoExpr -- ^mdo { ... } ie recursive do-expression + | ArrowExpr -- ^do-notation in an arrow-command context - | GhciStmtCtxt -- A command-line Stmt in GHCi pat <- rhs - | PatGuard (HsMatchContext id) -- Pattern guard for specified thing - | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt - | TransStmtCtxt (HsStmtContext id) -- A branch of a transform stmt - deriving Data + | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs + | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing + | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt + | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt + deriving Functor +deriving instance (DataIdPost id) => Data (HsStmtContext id) isListCompExpr :: HsStmtContext id -> Bool -- Uses syntax [ e | quals ] @@ -2179,7 +2195,8 @@ matchSeparator ThPatSplice = panic "unused" matchSeparator ThPatQuote = panic "unused" matchSeparator PatSyn = panic "unused" -pprMatchContext :: Outputable id => HsMatchContext id -> SDoc +pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id) + => HsMatchContext id -> SDoc pprMatchContext ctxt | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt | otherwise = text "a" <+> pprMatchContextNoun ctxt @@ -2188,8 +2205,9 @@ pprMatchContext ctxt want_an ProcExpr = True want_an _ = False -pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc -pprMatchContextNoun (FunRhs fun) = text "equation for" +pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id) + => HsMatchContext id -> SDoc +pprMatchContextNoun (FunRhs (L _ fun) _) = text "equation for" <+> quotes (ppr fun) pprMatchContextNoun CaseAlt = text "case alternative" pprMatchContextNoun IfAlt = text "multi-way if alternative" @@ -2204,7 +2222,9 @@ pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" pprMatchContextNoun PatSyn = text "pattern synonym declaration" ----------------- -pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc +pprAStmtContext, pprStmtContext :: (Outputable id, + Outputable (NameOrRdrName id)) + => HsStmtContext id -> SDoc pprAStmtContext ctxt = article <+> pprStmtContext ctxt where pp_an = text "an" @@ -2240,8 +2260,9 @@ pprStmtContext (TransStmtCtxt c) -- Used to generate the string for a *runtime* error message -matchContextErrString :: Outputable id => HsMatchContext id -> SDoc -matchContextErrString (FunRhs fun) = text "function" <+> ppr fun +matchContextErrString :: Outputable id + => HsMatchContext id -> SDoc +matchContextErrString (FunRhs (L _ fun) _) = text "function" <+> ppr fun matchContextErrString CaseAlt = text "case" matchContextErrString IfAlt = text "multi-way if" matchContextErrString PatBindRhs = text "pattern binding" @@ -2262,12 +2283,15 @@ matchContextErrString (StmtCtxt ListComp) = text "list comprehension" matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" matchContextErrString (StmtCtxt PArrComp) = text "array comprehension" -pprMatchInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) - => HsMatchContext idL -> Match idR body -> SDoc -pprMatchInCtxt ctxt match = hang (text "In" <+> pprMatchContext ctxt <> colon) - 4 (pprMatch ctxt match) +pprMatchInCtxt :: (OutputableBndrId idR, + Outputable (NameOrRdrName (NameOrRdrName idR)), + Outputable body) + => Match idR body -> SDoc +pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) + <> colon) + 4 (pprMatch match) -pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) +pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) => HsStmtContext idL -> StmtLR idL idR body -> SDoc pprStmtInCtxt ctxt (LastStmt e _ _) | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot index ff4b2bc07b..022ca6bbc4 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -8,9 +8,9 @@ module HsExpr where import SrcLoc ( Located ) -import Outputable ( SDoc, OutputableBndr, Outputable ) +import Outputable ( SDoc, Outputable ) import {-# SOURCE #-} HsPat ( LPat ) -import PlaceHolder ( DataId ) +import PlaceHolder ( DataId, OutputableBndrId ) import Data.Data hiding ( Fixity ) type role HsExpr nominal @@ -33,21 +33,20 @@ instance (Data body,DataId id) => Data (MatchGroup id body) instance (Data body,DataId id) => Data (GRHSs id body) instance (DataId id) => Data (SyntaxExpr id) -instance OutputableBndr id => Outputable (HsExpr id) -instance OutputableBndr id => Outputable (HsCmd id) +instance (OutputableBndrId id) => Outputable (HsExpr id) +instance (OutputableBndrId id) => Outputable (HsCmd id) type LHsExpr a = Located (HsExpr a) -pprLExpr :: (OutputableBndr i) => - LHsExpr i -> SDoc +pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc -pprExpr :: (OutputableBndr i) => - HsExpr i -> SDoc +pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc -pprSplice :: (OutputableBndr i) => HsSplice i -> SDoc +pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc -pprPatBind :: (OutputableBndr bndr, OutputableBndr id, Outputable body) +pprPatBind :: (OutputableBndrId bndr, + OutputableBndrId id, Outputable body) => LPat bndr -> GRHSs id body -> SDoc -pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body) - => idL -> MatchGroup idR body -> SDoc +pprFunBind :: (OutputableBndrId idR, Outputable body) + => MatchGroup idR body -> SDoc diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index 4fa0a64afd..18746c057a 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -23,7 +23,7 @@ import BasicTypes ( FractionalLit(..),SourceText ) import Type ( Type ) import Outputable import FastString -import PlaceHolder ( PostTc,PostRn,DataId ) +import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId ) import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) @@ -165,7 +165,7 @@ instance Outputable HsLit where ppr (HsWord64Prim _ w) = pprPrimWord64 w -- in debug mode, print the expression that it's resolved to, too -instance OutputableBndr id => Outputable (HsOverLit id) where +instance (OutputableBndrId id) => Outputable (HsOverLit id) where ppr (OverLit {ol_val=val, ol_witness=witness}) = ppr val <+> (ifPprDebug (parens (pprExpr witness))) diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index c168def337..ef667a1d71 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -43,7 +43,7 @@ import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr -- friends: import HsBinds import HsLit -import PlaceHolder -- ( PostRn,PostTc,DataId ) +import PlaceHolder import HsTypes import TcEvidence import BasicTypes @@ -365,7 +365,7 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl ************************************************************************ -} -instance (OutputableBndr name) => Outputable (Pat name) where +instance (OutputableBndrId name) => Outputable (Pat name) where ppr = pprPat pprPatBndr :: OutputableBndr name => name -> SDoc @@ -377,10 +377,10 @@ pprPatBndr var -- Print with type info if -dppr-debug is on else pprPrefixOcc var -pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc +pprParendLPat :: (OutputableBndrId name) => LPat name -> SDoc pprParendLPat (L _ p) = pprParendPat p -pprParendPat :: (OutputableBndr name) => Pat name -> SDoc +pprParendPat :: (OutputableBndrId name) => Pat name -> SDoc pprParendPat p = sdocWithDynFlags $ \ dflags -> if need_parens dflags p then parens (pprPat p) @@ -394,7 +394,7 @@ pprParendPat p = sdocWithDynFlags $ \ dflags -> -- But otherwise the CoPat is discarded, so it -- is the pattern inside that matters. Sigh. -pprPat :: (OutputableBndr name) => Pat name -> SDoc +pprPat :: (OutputableBndrId name) => Pat name -> SDoc pprPat (VarPat (L _ var)) = pprPatBndr var pprPat (WildPat _) = char '_' pprPat (LazyPat pat) = char '~' <> pprParendLPat pat @@ -430,11 +430,12 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, else pprUserCon (unLoc con) details -pprUserCon :: (OutputableBndr con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc +pprUserCon :: (OutputableBndr con, OutputableBndrId id) + => con -> HsConPatDetails id -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 pprUserCon c details = pprPrefixOcc c <+> pprConArgs details -pprConArgs :: OutputableBndr id => HsConPatDetails id -> SDoc +pprConArgs :: (OutputableBndrId id) => HsConPatDetails id -> SDoc pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats) pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2] pprConArgs (RecCon rpats) = ppr rpats @@ -546,7 +547,7 @@ looksLazyLPat (L _ (VarPat {})) = False looksLazyLPat (L _ (WildPat {})) = False looksLazyLPat _ = True -isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool +isIrrefutableHsPat :: (OutputableBndrId id) => LPat id -> Bool -- (isIrrefutableHsPat p) is true if matching against p cannot fail, -- in the sense of falling through to the next pattern. -- (NB: this is not quite the same as the (silly) defn diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot index 6e000e3808..aba5686085 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot @@ -10,11 +10,11 @@ import SrcLoc( Located ) import Data.Data hiding (Fixity) import Outputable -import PlaceHolder ( DataId ) +import PlaceHolder ( DataId, OutputableBndrId ) type role Pat nominal data Pat (i :: *) type LPat i = Located (Pat i) instance (DataId id) => Data (Pat id) -instance (OutputableBndr name) => Outputable (Pat name) +instance (OutputableBndrId name) => Outputable (Pat name) diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index 76d31a4182..1cfb8b8a1d 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -107,7 +107,7 @@ data HsModule name -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (HsModule name) -instance (OutputableBndr name, HasOccName name) +instance (OutputableBndrId name, HasOccName name) => Outputable (HsModule name) where ppr (HsModule Nothing _ imports decls _ mbDoc) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 66145b6588..e5f0f9cde5 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -69,7 +69,8 @@ module HsTypes ( import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) -import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) ) +import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..), + OutputableBndrId ) import Id ( Id ) import Name( Name ) @@ -584,7 +585,7 @@ data HsAppType name | HsAppPrefix (LHsType name) -- anything else, including things like (+) deriving instance (DataId name) => Data (HsAppType name) -instance OutputableBndr name => Outputable (HsAppType name) where +instance (OutputableBndrId name) => Outputable (HsAppType name) where ppr = ppr_app_ty TopPrec {- @@ -715,7 +716,7 @@ data ConDeclField name -- Record fields have Haddoc docs on them -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (ConDeclField name) -instance (OutputableBndr name) => Outputable (ConDeclField name) where +instance (OutputableBndrId name) => Outputable (ConDeclField name) where ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty -- HsConDetails is used for patterns/expressions *and* for data type @@ -1104,16 +1105,16 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel ************************************************************************ -} -instance (OutputableBndr name) => Outputable (HsType name) where +instance (OutputableBndrId name) => Outputable (HsType name) where ppr ty = pprHsType ty instance Outputable HsTyLit where ppr = ppr_tylit -instance (OutputableBndr name) => Outputable (LHsQTyVars name) where +instance (OutputableBndrId name) => Outputable (LHsQTyVars name) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs -instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where +instance (OutputableBndrId name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar n) = ppr n ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k] @@ -1126,7 +1127,8 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs name thing) where instance Outputable (HsWildCardInfo name) where ppr (AnonWildCard _) = char '_' -pprHsForAll :: OutputableBndr name => [LHsTyVarBndr name] -> LHsContext name -> SDoc +pprHsForAll :: (OutputableBndrId name) + => [LHsTyVarBndr name] -> LHsContext name -> SDoc pprHsForAll = pprHsForAllExtra Nothing -- | Version of 'pprHsForAll' that can also print an extra-constraints @@ -1136,32 +1138,34 @@ pprHsForAll = pprHsForAllExtra Nothing -- function for this is needed, as the extra-constraints wildcard is removed -- from the actual context and type, and stored in a separate field, thus just -- printing the type will not print the extra-constraints wildcard. -pprHsForAllExtra :: OutputableBndr name => Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name -> SDoc +pprHsForAllExtra :: (OutputableBndrId name) + => Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name + -> SDoc pprHsForAllExtra extra qtvs cxt = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt) where show_extra = isJust extra -pprHsForAllTvs :: OutputableBndr name => [LHsTyVarBndr name] -> SDoc +pprHsForAllTvs :: (OutputableBndrId name) => [LHsTyVarBndr name] -> SDoc pprHsForAllTvs qtvs | show_forall = forAllLit <+> interppSP qtvs <> dot | otherwise = empty where show_forall = opt_PprStyle_Debug || not (null qtvs) -pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc +pprHsContext :: (OutputableBndrId name) => HsContext name -> SDoc pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe -pprHsContextNoArrow :: (OutputableBndr name) => HsContext name -> SDoc +pprHsContextNoArrow :: (OutputableBndrId name) => HsContext name -> SDoc pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe -pprHsContextMaybe :: (OutputableBndr name) => HsContext name -> Maybe SDoc +pprHsContextMaybe :: (OutputableBndrId name) => HsContext name -> Maybe SDoc pprHsContextMaybe [] = Nothing pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt) -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ -pprHsContextExtra :: (OutputableBndr name) => Bool -> HsContext name -> SDoc +pprHsContextExtra :: (OutputableBndrId name) => Bool -> HsContext name -> SDoc pprHsContextExtra show_extra ctxt | not show_extra = pprHsContext ctxt @@ -1172,7 +1176,7 @@ pprHsContextExtra show_extra ctxt where ctxt' = map ppr ctxt ++ [char '_'] -pprConDeclFields :: OutputableBndr name => [LConDeclField name] -> SDoc +pprConDeclFields :: (OutputableBndrId name) => [LConDeclField name] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, @@ -1196,7 +1200,7 @@ seems like the Right Thing anyway.) -- Printing works more-or-less as for Types -pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc +pprHsType, pprParendHsType :: (OutputableBndrId name) => HsType name -> SDoc pprHsType ty = ppr_mono_ty TopPrec (prepare ty) pprParendHsType ty = ppr_mono_ty TyConPrec ty @@ -1207,10 +1211,10 @@ prepare (HsParTy ty) = prepare (unLoc ty) prepare (HsAppsTy [L _ (HsAppPrefix (L _ ty))]) = prepare ty prepare ty = ty -ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc +ppr_mono_lty :: (OutputableBndrId name) => TyPrec -> LHsType name -> SDoc ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) -ppr_mono_ty :: (OutputableBndr name) => TyPrec -> HsType name -> SDoc +ppr_mono_ty :: (OutputableBndrId name) => TyPrec -> HsType name -> SDoc ppr_mono_ty ctxt_prec (HsForAllTy { hst_bndrs = tvs, hst_body = ty }) = maybeParen ctxt_prec FunPrec $ sep [pprHsForAllTvs tvs, ppr_mono_lty TopPrec ty] @@ -1268,7 +1272,8 @@ ppr_mono_ty ctxt_prec (HsDocTy ty doc) -- postfix operators -------------------------- -ppr_fun_ty :: (OutputableBndr name) => TyPrec -> LHsType name -> LHsType name -> SDoc +ppr_fun_ty :: (OutputableBndrId name) + => TyPrec -> LHsType name -> LHsType name -> SDoc ppr_fun_ty ctxt_prec ty1 ty2 = let p1 = ppr_mono_lty FunPrec ty1 p2 = ppr_mono_lty TopPrec ty2 @@ -1277,7 +1282,7 @@ ppr_fun_ty ctxt_prec ty1 ty2 sep [p1, text "->" <+> p2] -------------------------- -ppr_app_ty :: OutputableBndr name => TyPrec -> HsAppType name -> SDoc +ppr_app_ty :: (OutputableBndrId name) => TyPrec -> HsAppType name -> SDoc ppr_app_ty _ (HsAppInfix (L _ n)) = pprInfixOcc n ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar (L _ n)))) = pprPrefixOcc n ppr_app_ty ctxt (HsAppPrefix ty) = ppr_mono_lty ctxt ty diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 6b90f001b0..43d60a3667 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -20,7 +20,7 @@ which deal with the instantiated versions are located elsewhere: module HsUtils( -- Terms - mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsConApp, mkSimpleHsAlt, + mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsConApp, mkHsCaseAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, @@ -133,10 +133,12 @@ just attach noSrcSpan to everything. mkHsPar :: LHsExpr id -> LHsExpr id mkHsPar e = L (getLoc e) (HsPar e) -mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id)) -mkSimpleMatch pats rhs +mkSimpleMatch :: HsMatchContext (NameOrRdrName id) + -> [LPat id] -> Located (body id) + -> LMatch id (Located (body id)) +mkSimpleMatch ctxt pats rhs = L loc $ - Match NonFunBindMatch pats Nothing (unguardedGRHSs rhs) + Match ctxt pats Nothing (unguardedGRHSs rhs) where loc = case pats of [] -> getLoc rhs @@ -178,8 +180,9 @@ mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t) mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) - where - matches = mkMatchGroup Generated [mkSimpleMatch pats body] + where + matches = mkMatchGroup Generated + [mkSimpleMatch LambdaExpr pats body] mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars @@ -192,10 +195,11 @@ mkHsConApp data_con tys args where mk_app f a = noLoc (HsApp f (noLoc a)) -mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id)) --- A simple lambda with a single pattern, no binds, no guards; pre-typechecking -mkSimpleHsAlt pat expr - = mkSimpleMatch [pat] expr +-- |A simple case alternative with a single pattern, no binds, no guards; +-- pre-typechecking +mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id)) +mkHsCaseAlt pat expr + = mkSimpleMatch CaseAlt [pat] expr nlHsTyApp :: name -> [Type] -> LHsExpr name nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id))) @@ -709,13 +713,15 @@ isInfixFunBind _ = False mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] -> LHsExpr RdrName -> LHsBind RdrName mk_easy_FunBind loc fun pats expr - = L loc $ mkFunBind (L loc fun) [mkMatch pats expr (noLoc emptyLocalBinds)] + = L loc $ mkFunBind (L loc fun) + [mkMatch (FunRhs (L loc fun) Prefix) pats expr + (noLoc emptyLocalBinds)] ------------ -mkMatch :: [LPat id] -> LHsExpr id -> Located (HsLocalBinds id) - -> LMatch id (LHsExpr id) -mkMatch pats expr lbinds - = noLoc (Match NonFunBindMatch (map paren pats) Nothing +mkMatch :: HsMatchContext (NameOrRdrName id) -> [LPat id] -> LHsExpr id + -> Located (HsLocalBinds id) -> LMatch id (LHsExpr id) +mkMatch ctxt pats expr lbinds + = noLoc (Match ctxt (map paren pats) Nothing (GRHSs (unguardedRHS noSrcSpan expr) lbinds)) where paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index cacad7111c..7b3391d533 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -17,6 +17,7 @@ import ConLike (ConLike) import FieldLabel import SrcLoc (Located) import TcEvidence ( HsWrapper ) +import Outputable ( OutputableBndr ) import Data.Data hiding ( Fixity ) import BasicTypes (Fixity) @@ -97,9 +98,18 @@ In terms of actual usage, we have the following PostRn id NameSet TcId and Var are synonyms for Id + +Unfortunately the type checker termination checking conditions fail for the +DataId constraint type based on this, so even though it is safe the +UndecidableInstances pragma is required where this is used. -} type DataId id = + ( DataIdPost id + , DataIdPost (NameOrRdrName id) + ) + +type DataIdPost id = ( Data id , Data (PostRn id NameSet) , Data (PostRn id Fixity) @@ -107,7 +117,7 @@ type DataId id = , Data (PostRn id Name) , Data (PostRn id (Located Name)) , Data (PostRn id [Name]) --- , Data (PostRn id [id]) + , Data (PostRn id id) , Data (PostTc id Type) , Data (PostTc id Coercion) @@ -118,3 +128,18 @@ type DataId id = , Data (PostTc id HsWrapper) , Data (PostTc id [FieldLabel]) ) + + +-- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext', +-- for printing messages related to a 'Match' +type family NameOrRdrName id where + NameOrRdrName Id = Name + NameOrRdrName Name = Name + NameOrRdrName RdrName = RdrName + +-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both +-- the @id@ and the 'NameOrRdrName' type for it +type OutputableBndrId id = + ( OutputableBndr id + , OutputableBndr (NameOrRdrName id) + ) diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index cc1e842be0..78020f72bc 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -3,6 +3,9 @@ -- -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -- + +{-# LANGUAGE FlexibleContexts #-} + module HscStats ( ppSourceStats ) where import Bag diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index e1c8559933..b0b64aea5c 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -2131,7 +2131,7 @@ infixexp :: { LHsExpr RdrName } exp10 :: { LHsExpr RdrName } : '\\' apat apats opt_asig '->' exp {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource - [sLL $1 $> $ Match { m_fixity = NonFunBindMatch + [sLL $1 $> $ Match { m_ctxt = LambdaExpr , m_pats = $2:$3 , m_type = snd $4 , m_grhss = unguardedGRHSs $6 }])) @@ -2550,7 +2550,7 @@ alts1 :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } | alt { sL1 $1 ([],[$1]) } alt :: { LMatch RdrName (LHsExpr RdrName) } - : pat opt_asig alt_rhs {%ams (sLL $1 $> (Match { m_fixity = NonFunBindMatch + : pat opt_asig alt_rhs {%ams (sLL $1 $> (Match { m_ctxt = CaseAlt , m_pats = [$1] , m_type = snd $2 , m_grhss = snd $ unLoc $3 })) diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 43ff23092a..af1e53e866 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -502,9 +502,10 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = do { unless (name == patsyn_name) $ wrongNameBindingErr loc decl ; match <- case details of - PrefixCon pats -> return $ Match (FunBindMatch ln False) pats Nothing rhs + PrefixCon pats -> + return $ Match (FunRhs ln Prefix) pats Nothing rhs InfixCon pat1 pat2 -> - return $ Match (FunBindMatch ln True) [pat1, pat2] Nothing rhs + return $ Match (FunRhs ln Infix) [pat1, pat2] Nothing rhs RecCon{} -> recordPatSynErr loc pat ; return $ L loc match } fromDecl (L loc decl) = extraDeclErr loc decl @@ -919,7 +920,7 @@ checkFunBind :: SDoc -> [AddAnn] -> SrcSpan -> Located RdrName - -> Bool + -> FunctionFixity -> [LHsExpr RdrName] -> Maybe (LHsType RdrName) -> Located (GRHSs RdrName (LHsExpr RdrName)) @@ -930,7 +931,7 @@ checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) -- Add back the annotations stripped from any HsPar values in the lhs -- mapM_ (\a -> a match_span) ann return (ann, makeFunBind fun - [L match_span (Match { m_fixity = FunBindMatch fun is_infix + [L match_span (Match { m_ctxt = FunRhs fun is_infix , m_pats = ps , m_type = opt_sig , m_grhss = grhss })]) @@ -1024,7 +1025,7 @@ splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg)) splitBang _ = Nothing isFunLhs :: LHsExpr RdrName - -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName],[AddAnn])) + -> P (Maybe (Located RdrName, FunctionFixity, [LHsExpr RdrName],[AddAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS -- @@ -1040,7 +1041,7 @@ isFunLhs :: LHsExpr RdrName isFunLhs e = go e [] [] where go (L loc (HsVar (L _ f))) es ann - | not (isRdrDataCon f) = return (Just (L loc f, False, es, ann)) + | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) go (L _ (HsApp f e)) es ann = go f (e:es) ann go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) @@ -1061,15 +1062,15 @@ isFunLhs e = go e [] [] | Just (e',es') <- splitBang e = do { bang_on <- extension bangPatEnabled ; if bang_on then go e' (es' ++ es) ann - else return (Just (L loc' op, True, (l:r:es), ann)) } + else return (Just (L loc' op, Infix, (l:r:es), ann)) } -- No bangs; behave just like the next case | not (isRdrDataCon op) -- We have found the function! - = return (Just (L loc' op, True, (l:r:es), ann)) + = return (Just (L loc' op, Infix, (l:r:es), ann)) | otherwise -- Infix data con; keep going = do { mb_l <- go l es ann ; case mb_l of - Just (op', True, j : k : es', ann') - -> return (Just (op', True, j : op_app : es', ann')) + Just (op', Infix, j : k : es', ann') + -> return (Just (op', Infix, j : op_app : es', ann')) where op_app = L loc (OpApp k (L loc' (HsVar (L loc' op))) fix r) _ -> return Nothing } diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 61f4dd8a3e..0466de375e 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -467,7 +467,7 @@ rnBind sig_fn bind@(FunBind { fun_id = name ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ -- bindSigTyVars tests for LangExt.ScopedTyVars - rnMatchGroup (FunRhs plain_name) + rnMatchGroup (FunRhs name Prefix) rnLExpr matches ; let is_infix = isInfixFunBind bind ; when is_infix $ checkPrecMatch plain_name matches' @@ -612,7 +612,7 @@ dupFixityDecl loc rdr_name rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function -> PatSynBind Name RdrName -> RnM (PatSynBind Name Name, [Name], Uses) -rnPatSynBind sig_fn bind@(PSB { psb_id = L _ name +rnPatSynBind sig_fn bind@(PSB { psb_id = L l name , psb_args = details , psb_def = pat , psb_dir = dir }) @@ -657,7 +657,8 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L _ name ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) ExplicitBidirectional mg -> do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $ - rnMatchGroup PatSyn rnLExpr mg + rnMatchGroup (FunRhs (L l name) Prefix) + rnLExpr mg ; return (ExplicitBidirectional mg', fvs) } ; mod <- getModule @@ -1031,23 +1032,23 @@ rnMatch' :: Outputable (body RdrName) => HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> Match RdrName (Located (body RdrName)) -> RnM (Match Name (Located (body Name)), FreeVars) -rnMatch' ctxt rnBody match@(Match { m_fixity = mf, m_pats = pats +rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats , m_type = maybe_rhs_sig, m_grhss = grhss }) = do { -- Result type signatures are no longer supported case maybe_rhs_sig of Nothing -> return () - Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty) + Just (L loc ty) -> addErrAt loc (resSigErr match ty) - ; let isinfix = isInfixMatch match + ; let fixity = if isInfixMatch match then Infix else Prefix -- Now the main event -- Note that there are no local fixity decls for matches ; rnPats ctxt pats $ \ pats' -> do { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss ; let mf' = case (ctxt,mf) of - (FunRhs funid,FunBindMatch (L lf _) _) - -> FunBindMatch (L lf funid) isinfix - _ -> NonFunBindMatch - ; return (Match { m_fixity = mf', m_pats = pats' + (FunRhs (L _ funid) _,FunRhs (L lf _) _) + -> FunRhs (L lf funid) fixity + _ -> ctxt + ; return (Match { m_ctxt = mf', m_pats = pats' , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }} emptyCaseErr :: HsMatchContext Name -> SDoc @@ -1061,12 +1062,12 @@ emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) resSigErr :: Outputable body - => HsMatchContext Name -> Match RdrName body -> HsType RdrName -> SDoc -resSigErr ctxt match ty + => Match RdrName body -> HsType RdrName -> SDoc +resSigErr match ty = vcat [ text "Illegal result type signature" <+> quotes (ppr ty) , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches") - , pprMatchInCtxt ctxt match ] + , pprMatchInCtxt match ] {- ************************************************************************ diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index 00dac01227..33eb83b401 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} module TcAnnotations ( tcAnnotations, annCtxt ) where @@ -64,6 +65,6 @@ annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod #endif -annCtxt :: OutputableBndr id => AnnDecl id -> SDoc +annCtxt :: (OutputableBndrId id) => AnnDecl id -> SDoc annCtxt ann = hang (text "In the annotation:") 2 (ppr ann) diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 052c49cb19..f2424eacc6 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -241,7 +241,7 @@ tc_cmd env (match@(Match _ pats _maybe_rhs_sig grhss))], mg_origin = origin })) (cmd_stk, res_ty) - = addErrCtxt (pprMatchInCtxt match_ctxt match) $ + = addErrCtxt (pprMatchInCtxt match) $ do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk -- Check the patterns, and the GRHSs inside @@ -249,7 +249,7 @@ tc_cmd env tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $ tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) - ; let match' = L mtch_loc (Match NonFunBindMatch pats' Nothing grhss') + ; let match' = L mtch_loc (Match LambdaExpr pats' Nothing grhss') arg_tys = map hsLPatType pats' cmd' = HsCmdLam (MG { mg_alts = L l [match'], mg_arg_tys = arg_tys , mg_res_ty = res_ty, mg_origin = origin }) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index fc04ec9999..b34ad0bcad 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, tcValBinds, tcHsBootSigs, tcPolyCheck, @@ -1462,7 +1463,7 @@ tcMonoBinds is_rec sig_fn no_gen -- We extend the error context even for a non-recursive -- function so that in type error messages we show the -- type of the thing whose rhs we are type checking - tcMatchesFun name matches rhs_ty + tcMatchesFun (L nm_loc name) matches rhs_ty ; rhs_ty <- readExpType rhs_ty -- Deeply instantiate the inferred type @@ -1593,7 +1594,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) = tcExtendIdBinderStackForRhs [info] $ tcExtendTyVarEnvForRhs mb_sig $ do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) - ; (co_fn, matches') <- tcMatchesFun (idName mono_id) + ; (co_fn, matches') <- tcMatchesFun (noLoc $ idName mono_id) matches (mkCheckExpType $ idType mono_id) ; emitWildCardHoles info ; return ( FunBind { fun_id = L loc mono_id @@ -2114,7 +2115,8 @@ the common case.) -} -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc +patMonoBindsCtxt :: (OutputableBndrId id, Outputable body) + => LPat id -> GRHSs Name body -> SDoc patMonoBindsCtxt pat grhss = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 006a2f9739..42a03142c1 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -1,7 +1,10 @@ -- (c) The University of Glasgow 2006 {-# LANGUAGE CPP, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an -- orphan +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder module TcEnv( TyThing(..), TcTyThing(..), TcId, @@ -823,10 +826,10 @@ data InstBindings a -- Used only to improve error messages } -instance OutputableBndr a => Outputable (InstInfo a) where +instance (OutputableBndrId a) => Outputable (InstInfo a) where ppr = pprInstInfoDetails -pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc +pprInstInfoDetails :: (OutputableBndrId a) => InstInfo a -> SDoc pprInstInfoDetails info = hang (pprInstanceHdr (iSpec info) <+> text "where") 2 (details (iBinds info)) diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index d4a9f38179..5089cab80a 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC, tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC, @@ -237,7 +238,7 @@ tcExpr (HsLam match) res_ty match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } herald = sep [ text "The lambda expression" <+> quotes (pprSetDepth (PartWay 1) $ - pprMatches (LambdaExpr :: HsMatchContext Name) match), + pprMatches match), -- The pprSetDepth makes the abstraction print briefly text "has"] diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 4157b02b72..e01586c300 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -407,13 +407,14 @@ gen_Ord_binds loc tycon | otherwise -- Mixed nullary and non-nullary = nlHsCase (nlHsVar a_RDR) $ (map (mkOrdOpAlt op) non_nullary_cons - ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)]) + ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)]) mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName) -- Make the alternative (Ki a1 a2 .. av -> mkOrdOpAlt op data_con - = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con) + = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed) + (mkInnerRhs op data_con) where as_needed = take (dataConSourceArity data_con) as_RDRs data_con_RDR = getRdrName data_con @@ -424,33 +425,35 @@ gen_Ord_binds loc tycon | tag == first_tag = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkSimpleHsAlt nlWildPat (ltResult op) ] + , mkHsCaseAlt nlWildPat (ltResult op) ] | tag == last_tag = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkSimpleHsAlt nlWildPat (gtResult op) ] + , mkHsCaseAlt nlWildPat (gtResult op) ] | tag == first_tag + 1 - = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op) + = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con) + (gtResult op) , mkInnerEqAlt op data_con - , mkSimpleHsAlt nlWildPat (ltResult op) ] + , mkHsCaseAlt nlWildPat (ltResult op) ] | tag == last_tag - 1 - = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op) + = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con) + (ltResult op) , mkInnerEqAlt op data_con - , mkSimpleHsAlt nlWildPat (gtResult op) ] + , mkHsCaseAlt nlWildPat (gtResult op) ] | tag > last_tag `div` 2 -- lower range is larger = untag_Expr tycon [(b_RDR, bh_RDR)] $ nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit) (gtResult op) $ -- Definitely GT nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkSimpleHsAlt nlWildPat (ltResult op) ] + , mkHsCaseAlt nlWildPat (ltResult op) ] | otherwise -- upper range is larger = untag_Expr tycon [(b_RDR, bh_RDR)] $ nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit) (ltResult op) $ -- Definitely LT nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con - , mkSimpleHsAlt nlWildPat (gtResult op) ] + , mkHsCaseAlt nlWildPat (gtResult op) ] where tag = get_tag data_con tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag))) @@ -459,7 +462,7 @@ gen_Ord_binds loc tycon -- First argument 'a' known to be built with K -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) mkInnerEqAlt op data_con - = mkSimpleHsAlt (nlConVarPat data_con_RDR bs_needed) $ + = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $ mkCompareFields tycon op (dataConOrigArgTys data_con) where data_con_RDR = getRdrName data_con @@ -495,9 +498,9 @@ mkCompareFields tycon op tys = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt | otherwise = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr)) - [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt, - mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq, - mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt] + [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt, + mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq, + mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt] where a_expr = nlHsVar a b_expr = nlHsVar b @@ -782,7 +785,7 @@ gen_Ix_binds loc tycon in nlHsCase (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR)) - [mkSimpleHsAlt (nlVarPat c_RDR) rhs] + [mkHsCaseAlt (nlVarPat c_RDR) rhs] )) ) @@ -1345,7 +1348,7 @@ gen_Data_binds dflags loc rep_tc | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) (map gunfold_alt data_cons) - gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) + gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) mk_unfold_rhs dc = foldr nlHsApp (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc)) (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) @@ -1552,13 +1555,15 @@ gen_Functor_binds loc tycon = (unitBag fmap_bind, emptyBag) where data_cons = tyConDataCons tycon - fmap_bind = mkRdrFunBind (L loc fmap_RDR) eqns + fun_name = L loc fmap_RDR + fmap_bind = mkRdrFunBind fun_name eqns fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs where parts = sequence $ foldDataConArgs ft_fmap con - eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat] + eqns | null data_cons = [mkSimpleMatch (FunRhs fun_name Prefix) + [nlWildPat, nlWildPat] (error_Expr "Void fmap")] | otherwise = map fmap_eqn data_cons @@ -1586,7 +1591,7 @@ gen_Functor_binds loc tycon -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName] -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) - match_for_con = mkSimpleConMatch $ + match_for_con = mkSimpleConMatch CaseAlt $ \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 .. {- @@ -1719,17 +1724,19 @@ mkSimpleLam2 lam = do -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ -- and its arguments, applying an expression (from @insides@) to each of the -- respective arguments of @con@. -mkSimpleConMatch :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName)) +mkSimpleConMatch :: Monad m => HsMatchContext RdrName + -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName] -> m (LMatch RdrName (LHsExpr RdrName)) -mkSimpleConMatch fold extra_pats con insides = do +mkSimpleConMatch ctxt fold extra_pats con insides = do let con_name = getRdrName con let vars_needed = takeList insides as_RDRs let pat = nlConVarPat con_name vars_needed rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed)) - return $ mkMatch (extra_pats ++ [pat]) rhs (noLoc emptyLocalBinds) + return $ mkMatch ctxt (extra_pats ++ [pat]) rhs + (noLoc emptyLocalBinds) -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" -- @@ -1749,13 +1756,14 @@ mkSimpleConMatch fold extra_pats con insides = do -- -- See Note [Generated code for DeriveFoldable and DeriveTraversable] mkSimpleConMatch2 :: Monad m - => (LHsExpr RdrName -> [LHsExpr RdrName] + => HsMatchContext RdrName + -> (LHsExpr RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [Maybe (LHsExpr RdrName)] -> m (LMatch RdrName (LHsExpr RdrName)) -mkSimpleConMatch2 fold extra_pats con insides = do +mkSimpleConMatch2 ctxt fold extra_pats con insides = do let con_name = getRdrName con vars_needed = takeList insides as_RDRs pat = nlConVarPat con_name vars_needed @@ -1780,7 +1788,8 @@ mkSimpleConMatch2 fold extra_pats con insides = do in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars) rhs <- fold con_expr exps - return $ mkMatch (extra_pats ++ [pat]) rhs (noLoc emptyLocalBinds) + return $ mkMatch ctxt (extra_pats ++ [pat]) rhs + (noLoc emptyLocalBinds) -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a] @@ -1907,7 +1916,7 @@ gen_Foldable_binds loc tycon -> DataCon -> [Maybe (LHsExpr RdrName)] -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) - match_foldr z = mkSimpleConMatch2 $ \_ xs -> return (mkFoldr xs) + match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs) where -- g1 v1 (g2 v2 (.. z)) mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName @@ -1936,7 +1945,7 @@ gen_Foldable_binds loc tycon -> DataCon -> [Maybe (LHsExpr RdrName)] -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) - match_foldMap = mkSimpleConMatch2 $ \_ xs -> return (mkFoldMap xs) + match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs) where -- mappend v1 (mappend v2 ..) mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName @@ -2023,7 +2032,8 @@ gen_Traversable_binds loc tycon -> DataCon -> [Maybe (LHsExpr RdrName)] -> State [RdrName] (LMatch RdrName (LHsExpr RdrName)) - match_for_con = mkSimpleConMatch2 $ \con xs -> return (mkApCon con xs) + match_for_con = mkSimpleConMatch2 CaseAlt $ + \con xs -> return (mkApCon con xs) where -- fmap (\b1 b2 ... -> Con b1 b2 ...) x1 <*> x2 <*> .. mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName @@ -2066,8 +2076,9 @@ makeG_d. gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Lift_binds loc tycon | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR) - [mkMatch [nlWildPat] errorMsg_Expr - (noLoc emptyLocalBinds)]) + [mkMatch (FunRhs (L loc lift_RDR) Prefix) + [nlWildPat] errorMsg_Expr + (noLoc emptyLocalBinds)]) , emptyBag) | otherwise = (unitBag lift_bind, emptyBag) where @@ -2176,7 +2187,9 @@ gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty mk_bind :: Id -> LHsBind RdrName mk_bind meth_id - = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr] + = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch + (FunRhs (L loc meth_RDR) Prefix) + [] rhs_expr] where Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty meth_id @@ -2351,7 +2364,9 @@ mk_HRFunBind :: Arity -> SrcSpan -> RdrName mk_HRFunBind arity loc fun pats_and_exprs = mkHRRdrFunBind arity (L loc fun) matches where - matches = [mkMatch p e (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs] + matches = [mkMatch (FunRhs (L loc fun) Prefix) p e + (noLoc emptyLocalBinds) + | (p,e) <-pats_and_exprs] mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName mkRdrFunBind = mkHRRdrFunBind 0 @@ -2365,7 +2380,8 @@ mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches' -- which can happen with -XEmptyDataDecls -- See Trac #4302 matches' = if null matches - then [mkMatch (replicate arity nlWildPat) + then [mkMatch (FunRhs fun Prefix) + (replicate arity nlWildPat) (error_Expr str) (noLoc emptyLocalBinds)] else matches str = "Void " ++ occNameString (rdrNameOcc fun_rdr) @@ -2481,7 +2497,7 @@ untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrN untag_Expr _ [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-} - [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)] + [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)] enum_from_to_Expr :: LHsExpr RdrName -> LHsExpr RdrName diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 931508bfb5..4443ed729c 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -323,8 +323,8 @@ mkBindsRep gk tycon = `unionBags` unitBag (mkRdrFunBind (L loc to01_RDR) to_matches) where - from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] - to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ] + from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts] + to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ] loc = srcLocSpan (getSrcLoc tycon) datacons = tyConDataCons tycon diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index db7a5f998d..2e6ab35c8e 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -14,7 +14,7 @@ checker. module TcHsSyn ( mkHsConApp, mkHsDictLet, mkHsApp, hsLitType, hsLPatType, hsPatType, - mkHsAppTy, mkSimpleHsAlt, + mkHsAppTy, mkHsCaseAlt, nlHsIntLit, shortCutLit, hsOverLitName, conLikeResTy, diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 59ddaee302..ffe2d2dd01 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -1557,8 +1557,9 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name (vcat [ppr clas <+> ppr inst_tys, nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) - ; return (noLoc $ mkTopFunBind Generated (noLoc (idName sel_id)) - [mkSimpleMatch [] rhs]) } + ; let fn = noLoc (idName sel_id) + ; return (noLoc $ mkTopFunBind Generated fn + [mkSimpleMatch (FunRhs fn Prefix) [] rhs]) } where rhs = nlHsVar dm_name diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 05b836cccb..d4867f54da 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -10,6 +10,7 @@ TcMatches: Typecheck some @Matches@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker, @@ -68,12 +69,12 @@ so it must be prepared to use tcSkolemise to skolemise it. See Note [sig_tau may be polymorphic] in TcPat. -} -tcMatchesFun :: Name +tcMatchesFun :: Located Name -> MatchGroup Name (LHsExpr Name) -> ExpRhoType -- Expected type of function -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) -- Returns type of body -tcMatchesFun fun_name matches exp_ty +tcMatchesFun fn@(L _ fun_name) matches exp_ty = do { -- Check that they all have the same no of arguments -- Location is in the monad, set the caller so that -- any inter-equation error messages get some vaguely @@ -97,7 +98,7 @@ tcMatchesFun fun_name matches exp_ty arity = matchGroupArity matches herald = text "The equation(s) for" <+> quotes (ppr fun_name) <+> text "have" - match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcBody } + match_ctxt = MC { mc_what = FunRhs fn Prefix, mc_body = tcBody } {- @tcMatchesCase@ doesn't do the argument-count check because the @@ -228,7 +229,7 @@ tcMatch ctxt pat_tys rhs_ty match = add_match_ctxt match $ do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ tc_grhss ctxt maybe_rhs_sig grhss rhs_ty - ; return (Match NonFunBindMatch pats' Nothing grhss') } + ; return (Match (mc_what ctxt) pats' Nothing grhss') } tc_grhss ctxt Nothing grhss rhs_ty = tcGRHSs ctxt grhss rhs_ty -- No result signature @@ -242,7 +243,7 @@ tcMatch ctxt pat_tys rhs_ty match add_match_ctxt match thing_inside = case mc_what ctxt of LambdaExpr -> thing_inside - m_ctxt -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside + _ -> addErrCtxt (pprMatchInCtxt match) thing_inside ------------- tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> ExpRhoType diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot index a45cbbed91..3e8dc0277b 100644 --- a/compiler/typecheck/TcMatches.hs-boot +++ b/compiler/typecheck/TcMatches.hs-boot @@ -4,13 +4,13 @@ import TcEvidence( HsWrapper ) import Name ( Name ) import TcType ( ExpRhoType, TcRhoType ) import TcRnTypes( TcM, TcId ) ---import SrcLoc ( Located ) +import SrcLoc ( Located ) tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType -> TcM (GRHSs TcId (LHsExpr TcId)) -tcMatchesFun :: Name +tcMatchesFun :: Located Name -> MatchGroup Name (LHsExpr Name) -> ExpRhoType -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 9091840554..35624e7d32 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -7,6 +7,7 @@ TcPat: Typechecking patterns -} {-# LANGUAGE CPP, RankNTypes, TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} module TcPat ( tcLetPat , TcPragEnv, lookupPragEnv, emptyPragEnv @@ -1235,7 +1236,7 @@ polyPatSig sig_ty = hang (text "Illegal polymorphic type signature in pattern:") 2 (ppr sig_ty) -lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM () +lazyUnliftedPatErr :: (OutputableBndrId name) => Pat name -> TcM () lazyUnliftedPatErr pat = failWithTc $ hang (text "A lazy (~) pattern cannot contain unlifted types:") diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 6418a2184a..c73da99dce 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} module TcPatSyn ( tcPatSynSig, tcInferPatSynDecl, tcCheckPatSynDecl , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr @@ -570,9 +571,9 @@ tcPatSynMatcher (L loc name) lpat args = map nlVarPat [scrutinee, cont, fail] lwpat = noLoc $ WildPat pat_ty cases = if isIrrefutableHsPat lpat - then [mkSimpleHsAlt lpat cont'] - else [mkSimpleHsAlt lpat cont', - mkSimpleHsAlt lwpat fail'] + then [mkHsCaseAlt lpat cont'] + else [mkHsCaseAlt lpat cont', + mkHsCaseAlt lwpat fail'] body = mkLHsWrap (mkWpLet req_ev_binds) $ L (getLoc lpat) $ HsCase (nlHsVar scrutinee) $ @@ -583,12 +584,15 @@ tcPatSynMatcher (L loc name) lpat } body' = noLoc $ HsLam $ - MG{ mg_alts = noLoc [mkSimpleMatch args body] + MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr + args body] , mg_arg_tys = [pat_ty, cont_ty, res_ty] , mg_res_ty = res_ty , mg_origin = Generated } - match = mkMatch [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') + match = mkMatch (FunRhs (L loc name) Prefix) [] + (mkHsLams (rr_tv:res_tv:univ_tvs) + req_dicts body') (noLoc EmptyLocalBinds) mg = MG{ mg_alts = L (getLoc match) [match] , mg_arg_tys = [] @@ -705,7 +709,9 @@ tcPatSynBuilderBind sig_fun PSB{ psb_id = L loc name, psb_def = lpat mk_mg body = mkMatchGroupName Generated [builder_match] where builder_args = [L loc (VarPat (L loc n)) | L loc n <- args] - builder_match = mkMatch builder_args body (noLoc EmptyLocalBinds) + builder_match = mkMatch (FunRhs (L loc name) Prefix) + builder_args body + (noLoc EmptyLocalBinds) args = case details of PrefixPatSyn args -> args @@ -717,7 +723,7 @@ tcPatSynBuilderBind sig_fun PSB{ psb_id = L loc name, psb_def = lpat add_dummy_arg mg@(MG { mg_alts = L l [L loc match@(Match { m_pats = pats })] }) = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ - pprMatches (PatSyn :: HsMatchContext Name) other_mg + pprMatches other_mg get_builder_sig :: TcSigFun -> Name -> Id -> Bool -> TcM TcIdSigInfo get_builder_sig sig_fun name builder_id need_dummy_arg @@ -940,19 +946,19 @@ tcCheckPatSynPat = go go1 SigPatOut{} = panic "SigPatOut in output of renamer" go1 CoPat{} = panic "CoPat in output of renamer" -asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a +asPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a asPatInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain as-patterns (@):") 2 (ppr pat) -thInPatSynErr :: OutputableBndr name => Pat name -> TcM a +thInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a thInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain Template Haskell:") 2 (ppr pat) -nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a +nPlusKPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a nPlusKPatInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain n+k-pattern:") diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 321081a7ce..cb7bb69f16 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1790,7 +1790,8 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) ; uniq <- newUnique ; interPrintName <- getInteractivePrintName ; let fresh_it = itName uniq loc - matches = [mkMatch [] rn_expr (noLoc emptyLocalBinds)] + matches = [mkMatch (FunRhs (L loc fresh_it) Prefix) [] rn_expr + (noLoc emptyLocalBinds)] -- [it = expr] the_bind = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs } -- Care here! In GHCi the expression might have diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 8c91b4897d..7529f15001 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -974,9 +974,11 @@ mkOneRecordSelector all_cons idDetails fl -- where cons_w_field = [C2,C7] sel_bind = mkTopFunBind Generated sel_lname alts where - alts | is_naughty = [mkSimpleMatch [] unit_rhs] + alts | is_naughty = [mkSimpleMatch (FunRhs sel_lname Prefix) + [] unit_rhs] | otherwise = map mk_match cons_w_field ++ deflt - mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] + mk_match con = mkSimpleMatch (FunRhs sel_lname Prefix) + [L loc (mk_sel_pat con)] (L loc (HsVar (L loc field_var))) mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } @@ -992,7 +994,8 @@ mkOneRecordSelector all_cons idDetails fl -- We do this explicitly so that we get a nice error message that -- mentions this particular record selector deflt | all dealt_with all_cons = [] - | otherwise = [mkSimpleMatch [L loc (WildPat placeHolderType)] + | otherwise = [mkSimpleMatch CaseAlt + [L loc (WildPat placeHolderType)] (mkHsApp (L loc (HsVar (L loc (getName rEC_SEL_ERROR_ID)))) (L loc (HsLit msg_lit)))] diff --git a/testsuite/tests/ghc-api/landmines/landmines.stdout b/testsuite/tests/ghc-api/landmines/landmines.stdout index 360ef198b6..279b92c715 100644 --- a/testsuite/tests/ghc-api/landmines/landmines.stdout +++ b/testsuite/tests/ghc-api/landmines/landmines.stdout @@ -1,4 +1,4 @@ -(12,12,7) +(12,12,8) (93,63,0) (15,13,7) -(10,10,7) +(10,10,8) diff --git a/testsuite/tests/patsyn/should_fail/T11667.stderr b/testsuite/tests/patsyn/should_fail/T11667.stderr index 95b6e929ad..44bf88ced9 100644 --- a/testsuite/tests/patsyn/should_fail/T11667.stderr +++ b/testsuite/tests/patsyn/should_fail/T11667.stderr @@ -38,4 +38,4 @@ T11667.hs:31:16: error: add (Num a) to the "required" context of the signature for pattern synonym ‘Pat4’ • In the expression: MkS 42 - In an equation for ‘$bPat4’: $bPat4 = MkS 42 + In an equation for ‘Pat4’: Pat4 = MkS 42 diff --git a/testsuite/tests/th/T8761.stderr b/testsuite/tests/th/T8761.stderr index 4b3a90c2a2..8d347562f6 100644 --- a/testsuite/tests/th/T8761.stderr +++ b/testsuite/tests/th/T8761.stderr @@ -50,7 +50,7 @@ T8761.hs:(48,1)-(52,21): Splicing declarations [d| pattern x :*: y <- ((x, _), [y]) pattern x :+: y = (x, y) pattern x :~: y <- (x, y) where - (:~:) x y = (x, y) |] + x :~: y = (x, y) |] ======> pattern x :*: y <- ((x, _), [y]) pattern x :+: y = (x, y) diff --git a/utils/haddock b/utils/haddock -Subproject 375a8d8c7203857863992483df9f9d24ec93eca +Subproject 8d47c8b733a0b9406d99a97c7eaeba3d6b51ec7 |