diff options
| -rw-r--r-- | compiler/deSugar/Check.hs | 6 | ||||
| -rw-r--r-- | compiler/hsSyn/HsBinds.hs | 40 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.hs | 26 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.hs | 4 | ||||
| -rw-r--r-- | compiler/parser/Parser.y | 34 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.hs | 16 | ||||
| -rw-r--r-- | compiler/rename/RnBinds.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/parser/should_compile/DumpParsedAst.stderr | 3 | ||||
| -rw-r--r-- | testsuite/tests/parser/should_compile/DumpRenamedAst.stderr | 3 | ||||
| -rw-r--r-- | testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr | 3 |
10 files changed, 40 insertions, 99 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 32158565e9..4b01aac323 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -1742,9 +1742,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun (ppr_match, pref) = case kind of - FunRhs (L _ 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/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 5fd523f820..b39e25a2c7 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -132,41 +132,12 @@ type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) -- | Located Haskell Binding with separate Left and Right identifier types type LHsBindLR idL idR = Located (HsBindLR idL idR) -{- Note [Varieties of binding pattern matches] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The distinction between FunBind and PatBind is a bit subtle. FunBind covers -patterns which resemble function bindings and simple variable bindings. - - f x = e - f !x = e - f = e - !x = e -- FunRhs has SrcStrict - x `f` y = e -- FunRhs has Infix - -The actual patterns and RHSs of a FunBind are encoding in fun_matches. -The m_ctxt field of Match will be FunRhs and carries two bits of information -about the match, - - * the mc_strictness field describes whether the match is decorated with a bang - (e.g. `!x = e`) - * the mc_fixity field describes the fixity of the function binder - -By contrast, PatBind represents data constructor patterns, as well as a few -other interesting cases. Namely, - - Just x = e - (x) = e - x :: Ty = e --} - -- | Haskell Binding with separate Left and Right id's data HsBindLR idL idR - = -- | Function-like Binding + = -- | Function Binding -- -- FunBind is used for both functions @f x = e@ -- and variables @f = \x -> e@ - -- and strict variables @!x = x + 1@ -- -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'. -- @@ -177,10 +148,6 @@ data HsBindLR idL idR -- parses as a pattern binding, just like -- @(f :: a -> a) = ... @ -- - -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their - -- 'MatchContext'. See Note [Varities of binding pattern matches] for - -- details about the relationship between FunBind and PatBind. - -- -- 'ApiAnnotation.AnnKeywordId's -- -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches @@ -221,10 +188,7 @@ data HsBindLR idL idR -- | Pattern Binding -- -- The pattern is never a simple variable; - -- That case is done by FunBind. - -- See Note [Varities of binding pattern matches] for details about the - -- relationship between FunBind and PatBind. - + -- That case is done by FunBind -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 750578b68c..f32c24ee46 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -1454,8 +1454,8 @@ Example infix function definition requiring individual API Annotations isInfixMatch :: Match id body -> Bool isInfixMatch match = case m_ctxt match of - FunRhs {mc_fixity = Infix} -> True - _ -> False + FunRhs _ Infix -> True + _ -> False isEmptyMatchGroup :: MatchGroup id body -> Bool isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms @@ -1534,7 +1534,7 @@ pprMatch match ctxt = m_ctxt match (herald, other_pats) = case ctxt of - FunRhs {mc_fun=L _ fun, mc_fixity=fixity} + FunRhs (L _ fun) fixity | fixity == Prefix -> (pprPrefixOcc fun, m_pats match) -- f x y z = e -- Not pprBndr; the AbsBinds will @@ -2333,17 +2333,9 @@ pp_dotdot = text " .. " -- | Haskell Match Context -- --- Context of a pattern match. This is more subtle than it would seem. See Note --- [Varieties of pattern matches]. +-- Context of a Match data HsMatchContext id - = FunRhs { mc_fun :: Located id -- ^ function binder of @f@ - , mc_fixity :: LexicalFixity -- ^ fixing of @f@ - , mc_strictness :: SrcStrictness - -- ^ was the pattern banged? See - -- Note [Varities of binding pattern matches] - } - -- ^A pattern matching on an argument of a - -- function binding + = FunRhs (Located id) LexicalFixity -- ^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 @@ -2364,8 +2356,7 @@ data HsMatchContext id deriving instance (DataIdPost id) => Data (HsMatchContext id) instance OutputableBndr id => Outputable (HsMatchContext id) where - ppr (FunRhs (L _ id) fix str) - = text "FunRhs" <+> ppr id <+> ppr fix <+> ppr str + ppr (FunRhs (L _ id) fix) = text "FunRhs" <+> ppr id <+> ppr fix ppr LambdaExpr = text "LambdaExpr" ppr CaseAlt = text "CaseAlt" ppr IfAlt = text "IfAlt" @@ -2450,8 +2441,7 @@ pprMatchContext ctxt pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id) => HsMatchContext id -> SDoc -pprMatchContextNoun (FunRhs {mc_fun=L _ fun}) - = text "equation for" +pprMatchContextNoun (FunRhs (L _ fun) _) = text "equation for" <+> quotes (ppr fun) pprMatchContextNoun CaseAlt = text "case alternative" pprMatchContextNoun IfAlt = text "multi-way if alternative" @@ -2511,7 +2501,7 @@ instance (Outputable id, Outputable (NameOrRdrName id)) -- Used to generate the string for a *runtime* error message matchContextErrString :: Outputable id => HsMatchContext id -> SDoc -matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun +matchContextErrString (FunRhs (L _ fun) _) = text "function" <+> ppr fun matchContextErrString CaseAlt = text "case" matchContextErrString IfAlt = text "multi-way if" matchContextErrString PatBindRhs = text "pattern binding" diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index a15aa1576e..4b07683a67 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -751,9 +751,9 @@ mk_easy_FunBind loc fun pats expr [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr (noLoc emptyLocalBinds)] --- | Make a prefix, non-strict function 'HsMatchContext' +-- | Make a prefix 'FunRhs' 'HsMatchContext' mkPrefixFunRhs :: Located id -> HsMatchContext id -mkPrefixFunRhs n = FunRhs n Prefix NoSrcStrict +mkPrefixFunRhs n = FunRhs n Prefix ------------ mkMatch :: HsMatchContext (NameOrRdrName id) -> [LPat id] -> LHsExpr id diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index c525ddf055..7af02053fd 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -2181,28 +2181,20 @@ docdecld :: { LDocDecl } decl_no_th :: { LHsDecl RdrName } : sigdecl { $1 } - | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) - -- Turn it all into an expression so that - -- checkPattern can check that bangs are enabled - ; l = comb2 $1 $> }; - (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ; - -- Depending upon what the pattern looks like we might get either - -- a FunBind or PatBind back from checkValDef. See Note - -- [Varieties of binding pattern matches] - case r of { - (FunBind n _ _ _ _) -> - ams (L l ()) [mj AnnFunId n] >> return () ; - (PatBind (L lh _lhs) _rhs _ _ _) -> - ams (L lh ()) [] >> return () } ; - - _ <- ams (L l ()) (ann ++ fst (unLoc $3)) ; - return $! (sL l $ ValD r) } } - - | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3; + | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) }; + pat <- checkPattern empty e; + _ <- ams (sLL $1 $> ()) + (fst $ unLoc $3); + return $ sLL $1 $> $ ValD $ + PatBind pat (snd $ unLoc $3) + placeHolderType + placeHolderNames + ([],[]) } } + -- Turn it all into an expression so that + -- checkPattern can check that bangs are enabled + + | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3; let { l = comb2 $1 $> }; - -- Depending upon what the pattern looks like we might get either - -- a FunBind or PatBind back from checkValDef. See Note - -- [Varieties of binding pattern matches] case r of { (FunBind n _ _ _ _) -> ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ; diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index d7facdc4f0..d6fc6fb642 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -514,9 +514,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = wrongNameBindingErr loc decl ; match <- case details of PrefixCon pats -> - return $ Match (FunRhs ln Prefix NoSrcStrict) pats Nothing rhs + return $ Match (FunRhs ln Prefix) pats Nothing rhs InfixCon pat1 pat2 -> - return $ Match (FunRhs ln Infix NoSrcStrict) [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 @@ -923,27 +923,25 @@ patIsRec e = e == mkUnqual varName (fsLit "rec") -- Check Equation Syntax checkValDef :: SDoc - -> SrcStrictness -> LHsExpr RdrName -> Maybe (LHsType RdrName) -> Located (a,GRHSs RdrName (LHsExpr RdrName)) -> P ([AddAnn],HsBind RdrName) -checkValDef msg _strictness lhs (Just sig) grhss +checkValDef msg lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding = checkPatBind msg (L (combineLocs lhs sig) (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss -checkValDef msg strictness lhs opt_sig g@(L l (_,grhss)) +checkValDef msg lhs opt_sig g@(L l (_,grhss)) = do { mb_fun <- isFunLhs lhs ; case mb_fun of Just (fun, is_infix, pats, ann) -> - checkFunBind msg strictness ann (getLoc lhs) + checkFunBind msg ann (getLoc lhs) fun is_infix pats opt_sig (L l grhss) Nothing -> checkPatBind msg lhs g } checkFunBind :: SDoc - -> SrcStrictness -> [AddAnn] -> SrcSpan -> Located RdrName @@ -952,13 +950,13 @@ checkFunBind :: SDoc -> Maybe (LHsType RdrName) -> Located (GRHSs RdrName (LHsExpr RdrName)) -> P ([AddAnn],HsBind RdrName) -checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) +checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) = do ps <- checkPatterns msg pats let match_span = combineSrcSpans lhs_loc rhs_span -- 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_ctxt = FunRhs fun is_infix strictness + [L match_span (Match { m_ctxt = FunRhs fun is_infix , m_pats = ps , m_type = opt_sig , m_grhss = grhss })]) diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index f91ca52960..7f0490a68e 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -1166,8 +1166,8 @@ rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats ; rnPats ctxt pats $ \ pats' -> do { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss ; let mf' = case (ctxt,mf) of - (FunRhs (L _ funid) _ _,FunRhs (L lf _) _ _) - -> FunRhs (L lf funid) fixity NoSrcStrict -- TODO: Is this right? + (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 ) }} diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index ad3680e578..9f9cf659d4 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -204,8 +204,7 @@ (FunRhs ({ DumpParsedAst.hs:11:1-4 } (Unqual {OccName: main})) - (Prefix) - (NoSrcStrict)) + (Prefix)) [] (Nothing) (GRHSs diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index c873ee148b..d0b456a2cb 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -17,8 +17,7 @@ (Match (FunRhs ({ DumpRenamedAst.hs:11:1-4 }{Name: main:DumpRenamedAst.main{v}}) - (Prefix) - (NoSrcStrict)) + (Prefix)) [] (Nothing) (GRHSs diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index 663a7d7f2e..4b10222262 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -244,8 +244,7 @@ (Match (FunRhs ({ DumpTypecheckedAst.hs:11:1-4 }{Name: main:DumpTypecheckedAst.main{v}}) - (Prefix) - (NoSrcStrict)) + (Prefix)) [] (Nothing) (GRHSs |