Commit 2c6d73e2 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-06-11 12:24:51 by simonpj]

--------------------------------------
	Tidy up and improve "pattern contexts"
	--------------------------------------

In various places (renamer, typechecker, desugarer) we need to know
what the context of a pattern match is (case expression, function defn,
let binding, etc).  This commit tidies up the story quite a bit.  I
think it represents a net decrease in code, and certainly it improves the
error messages from:

	f x x = 3

Prevsiously we got a message like "Conflicting bindings for x in a pattern match",
but not it says "..in a defn of function f".

WARNING: the tidy up had a more global effect than I originally expected,
so it's possible that some other error messages look a bit peculiar.  They
should be easy to fix, but tell us!
parent 0004357c
......@@ -54,3 +54,57 @@ completeLazyBind: [given a simplified RHS]
- add unfolding [this is the only place we add an unfolding]
add arity
Right hand sides and arguments
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In many ways we want to treat
(a) the right hand side of a let(rec), and
(b) a function argument
in the same way. But not always! In particular, we would
like to leave these arguments exactly as they are, so they
will match a RULE more easily.
f (g x, h x)
g (+ x)
It's harder to make the rule match if we ANF-ise the constructor,
or eta-expand the PAP:
f (let { a = g x; b = h x } in (a,b))
g (\y. + x y)
On the other hand if we see the let-defns
p = (g x, h x)
q = + x
then we *do* want to ANF-ise and eta-expand, so that p and q
can be safely inlined.
Even floating lets out is a bit dubious. For let RHS's we float lets
out if that exposes a value, so that the value can be inlined more vigorously.
For example
r = let x = e in (x,x)
Here, if we float the let out we'll expose a nice constructor. We did experiments
that showed this to be a generally good thing. But it was a bad thing to float
lets out unconditionally, because that meant they got allocated more often.
For function arguments, there's less reason to expose a constructor (it won't
get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
So for the moment we don't float lets out of function arguments either.
Eta expansion
~~~~~~~~~~~~~~
For eta expansion, we want to catch things like
case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
If the \x was on the RHS of a let, we'd eta expand to bring the two
lambdas together. And in general that's a good thing to do. Perhaps
we should eta expand wherever we find a (value) lambda? Then the eta
expansion at a let RHS can concentrate solely on the PAP case.
......@@ -78,11 +78,9 @@ dsMonoBinds _ (VarMonoBind var expr) rest
dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest
= putSrcLocDs locn $
matchWrapper (FunRhs (idName fun)) matches error_string `thenDs` \ (args, body) ->
addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
matchWrapper (FunRhs fun) matches `thenDs` \ (args, body) ->
addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
returnDs (pair : rest)
where
error_string = "function " ++ showSDoc (ppr fun)
dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest
= putSrcLocDs locn $
......
......@@ -11,11 +11,12 @@ module DsExpr ( dsExpr, dsLet ) where
import HsSyn ( failureFreePat,
HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
Stmt(..), HsMatchContext(..), Match(..), HsBinds(..), MonoBinds(..),
Stmt(..), HsMatchContext(..), HsDoContext(..),
Match(..), HsBinds(..), MonoBinds(..),
mkSimpleMatch, isDoExpr
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds,
TypecheckedStmt
TypecheckedStmt, TypecheckedMatchContext
)
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
......@@ -122,14 +123,13 @@ dsExpr (HsLit lit) = dsLit lit
-- HsOverLit has been gotten rid of by the type checker
dsExpr expr@(HsLam a_Match)
= matchWrapper LambdaExpr [a_Match] "lambda" `thenDs` \ (binders, matching_code) ->
= matchWrapper LambdaExpr [a_Match] `thenDs` \ (binders, matching_code) ->
returnDs (mkLams binders matching_code)
dsExpr expr@(HsApp fun arg)
= dsExpr fun `thenDs` \ core_fun ->
dsExpr arg `thenDs` \ core_arg ->
returnDs (core_fun `App` core_arg)
\end{code}
Operator sections. At first it looks as if we can convert
......@@ -204,7 +204,7 @@ dsExpr (HsCase discrim matches src_loc)
| all ubx_tuple_match matches
= putSrcLocDs src_loc $
dsExpr discrim `thenDs` \ core_discrim ->
matchWrapper CaseAlt matches "case" `thenDs` \ ([discrim_var], matching_code) ->
matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
case matching_code of
Case (Var x) bndr alts | x == discrim_var ->
returnDs (Case core_discrim bndr alts)
......@@ -216,7 +216,7 @@ dsExpr (HsCase discrim matches src_loc)
dsExpr (HsCase discrim matches src_loc)
= putSrcLocDs src_loc $
dsExpr discrim `thenDs` \ core_discrim ->
matchWrapper CaseAlt matches "case" `thenDs` \ ([discrim_var], matching_code) ->
matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
returnDs (bindNonRec discrim_var core_discrim matching_code)
dsExpr (HsLet binds body)
......@@ -430,8 +430,8 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
-- and the right hand sides with applications of the wrapper Id
-- so that everything works when we are doing fancy unboxing on the
-- constructor aguments.
mapDs mk_alt cons_to_upd `thenDs` \ alts ->
matchWrapper RecUpd alts "record update" `thenDs` \ ([discrim_var], matching_code) ->
mapDs mk_alt cons_to_upd `thenDs` \ alts ->
matchWrapper RecUpd alts `thenDs` \ ([discrim_var], matching_code) ->
returnDs (bindNonRec discrim_var record_expr' matching_code)
......@@ -490,7 +490,7 @@ dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
Basically does the translation given in the Haskell~1.3 report:
\begin{code}
dsDo :: HsMatchContext
dsDo :: HsDoContext
-> [TypecheckedStmt]
-> Id -- id for: return m
-> Id -- id for: (>>=) m
......@@ -501,6 +501,9 @@ dsDo :: HsMatchContext
dsDo do_or_lc stmts return_id then_id fail_id result_ty
= let
(_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b)
is_do = case do_or_lc of
DoExpr -> True
ListComp -> False
-- For ExprStmt, see the comments near HsExpr.HsStmt about
-- exactly what ExprStmts mean!
......@@ -508,12 +511,12 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
-- In dsDo we can only see DoStmt and ListComp (no gaurds)
go [ResultStmt expr locn]
| isDoExpr do_or_lc = do_expr expr locn
| otherwise = do_expr expr locn `thenDs` \ expr2 ->
returnDs (mkApps (Var return_id) [Type b_ty, expr2])
| is_do = do_expr expr locn
| otherwise = do_expr expr locn `thenDs` \ expr2 ->
returnDs (mkApps (Var return_id) [Type b_ty, expr2])
go (ExprStmt expr locn : stmts)
| isDoExpr do_or_lc
| is_do -- Do expression
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
let
......@@ -556,8 +559,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
, mkSimpleMatch [WildPat a_ty] fail_expr (Just result_ty) locn
]
in
matchWrapper DoExpr the_matches match_msg
`thenDs` \ (binders, matching_code) ->
matchWrapper (DoCtxt do_or_lc) the_matches `thenDs` \ (binders, matching_code) ->
returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
mkLams binders matching_code])
in
......@@ -565,10 +567,6 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
where
do_expr expr locn = putSrcLocDs locn (dsExpr expr)
match_msg = case do_or_lc of
DoExpr -> "`do' statement"
ListComp -> "comprehension"
\end{code}
......
......@@ -12,7 +12,7 @@ import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
import {-# SOURCE #-} Match ( matchSinglePat )
import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), HsMatchContext(..) )
import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt )
import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt, TypecheckedMatchContext )
import CoreSyn ( CoreExpr )
import Type ( Type )
......@@ -45,8 +45,8 @@ dsGuarded grhss
In contrast, @dsGRHSs@ produces a @MatchResult@.
\begin{code}
dsGRHSs :: HsMatchContext -> [TypecheckedPat] -- These are to build a MatchContext from
-> TypecheckedGRHSs -- Guarded RHSs
dsGRHSs :: TypecheckedMatchContext -> [TypecheckedPat] -- These are to build a MatchContext from
-> TypecheckedGRHSs -- Guarded RHSs
-> DsM (Type, MatchResult)
dsGRHSs kind pats (GRHSs grhss binds (Just ty))
......
......@@ -11,7 +11,7 @@ module DsListComp ( dsListComp ) where
import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
import BasicTypes ( Boxity(..) )
import HsSyn ( OutPat(..), HsExpr(..), Stmt(..), HsMatchContext(..) )
import HsSyn ( OutPat(..), HsExpr(..), Stmt(..), HsMatchContext(..), HsDoContext(..) )
import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr )
import DsHsSyn ( outPatType )
import CoreSyn
......@@ -193,7 +193,7 @@ deBindComp pat core_list1 quals core_list2
letrec_body = App (Var h) core_list1
in
deListComp quals core_fail `thenDs` \ rest_expr ->
matchSimply (Var u2) ListComp pat
matchSimply (Var u2) (DoCtxt ListComp) pat
rest_expr core_fail `thenDs` \ core_match ->
let
rhs = Lam u1 $
......@@ -306,7 +306,8 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals)
dfListComp c_id b quals `thenDs` \ core_rest ->
-- build the pattern match
matchSimply (Var x) ListComp pat core_rest (Var b) `thenDs` \ core_expr ->
matchSimply (Var x) (DoCtxt ListComp)
pat core_rest (Var b) `thenDs` \ core_expr ->
-- now build the outermost foldr, and return
dsLookupGlobalValue foldrName `thenDs` \ foldr_id ->
......
......@@ -25,7 +25,7 @@ module DsMonad (
#include "HsVersions.h"
import HsSyn ( HsMatchContext )
import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext )
import Bag ( emptyBag, snocBag, Bag )
import ErrUtils ( WarnMsg )
import Id ( mkSysLocal, setIdUnique, Id )
......@@ -33,7 +33,6 @@ import Module ( Module )
import Var ( TyVar, setTyVarUnique )
import Outputable
import SrcLoc ( noSrcLoc, SrcLoc )
import TcHsSyn ( TypecheckedPat )
import Type ( Type )
import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
......@@ -218,7 +217,7 @@ dsLookupGlobalValue name dflags us genv loc mod warns
\begin{code}
data DsMatchContext
= DsMatchContext HsMatchContext [TypecheckedPat] SrcLoc
= DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
| NoMatchContext
deriving ()
\end{code}
......@@ -4,6 +4,6 @@ Match match matchExport matchSimply matchSinglePat;
_declarations_
1 match _:_ [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;;
1 matchExport _:_ [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;;
1 matchSimply _:_ CoreSyn.CoreExpr -> HsExpr.HsMatchContext -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
1 matchSimply _:_ CoreSyn.CoreExpr -> HsExpr.HsMatchContext Var.Id -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
1 matchSinglePat _:_ CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> TcHsSyn.TypecheckedPat -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ;;
......@@ -2,5 +2,5 @@ __interface Match 1 0 where
__export Match match matchExport matchSimply matchSinglePat;
1 match :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
1 matchExport :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext Var.Id -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
1 matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> TcHsSyn.TypecheckedPat -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ;
......@@ -10,7 +10,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w
import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
import TcHsSyn ( TypecheckedPat, TypecheckedMatch )
import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext )
import DsHsSyn ( outPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
......@@ -622,9 +622,8 @@ Call @match@ with all of this information!
\end{enumerate}
\begin{code}
matchWrapper :: HsMatchContext -- For shadowing warning messages
matchWrapper :: TypecheckedMatchContext -- For shadowing warning messages
-> [TypecheckedMatch] -- Matches being desugared
-> String -- Error message if the match fails
-> DsM ([Id], CoreExpr) -- Results
\end{code}
......@@ -651,11 +650,12 @@ one pattern, and match simply only accepts one pattern.
JJQC 30-Nov-1997
\begin{code}
matchWrapper kind matches error_string
matchWrapper ctxt matches
= getDOptsDs `thenDs` \ dflags ->
flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) ->
flattenMatches ctxt matches `thenDs` \ (result_ty, eqns_info) ->
let
EqnInfo _ _ arg_pats _ : _ = eqns_info
error_string = matchContextErrString ctxt
in
mapDs selectMatchVar arg_pats `thenDs` \ new_vars ->
match_fun dflags new_vars eqns_info `thenDs` \ match_result ->
......@@ -664,7 +664,7 @@ matchWrapper kind matches error_string
extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
returnDs (new_vars, result_expr)
where match_fun dflags
= case kind of
= case ctxt of
LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport
| otherwise -> match
_ -> matchExport
......@@ -681,11 +681,11 @@ situation where we want to match a single expression against a single
pattern. It returns an expression.
\begin{code}
matchSimply :: CoreExpr -- Scrutinee
-> HsMatchContext -- Match kind
-> TypecheckedPat -- Pattern it should match
-> CoreExpr -- Return this if it matches
-> CoreExpr -- Return this if it doesn't
matchSimply :: CoreExpr -- Scrutinee
-> TypecheckedMatchContext -- Match kind
-> TypecheckedPat -- Pattern it should match
-> CoreExpr -- Return this if it matches
-> CoreExpr -- Return this if it doesn't
-> DsM CoreExpr
matchSimply scrut kind pat result_expr fail_expr
......@@ -726,7 +726,7 @@ matchSinglePat scrut ctx pat match_result
This is actually local to @matchWrapper@.
\begin{code}
flattenMatches :: HsMatchContext
flattenMatches :: TypecheckedMatchContext
-> [TypecheckedMatch]
-> DsM (Type, [EquationInfo])
......
......@@ -10,7 +10,9 @@ module HsBinds where
#include "HsVersions.h"
import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr, pprMatches, Match, pprGRHSs, GRHSs )
import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr,
Match, pprFunBind,
GRHSs, pprPatBind )
-- friends:
import HsTypes ( HsType )
......@@ -199,11 +201,8 @@ ppr_monobind EmptyMonoBinds = empty
ppr_monobind (AndMonoBinds binds1 binds2)
= ppr_monobind binds1 $$ ppr_monobind binds2
ppr_monobind (PatMonoBind pat grhss locn)
= sep [ppr pat, nest 4 (pprGRHSs False grhss)]
ppr_monobind (FunMonoBind fun inf matches locn)
= pprMatches (False, ppr fun) matches
ppr_monobind (PatMonoBind pat grhss locn) = pprPatBind pat grhss
ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
-- ToDo: print infix if appropriate
ppr_monobind (VarMonoBind name expr)
......
_interface_ HsExpr 1
_exports_
HsExpr HsExpr pprExpr Match GRHSs pprMatch pprMatches pprGRHSs ;
HsExpr HsExpr pprExpr Match GRHSs pprFunBind pprPatBind ;
_declarations_
1 data HsExpr i p;
1 pprExpr _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;;
1 data Match a b ;
1 data GRHSs a b ;
1 pprGRHSs _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsExpr.GRHSs i p -> Outputable.SDoc ;;
1 pprMatch _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> HsExpr.Match i p -> Outputable.SDoc ;;
1 pprMatches _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsExpr.Match i p] -> Outputable.SDoc ;;
1 pprPatBind _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => p -> HsExpr.GRHSs i p -> Outputable.SDoc ;;
1 pprFunBind _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => i -> [HsExpr.Match i p] -> Outputable.SDoc ;;
__interface HsExpr 1 0 where
__export HsExpr HsExpr pprExpr Match GRHSs pprMatch pprMatches pprGRHSs ;
__export HsExpr HsExpr pprExpr Match GRHSs pprPatBind pprFunBind ;
1 data HsExpr i p ;
1 pprExpr :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;
1 data Match a b ;
1 data GRHSs a b ;
1 pprGRHSs :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsExpr.GRHSs i p -> Outputable.SDoc ;
1 pprMatch :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> HsExpr.Match i p -> Outputable.SDoc ;
1 pprMatches :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsExpr.Match i p] -> Outputable.SDoc ;
1 pprPatBind :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => p -> HsExpr.GRHSs i p -> Outputable.SDoc ;
1 pprFunBind :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => i -> [HsExpr.Match i p] -> Outputable.SDoc ;
......@@ -83,11 +83,11 @@ data HsExpr id pat
| HsWith (HsExpr id pat) -- implicit parameter binding
[(id, HsExpr id pat)]
| HsDo HsMatchContext
| HsDo HsDoContext
[Stmt id pat] -- "do":one or more stmts
SrcLoc
| HsDoOut HsMatchContext
| HsDoOut HsDoContext
[Stmt id pat] -- "do":one or more stmts
id -- id for return
id -- id for >>=
......@@ -222,7 +222,7 @@ ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
ppr_expr (HsLam match)
= hsep [char '\\', nest 2 (pprMatch (True,empty) match)]
= hsep [char '\\', nest 2 (pprMatch LambdaExpr match)]
ppr_expr expr@(HsApp e1 e2)
= let (fun, args) = collect_args expr [] in
......@@ -278,7 +278,7 @@ ppr_expr (SectionR op expr)
ppr_expr (HsCase expr matches _)
= sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")],
nest 2 (pprMatches (True, empty) matches) ]
nest 2 (pprMatches CaseAlt matches) ]
ppr_expr (HsIf e1 e2 e3 _)
= sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")],
......@@ -479,46 +479,56 @@ We know the list must have at least one @Match@ in it.
\begin{code}
pprMatches :: (Outputable id, Outputable pat)
=> (Bool, SDoc) -> [Match id pat] -> SDoc
pprMatches print_info matches = vcat (map (pprMatch print_info) matches)
=> HsMatchContext id -> [Match id pat] -> SDoc
pprMatches ctxt matches = vcat (map (pprMatch ctxt) matches)
-- Exported to HsBinds, which can't see the defn of HsMatchContext
pprFunBind :: (Outputable id, Outputable pat)
=> id -> [Match id pat] -> SDoc
pprFunBind fun matches = pprMatches (FunRhs fun) matches
-- Exported to HsBinds, which can't see the defn of HsMatchContext
pprPatBind :: (Outputable id, Outputable pat)
=> pat -> GRHSs id pat -> SDoc
pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
pprMatch :: (Outputable id, Outputable pat)
=> (Bool, SDoc) -> Match id pat -> SDoc
pprMatch print_info@(is_case, name) (Match _ pats maybe_ty grhss)
= maybe_name <+> sep [sep (map ppr pats),
ppr_maybe_ty,
nest 2 (pprGRHSs is_case grhss)]
=> HsMatchContext id -> Match id pat -> SDoc
pprMatch ctxt (Match _ pats maybe_ty grhss)
= pp_name ctxt <+> sep [sep (map ppr pats),
ppr_maybe_ty,
nest 2 (pprGRHSs ctxt grhss)]
where
maybe_name | is_case = empty
| otherwise = name
pp_name (FunRhs fun) = ppr fun
pp_name other = empty
ppr_maybe_ty = case maybe_ty of
Just ty -> dcolon <+> ppr ty
Nothing -> empty
pprGRHSs :: (Outputable id, Outputable pat)
=> Bool -> GRHSs id pat -> SDoc
pprGRHSs is_case (GRHSs grhss binds maybe_ty)
= vcat (map (pprGRHS is_case) grhss)
=> HsMatchContext id -> GRHSs id pat -> SDoc
pprGRHSs ctxt (GRHSs grhss binds maybe_ty)
= vcat (map (pprGRHS ctxt) grhss)
$$
(if nullBinds binds then empty
else text "where" $$ nest 4 (pprDeeper (ppr binds)))
pprGRHS :: (Outputable id, Outputable pat)
=> Bool -> GRHS id pat -> SDoc
=> HsMatchContext id -> GRHS id pat -> SDoc
pprGRHS is_case (GRHS [ResultStmt expr _] locn)
= pp_rhs is_case expr
pprGRHS ctxt (GRHS [ResultStmt expr _] locn)
= pp_rhs ctxt expr
pprGRHS is_case (GRHS guarded locn)
= sep [char '|' <+> interpp'SP guards, pp_rhs is_case expr]
pprGRHS ctxt (GRHS guarded locn)
= sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
where
ResultStmt expr _ = last guarded -- Last stmt should be a ResultStmt for guards
guards = init guarded
pp_rhs is_case rhs = text (if is_case then "->" else "=") <+> pprDeeper (ppr rhs)
pp_rhs ctxt rhs = ptext (matchSeparator ctxt) <+> pprDeeper (ppr rhs)
\end{code}
......@@ -596,7 +606,7 @@ pprStmt (ParStmt stmtss)
pprStmt (ParStmtOut stmtss)
= hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
pprDo :: (Outputable id, Outputable pat) => HsMatchContext -> [Stmt id pat] -> SDoc
pprDo :: (Outputable id, Outputable pat) => HsDoContext -> [Stmt id pat] -> SDoc
pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
pprDo ListComp stmts = brackets $
hang (pprExpr expr <+> char '|')
......@@ -644,30 +654,21 @@ pp_dotdot = ptext SLIT(" .. ")
%************************************************************************
\begin{code}
data HsMatchContext -- Context of a Match or Stmt
= ListComp -- List comprehension
| DoExpr -- Do Statment
| FunRhs Name -- Function binding for f
data HsMatchContext id -- Context of a Match or Stmt
= DoCtxt HsDoContext -- Do-stmt or list comprehension
| FunRhs id -- Function binding for f
| CaseAlt -- Guard on a case alternative
| LambdaExpr -- Lambda
| PatBindRhs -- Pattern binding
| RecUpd -- Record update
deriving ()
-- It's convenient to have FunRhs as a Name
-- throughout so that HsMatchContext doesn't
-- need to be parameterised.
-- In the RdrName world we never use the FunRhs variant.
data HsDoContext = ListComp | DoExpr
\end{code}
\begin{code}
isDoExpr DoExpr = True
isDoExpr other = False
isDoOrListComp ListComp = True
isDoOrListComp DoExpr = True
isDoOrListComp other = False
isDoExpr (DoCtxt DoExpr) = True
isDoExpr other = False
\end{code}
\begin{code}
......@@ -675,17 +676,25 @@ matchSeparator (FunRhs _) = SLIT("=")
matchSeparator CaseAlt = SLIT("->")
matchSeparator LambdaExpr = SLIT("->")
matchSeparator PatBindRhs = SLIT("=")
matchSeparator DoExpr = SLIT("<-")
matchSeparator ListComp = SLIT("<-")
matchSeparator (DoCtxt _) = SLIT("<-")
matchSeparator RecUpd = panic "When is this used?"
\end{code}
\begin{code}
pprMatchContext (FunRhs fun) = ptext SLIT("In the definition of") <+> quotes (ppr fun)
pprMatchContext CaseAlt = ptext SLIT("In a group of case alternatives beginning")
pprMatchContext RecUpd = ptext SLIT("In a record-update construct")
pprMatchContext PatBindRhs = ptext SLIT("In a pattern binding")
pprMatchContext LambdaExpr = ptext SLIT("In a lambda abstraction")
pprMatchContext DoExpr = ptext SLIT("In a 'do' expression pattern binding")
pprMatchContext ListComp = ptext SLIT("In a 'list comprehension' pattern binding")
pprMatchContext (FunRhs fun) = ptext SLIT("In the definition of") <+> quotes (ppr fun)
pprMatchContext CaseAlt = ptext SLIT("In a case alternative")
pprMatchContext RecUpd = ptext SLIT("In a record-update construct")
pprMatchContext PatBindRhs = ptext SLIT("In a pattern binding")
pprMatchContext LambdaExpr = ptext SLIT("In a lambda abstraction")
pprMatchContext (DoCtxt DoExpr) = ptext SLIT("In a 'do' expression pattern binding")
pprMatchContext (DoCtxt ListComp) = ptext SLIT("In a 'list comprehension' pattern binding")
-- Used to generate the string for a *runtime* error message
matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun)
matchContextErrString CaseAlt = "case"
matchContextErrString PatBindRhs = "pattern binding"
matchContextErrString RecUpd = "record update"
matchContextErrString LambdaExpr = "lambda"
matchContextErrString (DoCtxt DoExpr) = "'do' expression"
matchContextErrString (DoCtxt ListComp) = "list comprehension"
\end{code}
......@@ -217,7 +217,7 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
= -- Extract all the binders in this group,
-- and extend current scope, inventing new names for the new binders
-- This also checks that the names form a set
bindLocatedLocalsRn (text "a binding group")
bindLocatedLocalsRn (text "In a binding group")
mbinders_w_srclocs $ \ new_mbinders ->
let
binder_set = mkNameSet new_mbinders
......@@ -327,7 +327,7 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn)
names_bound_here = unitNameSet new_name
in
sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me ->
mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) ->
mapFvRn (rnMatch (FunRhs name)) matches `thenRn` \ (new_matches, fvs) ->
mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_`
returnRn
[(unitNameSet new_name,
......@@ -387,12 +387,12 @@ rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn)
-- Gruesome; bring into scope the correct members of the generic type variables
-- See comments in RnSource.rnSourceDecl(ClassDecl)
rn_match match@(Match _ (TypePatIn ty : _) _ _)
= extendTyVarEnvFVRn gen_tvs (rnMatch match)
= extendTyVarEnvFVRn gen_tvs (rnMatch (FunRhs name) match)
where
tvs = map rdrNameOcc (extractHsTyRdrNames ty)
gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs]
rn_match match = rnMatch match
rn_match match = rnMatch (FunRhs name) match
-- Can't handle method pattern-bindings which bind multiple methods.
......
......@@ -983,7 +983,7 @@ dupNamesErr descriptor ((name,loc) : dup_things)
= pushSrcLocRn loc $
addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
$$
(ptext SLIT("in") <+> descriptor))
descriptor)
warnDeprec :: Name -> DeprecTxt -> RnM d ()
warnDeprec name txt
......@@ -992,3 +992,4 @@ warnDeprec name txt
quotes (ppr name) <+> text "is deprecated:",
nest 4 (ppr txt) ])
\end{code}
......@@ -159,9 +159,9 @@ rnPat (TypePatIn name) =
************************************************************************
\begin{code}