- 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.
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 $
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 )
-- 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
| 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)
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)
-- 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)
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
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!
-- 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
, 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
where
do_expr expr locn = putSrcLocDs locn (dsExpr expr)
-
- match_msg = case do_or_lc of
- DoExpr -> "`do' statement"
- ListComp -> "comprehension"
\end{code}
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 )
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))
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
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 $
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 ->
#include "HsVersions.h"
-import HsSyn ( HsMatchContext )
+import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext )
import Bag ( emptyBag, snocBag, Bag )
import ErrUtils ( WarnMsg )
import Id ( mkSysLocal, setIdUnique, Id )
import Var ( TyVar, setTyVarUnique )
import Outputable
import SrcLoc ( noSrcLoc, SrcLoc )
-import TcHsSyn ( TypecheckedPat )
import Type ( Type )
import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
\begin{code}
data DsMatchContext
- = DsMatchContext HsMatchContext [TypecheckedPat] SrcLoc
+ = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
| NoMatchContext
deriving ()
\end{code}
_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 ;;
__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 ;
import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
-import TcHsSyn ( TypecheckedPat, TypecheckedMatch )
+import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext )
import DsHsSyn ( outPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
\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}
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 ->
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
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
This is actually local to @matchWrapper@.
\begin{code}
-flattenMatches :: HsMatchContext
+flattenMatches :: TypecheckedMatchContext
-> [TypecheckedMatch]
-> DsM (Type, [EquationInfo])
#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 )
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 ;
| 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 >>=
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
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")],
\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}
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 '|')
%************************************************************************
\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}
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}
= -- 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
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,
-- 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.
= pushSrcLocRn loc $
addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
$$
- (ptext SLIT("in") <+> descriptor))
+ descriptor)
warnDeprec :: Name -> DeprecTxt -> RnM d ()
warnDeprec name txt
quotes (ppr name) <+> text "is deprecated:",
nest 4 (ppr txt) ])
\end{code}
+
************************************************************************
\begin{code}
-rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
+rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
-rnMatch match@(Match _ pats maybe_rhs_sig grhss)
+rnMatch ctxt match@(Match _ pats maybe_rhs_sig grhss)
= pushSrcLocRn (getMatchLoc match) $
-- Bind pattern-bound type variables
Nothing -> []
Just ty -> [ty]
pat_sig_tys = collectSigTysFromPats pats
- doc_sig = text "a result type-signature"
- doc_pat = text "a pattern match"
+ doc_sig = text "In a result type-signature"
+ doc_pat = pprMatchContext ctxt
in
bindPatSigTyVars (rhs_sig_tys ++ pat_sig_tys) $ \ sig_tyvars ->
let
tyvars_in_sigs = extractHsTysRdrTyVars tys
forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
- doc_sig = text "a pattern type-signature"
+ doc_sig = text "In a pattern type-signature"
in
bindNakedTyVarsFVRn doc_sig forall_tyvars thing_inside
\end{code}
returnRn (HsOverLit lit', fvs)
rnExpr (HsLam match)
- = rnMatch match `thenRn` \ (match', fvMatch) ->
+ = rnMatch LambdaExpr match `thenRn` \ (match', fvMatch) ->
returnRn (HsLam match', fvMatch)
rnExpr (HsApp fun arg)
rnExpr (HsCase expr ms src_loc)
= pushSrcLocRn src_loc $
- rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
- mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
+ rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
+ mapFvRn (rnMatch CaseAlt) ms `thenRn` \ (new_ms, ms_fvs) ->
returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
rnExpr (HsLet binds expr)
returnRn ((new_binders ++ rest_binders, result),
fv_expr `plusFV` fvs `plusFV` fv_pat)
where
- doc = text "a pattern in do binding"
+ doc = text "In a pattern in 'do' binding"
rnStmt (ExprStmt expr src_loc) thing_inside
= pushSrcLocRn src_loc $
type RenamedHsExpr = HsExpr Name RenamedPat
type RenamedHsModule = HsModule Name RenamedPat
type RenamedInstDecl = InstDecl Name RenamedPat
+type RenamedMatchContext = HsMatchContext Name
type RenamedMatch = Match Name RenamedPat
type RenamedMonoBinds = MonoBinds Name RenamedPat
type RenamedPat = InPat Name
mapFvRn (rnHsTypeFVs doc_str) tys `thenRn` \ (tys', fvs) ->
returnRn (DefD (DefaultDecl tys' src_loc), fvs)
where
- doc_str = text "a `default' declaration"
+ doc_str = text "In a `default' declaration"
\end{code}
-- Used for both source decls only
= ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl!
let
- meth_doc = text "the bindings in an instance declaration"
+ meth_doc = text "In the bindings in an instance declaration"
meth_names = collectLocatedMonoBinders mbinds
inst_tyvars = case inst_ty of
HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
returnRn (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc,
fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
where
- doc = text "the transformation rule" <+> ptext rule_name
+ doc = text "In the transformation rule" <+> ptext rule_name
sig_tvs = extractRuleBndrsTyVars vars
get_var (RuleBndr v) = v
mapRn rnIdInfo id_infos `thenRn` \ id_infos' ->
returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
where
- doc_str = text "the interface signature for" <+> quotes (ppr name)
+ doc_str = text "In the interface signature for" <+> quotes (ppr name)
rnTyClDecl (ForeignType {tcdName = name, tcdFoType = spec, tcdLoc = loc})
= pushSrcLocRn loc $
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
rnContext data_doc context `thenRn` \ context' ->
checkDupOrQualNames data_doc con_names `thenRn_`
+
+ -- Check that there's at least one condecl,
+ -- or else we're reading an interface file, or -fglasgow-exts
+ (if null condecls then
+ doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
+ getModeRn `thenRn` \ mode ->
+ checkRn (glaExts || isInterfaceMode mode)
+ (emptyConDeclsErr tycon)
+ else returnRn ()
+ ) `thenRn_`
+
mapRn rnConDecl condecls `thenRn` \ condecls' ->
mapRn lookupSysBinder sys_names `thenRn` \ sys_names' ->
returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
tcdDerivs = Nothing, tcdLoc = src_loc, tcdSysNames = sys_names'})
where
- data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
+ data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
con_names = map conDeclName condecls
rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ ty' ->
returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
where
- syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
+ syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
-- For H98 we do *not* universally quantify on the RHS of a synonym
-- Silently discard context... but the tyvars in the rest won't be in scope
tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
tcdSysNames = names', tcdLoc = src_loc})
where
- cls_doc = text "the declaration for class" <+> ppr cname
- sig_doc = text "the signatures for class" <+> ppr cname
+ cls_doc = text "In the declaration for class" <+> ppr cname
+ sig_doc = text "In the signatures for class" <+> ppr cname
rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn)
= pushSrcLocRn locn $
rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
where
- meth_doc = text "the default-methods for class" <+> ppr (tcdName rn_cls_decl)
+ meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
-- Not a class or data type declaration
rnConDetails doc locn details `thenRn` \ new_details ->
returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn)
where
- doc = text "the definition of data constructor" <+> quotes (ppr name)
+ doc = text "In the definition of data constructor" <+> quotes (ppr name)
rnConDetails doc locn (VanillaCon tys)
= mapRn (rnBangTy doc) tys `thenRn` \ new_tys ->
-- rnHsSigType is used for source-language type signatures,
-- which use *implicit* universal quantification.
rnHsSigType doc_str ty
- = rnHsType (text "the type signature for" <+> doc_str) ty
+ = rnHsType (text "In the type signature for" <+> doc_str) ty
---------------------------------------
rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
$$
- (ptext SLIT("In") <+> doc)
+ doc
)
}
naughtyCCallContextErr (HsClassP clas _)
= sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
ptext SLIT("in a context")]
+emptyConDeclsErr tycon
+ = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
+ nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
\end{code}
complete_it xve = tcAddSrcLoc locn $
tcAddErrCtxt (patMonoBindsCtxt bind) $
tcExtendLocalValEnv xve $
- tcGRHSs grhss pat_ty PatBindRhs `thenTc` \ (grhss', lie) ->
+ tcGRHSs PatBindRhs grhss pat_ty `thenTc` \ (grhss', lie) ->
returnTc (PatMonoBind pat' grhss' locn, lie)
in
returnTc (complete_it, lie_req, tvs, ids, lie_avail)
#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsMatchContext(..), mkMonoBind
+ HsMatchContext(..), HsDoContext(..), mkMonoBind
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds, mkHsLet )
returnNF_Tc (m_ty, (mkAppTy m_ty, elt_ty))
) `thenNF_Tc` \ (tc_ty, m_ty) ->
- tcStmts do_or_lc m_ty stmts `thenTc` \ (stmts', stmts_lie) ->
+ tcStmts (DoCtxt do_or_lc) m_ty stmts `thenTc` \ (stmts', stmts_lie) ->
-- Build the then and zero methods in case we need them
-- It's important that "then" and "return" appear just once in the final LIE,
import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..),
Match(..), GRHSs(..), Stmt(..), HsLit(..),
- HsBinds(..), HsType(..), HsMatchContext(..),
+ HsBinds(..), HsType(..), HsDoContext(..),
unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList
)
import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
TypecheckedMatch, TypecheckedHsModule,
TypecheckedGRHSs, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
+ TypecheckedMatchContext,
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
type TypecheckedStmt = Stmt Id TypecheckedPat
type TypecheckedMatch = Match Id TypecheckedPat
+type TypecheckedMatchContext = HsMatchContext Id
type TypecheckedGRHSs = GRHSs Id TypecheckedPat
type TypecheckedGRHS = GRHS Id TypecheckedPat
type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
TcMatches tcGRHSs tcMatchesFun;
_declarations_
2 tcGRHSs _:_ _forall_ [s] =>
- RnHsSyn.RenamedGRHSs
+ HsExpr.HsMatchContext Name.Name
+ -> RnHsSyn.RenamedGRHSs
-> TcMonad.TcType
- -> HsExpr.HsMatchContext
-> TcMonad.TcM s (TcHsSyn.TcGRHSs, Inst.LIE) ;;
3 tcMatchesFun _:_ _forall_ [s] =>
[(Name.Name,Var.Id)]
__interface TcMatches 1 0 where
__export TcMatches tcGRHSs tcMatchesFun;
-1 tcGRHSs ::
- RnHsSyn.RenamedGRHSs
+1 tcGRHSs :: HsExpr.HsMatchContext Name.Name
+ -> RnHsSyn.RenamedGRHSs
-> TcMonad.TcType
- -> HsExpr.HsMatchContext
-> TcMonad.TcM (TcHsSyn.TcGRHSs, Inst.LIE) ;
1 tcMatchesFun ::
[(Name.Name,Var.Id)]
import {-# SOURCE #-} TcExpr( tcExpr )
import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
- MonoBinds(..), Stmt(..), HsMatchContext(..),
+ MonoBinds(..), Stmt(..), HsMatchContext(..), HsDoContext(..),
pprMatch, getMatchLoc, pprMatchContext, isDoExpr,
mkMonoBind, nullMonoBinds, collectSigTysFromPats
)
import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedPat, RenamedHsType,
- extractHsTyVars )
-import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat )
+ RenamedMatchContext, extractHsTyVars )
+import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat, TypecheckedMatchContext )
import TcMonad
import TcMonoType ( kcHsSigTypes, tcScopedTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
-- may show up as something wrong with the (non-existent) type signature
-- No need to zonk expected_ty, because unifyFunTy does that on the fly
- tcMatches xve matches expected_ty (FunRhs fun_name)
+ tcMatches xve (FunRhs fun_name) matches expected_ty
\end{code}
@tcMatchesCase@ doesn't do the argument-count check because the
tcMatchesCase matches expr_ty
= newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty ->
- tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) ->
+ tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty) `thenTc` \ (matches', lie) ->
returnTc (scrut_ty, matches', lie)
tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
-tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaExpr
+tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty
\end{code}
\begin{code}
tcMatches :: [(Name,Id)]
+ -> RenamedMatchContext
-> [RenamedMatch]
-> TcType
- -> HsMatchContext
-> TcM ([TcMatch], LIE)
-tcMatches xve matches expected_ty fun_or_case
+tcMatches xve fun_or_case matches expected_ty
= mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
returnTc (matches, plusLIEs lies)
where
- tc_match match = tcMatch xve match expected_ty fun_or_case
+ tc_match match = tcMatch xve fun_or_case match expected_ty
\end{code}
\begin{code}
tcMatch :: [(Name,Id)]
+ -> RenamedMatchContext
-> RenamedMatch
-> TcType -- Expected result-type of the Match.
-- Early unification with this guy gives better error messages
- -> HsMatchContext
-> TcM (TcMatch, LIE)
-tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
+tcMatch xve1 ctxt match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty
= tcAddSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
tcAddErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
-- Typecheck the body
tcExtendLocalValEnv xve1 $
- tcGRHSs grhss rhs_ty ctxt `thenTc` \ (grhss', lie) ->
+ tcGRHSs ctxt grhss rhs_ty `thenTc` \ (grhss', lie) ->
returnTc ((pats', grhss'), lie)
)
glue_on is_rec mbinds (GRHSs grhss binds ty)
= GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
-tcGRHSs :: RenamedGRHSs
- -> TcType -> HsMatchContext
+tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
+ -> TcType
-> TcM (TcGRHSs, LIE)
-tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
+tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
= tcBindsAndThen glue_on binds (tc_grhss grhss)
where
tc_grhss grhss
tcStmtsAndThen
:: (TcStmt -> thing -> thing) -- Combiner
- -> HsMatchContext
+ -> RenamedMatchContext
-> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
-- elt_ty, where type of the comprehension is (m elt_ty)
-> [RenamedStmt]
loop ((bndrs,stmts) : pairs)
= tcStmtsAndThen
- combine_par ListComp m_ty stmts
+ combine_par (DoCtxt ListComp) m_ty stmts
-- Notice we pass on m_ty; the result type is used only
-- to get escaping type variables for checkExistentialPat
(tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
\end{code}
\begin{code}
-matchCtxt CaseAlt match
- = hang (ptext SLIT("In a case alternative:"))
- 4 (pprMatch (True,empty) {-is_case-} match)
-
-matchCtxt (FunRhs fun) match
- = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
- 4 (pprMatch (False, ppr_fun) {-not case-} match)
- where
- ppr_fun = ppr fun
-
-matchCtxt LambdaExpr match
- = hang (ptext SLIT("In the lambda expression"))
- 4 (pprMatch (True, empty) match)
+matchCtxt ctxt match = hang (pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
+stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
varyingArgsErr name matches
= sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
lurkingRank2SigErr
= ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
-
-stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
\end{code}
import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
- Stmt(..), InPat(..), HsMatchContext(..), RuleDecl(..),
+ Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch
)
import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName,
in
traceTc (text "tcs 2") `thenNF_Tc_`
- tcStmtsAndThen combine DoExpr io_ty stmts (
+ tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts (
-- Look up the names right in the middle,
-- where they will all be in scope
mapNF_Tc tcLookupId names `thenNF_Tc` \ ids ->
projects / ghc-hetmet.git / commitdiff