X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=34df4180050b623cdf4e228b99bfe8b11b325234;hb=a61995821fca70c4d62769757d6808ebbc970e12;hp=ad7d4045daeb370e6cdb87fdc896b9b8464194f3;hpb=b9b0688a995d9b37c078507449901b20bf732daa;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index ad7d404..34df418 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -1,57 +1,54 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[RnExpr]{Renaming of expressions} Basically dependency analysis. -Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qualifier@ datatypes. In +Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In general, all of these functions return a renamed thing, and a set of free variables. \begin{code} -#include "HsVersions.h" - module RnExpr ( - rnMatch, rnGRHSsAndBinds, rnPat, + rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, checkPrecMatch ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops -#else -import {-# SOURCE #-} RnBinds -import {-# SOURCE #-} RnSource ( rnHsSigType ) -#endif +#include "HsVersions.h" + +import {-# SOURCE #-} RnBinds ( rnBinds ) +import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType ) import HsSyn import RdrHsSyn import RnHsSyn import RnMonad import RnEnv -import CmdLineOpts ( opt_GlasgowExts ) -import BasicTypes ( Fixity(..), FixityDirection(..) ) -import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, - creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR, - ratioDataCon_RDR, negate_RDR +import RnIfaces ( lookupFixity ) +import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts ) +import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity ) +import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, + ccallableClass_RDR, creturnableClass_RDR, + monadClass_RDR, enumClass_RDR, ordClass_RDR, + ratioDataCon_RDR, negate_RDR, assertErr_RDR, + ioDataCon_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import TyCon ( TyCon ) -import Id ( GenId ) -import ErrUtils ( addErrLoc, addShortErrLocLine ) -import Name -import Pretty -import UniqFM ( lookupUFM, {- ToDo:rm-} isNullUFM ) -import UniqSet ( emptyUniqSet, unitUniqSet, - unionUniqSets, unionManyUniqSets, - SYN_IE(UniqSet) +import Name ( nameUnique, isLocallyDefined, NamedThing(..) + , mkSysLocalName, nameSrcLoc ) -import Util ( Ord3(..), removeDups, panic, pprPanic, assertPanic ) +import NameSet +import UniqFM ( isNullUFM ) +import FiniteMap ( elemFM ) +import UniqSet ( emptyUniqSet, UniqSet ) +import Unique ( assertIdKey ) +import Util ( removeDups ) +import ListSetOps ( unionLists ) +import Maybes ( maybeToBool ) import Outputable - \end{code} @@ -62,39 +59,58 @@ import Outputable ********************************************************* \begin{code} -rnPat :: RdrNamePat -> RnMS s RenamedPat +rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars) -rnPat WildPatIn = returnRn WildPatIn +rnPat WildPatIn = returnRn (WildPatIn, emptyFVs) rnPat (VarPatIn name) = lookupBndrRn name `thenRn` \ vname -> - returnRn (VarPatIn vname) + returnRn (VarPatIn vname, emptyFVs) +rnPat (SigPatIn pat ty) + | opt_GlasgowExts + = rnPat pat `thenRn` \ (pat', fvs1) -> + rnHsType doc ty `thenRn` \ (ty', fvs2) -> + returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2) + + | otherwise + = addErrRn (patSigErr ty) `thenRn_` + rnPat pat + where + doc = text "a pattern type-signature" + rnPat (LitPatIn lit) - = litOccurrence lit `thenRn_` - lookupImplicitOccRn eqClass_RDR `thenRn_` -- Needed to find equality on pattern - returnRn (LitPatIn lit) + = litOccurrence lit `thenRn` \ fvs1 -> + lookupImplicitOccRn eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern + returnRn (LitPatIn lit, fvs1 `addOneFV` eq) rnPat (LazyPatIn pat) - = rnPat pat `thenRn` \ pat' -> - returnRn (LazyPatIn pat') + = rnPat pat `thenRn` \ (pat', fvs) -> + returnRn (LazyPatIn pat', fvs) rnPat (AsPatIn name pat) - = rnPat pat `thenRn` \ pat' -> + = rnPat pat `thenRn` \ (pat', fvs) -> lookupBndrRn name `thenRn` \ vname -> - returnRn (AsPatIn vname pat') + returnRn (AsPatIn vname pat', fvs) rnPat (ConPatIn con pats) - = lookupOccRn con `thenRn` \ con' -> - mapRn rnPat pats `thenRn` \ patslist -> - returnRn (ConPatIn con' patslist) + = lookupOccRn con `thenRn` \ con' -> + mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> + returnRn (ConPatIn con' patslist, fvs `addOneFV` con') rnPat (ConOpPatIn pat1 con _ pat2) - = rnPat pat1 `thenRn` \ pat1' -> + = rnPat pat1 `thenRn` \ (pat1', fvs1) -> lookupOccRn con `thenRn` \ con' -> - lookupFixity con `thenRn` \ fixity -> - rnPat pat2 `thenRn` \ pat2' -> - mkConOpPatRn pat1' con' fixity pat2' + rnPat pat2 `thenRn` \ (pat2', fvs2) -> + + getModeRn `thenRn` \ mode -> + -- See comments with rnExpr (OpApp ...) + (case mode of + InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2') + SourceMode -> lookupFixity con' `thenRn` \ fixity -> + mkConOpPatRn pat1' con' fixity pat2' + ) `thenRn` \ pat' -> + returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con') -- Negated patters can only be literals, and they are dealt with -- by negating the literal at compile time, not by using the negation @@ -103,37 +119,40 @@ rnPat (ConOpPatIn pat1 con _ pat2) rnPat neg@(NegPatIn pat) = checkRn (valid_neg_pat pat) (negPatErr neg) `thenRn_` - rnPat pat `thenRn` \ pat' -> - returnRn (NegPatIn pat') + rnPat pat `thenRn` \ (pat', fvs) -> + returnRn (NegPatIn pat', fvs) where - valid_neg_pat (LitPatIn (HsInt _)) = True - valid_neg_pat (LitPatIn (HsFrac _)) = True - valid_neg_pat _ = False + valid_neg_pat (LitPatIn (HsInt _)) = True + valid_neg_pat (LitPatIn (HsIntPrim _)) = True + valid_neg_pat (LitPatIn (HsFrac _)) = True + valid_neg_pat (LitPatIn (HsFloatPrim _)) = True + valid_neg_pat (LitPatIn (HsDoublePrim _)) = True + valid_neg_pat _ = False rnPat (ParPatIn pat) - = rnPat pat `thenRn` \ pat' -> - returnRn (ParPatIn pat') + = rnPat pat `thenRn` \ (pat', fvs) -> + returnRn (ParPatIn pat', fvs) rnPat (NPlusKPatIn name lit) - = litOccurrence lit `thenRn_` - lookupImplicitOccRn ordClass_RDR `thenRn_` + = litOccurrence lit `thenRn` \ fvs -> + lookupImplicitOccRn ordClass_RDR `thenRn` \ ord -> lookupBndrRn name `thenRn` \ name' -> - returnRn (NPlusKPatIn name' lit) + returnRn (NPlusKPatIn name' lit, fvs `addOneFV` ord) rnPat (ListPatIn pats) - = addImplicitOccRn listType_name `thenRn_` - mapRn rnPat pats `thenRn` \ patslist -> - returnRn (ListPatIn patslist) + = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> + returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name) -rnPat (TuplePatIn pats) - = addImplicitOccRn (tupleType_name (length pats)) `thenRn_` - mapRn rnPat pats `thenRn` \ patslist -> - returnRn (TuplePatIn patslist) +rnPat (TuplePatIn pats boxed) + = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> + returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name) + where + tycon_name = tupleTyCon_name boxed (length pats) rnPat (RecPatIn con rpats) = lookupOccRn con `thenRn` \ con' -> - rnRpats rpats `thenRn` \ rpats' -> - returnRn (RecPatIn con' rpats') + rnRpats rpats `thenRn` \ (rpats', fvs) -> + returnRn (RecPatIn con' rpats', fvs `addOneFV` con') \end{code} ************************************************************************ @@ -143,78 +162,83 @@ rnPat (RecPatIn con rpats) ************************************************************************ \begin{code} -rnMatch, rnMatch1 :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars) +rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars) --- The only tricky bit here is that we want to do a single --- bindLocalsRn for all the matches together, so that we spot --- the repeated variable in --- f x x = 1 +rnMatch match@(Match _ pats maybe_rhs_sig grhss) + = pushSrcLocRn (getMatchLoc match) $ -rnMatch match - = bindLocalsRn "pattern" (get_binders match) $ \ new_binders -> - rnMatch1 match `thenRn` \ (match', fvs) -> - returnRn (match', fvs `minusNameSet` mkNameSet new_binders) - where - get_binders (GRHSMatch _) = [] - get_binders (PatMatch pat match) = collectPatBinders pat ++ get_binders match - -rnMatch1 (PatMatch pat match) - = rnPat pat `thenRn` \ pat' -> - rnMatch1 match `thenRn` \ (match', fvs) -> - returnRn (PatMatch pat' match', fvs) + -- Find the universally quantified type variables + -- in the pattern type signatures + getLocalNameEnv `thenRn` \ name_env -> + let + tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats + rhs_sig_tyvars = case maybe_rhs_sig of + Nothing -> [] + Just ty -> extractHsTyRdrNames ty + tyvars_in_pats = extractPatsTyVars pats + forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs + doc = text "a pattern type-signature" + in + bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ sig_tyvars -> + + -- Note that we do a single bindLocalsRn for all the + -- matches together, so that we spot the repeated variable in + -- f x x = 1 + bindLocalsFVRn doc (collectPatsBinders pats) $ \ new_binders -> + + mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) -> + rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) -> + (case maybe_rhs_sig of + Nothing -> returnRn (Nothing, emptyFVs) + Just ty | opt_GlasgowExts -> rnHsType doc ty `thenRn` \ (ty', ty_fvs) -> + returnRn (Just ty', ty_fvs) + | otherwise -> addErrRn (patSigErr ty) `thenRn_` + returnRn (Nothing, emptyFVs) + ) `thenRn` \ (maybe_rhs_sig', ty_fvs) -> -rnMatch1 (GRHSMatch grhss_and_binds) - = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) -> - returnRn (GRHSMatch grhss_and_binds', fvs) + let + binder_set = mkNameSet new_binders + unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs) + all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs + in + warnUnusedMatches unused_binders `thenRn_` + + returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs) + -- The bindLocals and bindTyVars will remove the bound FVs \end{code} %************************************************************************ %* * -\subsubsection{Guarded right-hand sides (GRHSsAndBinds)} +\subsubsection{Guarded right-hand sides (GRHSs)} %* * %************************************************************************ \begin{code} -rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars) - -rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) - = rnBinds binds $ \ binds' -> - rnGRHSs grhss `thenRn` \ (grhss', fvGRHS) -> - returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS) - where - rnGRHSs [] = returnRn ([], emptyNameSet) - - rnGRHSs (grhs:grhss) - = rnGRHS grhs `thenRn` \ (grhs', fvs) -> - rnGRHSs grhss `thenRn` \ (grhss', fvss) -> - returnRn (grhs' : grhss', fvs `unionNameSets` fvss) - - rnGRHS (GRHS guard expr locn) - = pushSrcLocRn locn $ - (if not (opt_GlasgowExts || is_standard_guard guard) then - addWarnRn (nonStdGuardErr guard) - else +rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars) + +rnGRHSs (GRHSs grhss binds maybe_ty) + = ASSERT( not (maybeToBool maybe_ty) ) + rnBinds binds $ \ binds' -> + mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) -> + returnRn (GRHSs grhss' binds' Nothing, fvGRHSs) + +rnGRHS (GRHS guarded locn) + = pushSrcLocRn locn $ + (if not (opt_GlasgowExts || is_standard_guard guarded) then + addWarnRn (nonStdGuardErr guarded) + else returnRn () - ) `thenRn_` - - (rnStmts rnExpr guard $ \ guard' -> - -- This nested thing deals with scope and - -- the free vars of the guard, and knocking off the - -- free vars of the rhs that are bound by the guard - - rnExpr expr `thenRn` \ (expr', fvse) -> - returnRn (GRHS guard' expr' locn, fvse)) - - rnGRHS (OtherwiseGRHS expr locn) - = pushSrcLocRn locn $ - rnExpr expr `thenRn` \ (expr', fvs) -> - returnRn (GRHS [] expr' locn, fvs) + ) `thenRn_` + rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) -> + returnRn (GRHS guarded' locn, fvs) + where -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the -- Glasgow extension - is_standard_guard [GuardStmt _ _] = True - is_standard_guard other = False + is_standard_guard [ExprStmt _ _] = True + is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True + is_standard_guard other = False \end{code} %************************************************************************ @@ -224,7 +248,7 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) %************************************************************************ \begin{code} -rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars) +rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars) rnExprs ls = rnExprs' ls emptyUniqSet where rnExprs' [] acc = returnRn ([], acc) @@ -234,7 +258,7 @@ rnExprs ls = rnExprs' ls emptyUniqSet -- Now we do a "seq" on the free vars because typically it's small -- or empty, especially in very long lists of constants let - acc' = acc `unionNameSets` fvExpr + acc' = acc `plusFV` fvExpr in (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) -> returnRn (expr':exprs', fvExprs) @@ -244,25 +268,23 @@ grubby_seqNameSet ns result | isNullUFM ns = result | otherwise = result \end{code} -Variables. We look up the variable and return the resulting name. The -interesting question is what the free-variable set should be. We -don't want to return imported or prelude things as free vars. So we -look at the Name returned from the lookup, and make it part of the -free-var set iff if it's a LocallyDefined Name. -\end{itemize} +Variables. We look up the variable and return the resulting name. \begin{code} -rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars) +rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) rnExpr (HsVar v) - = lookupOccRn v `thenRn` \ vname -> - returnRn (HsVar vname, if isLocallyDefined vname - then unitNameSet vname - else emptyUniqSet) + = lookupOccRn v `thenRn` \ name -> + if nameUnique name == assertIdKey then + -- We expand it to (GHCerr.assert__ location) + mkAssertExpr + else + -- The normal case + returnRn (HsVar name, unitFV name) rnExpr (HsLit lit) - = litOccurrence lit `thenRn_` - returnRn (HsLit lit, emptyNameSet) + = litOccurrence lit `thenRn` \ fvs -> + returnRn (HsLit lit, fvs) rnExpr (HsLam match) = rnMatch match `thenRn` \ (match', fvMatch) -> @@ -271,32 +293,39 @@ rnExpr (HsLam match) rnExpr (HsApp fun arg) = rnExpr fun `thenRn` \ (fun',fvFun) -> rnExpr arg `thenRn` \ (arg',fvArg) -> - returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg) + returnRn (HsApp fun' arg', fvFun `plusFV` fvArg) -rnExpr (OpApp e1 op@(HsVar op_name) _ e2) +rnExpr (OpApp e1 op _ e2) = rnExpr e1 `thenRn` \ (e1', fv_e1) -> rnExpr e2 `thenRn` \ (e2', fv_e2) -> - rnExpr op `thenRn` \ (op', fv_op) -> + rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) -> -- Deal with fixity -- When renaming code synthesised from "deriving" declarations -- we're in Interface mode, and we should ignore fixity; assume -- that the deriving code generator got the association correct - lookupFixity op_name `thenRn` \ fixity -> + -- Don't even look up the fixity when in interface mode getModeRn `thenRn` \ mode -> (case mode of - SourceMode -> mkOpAppRn e1' op' fixity e2' - InterfaceMode _ -> returnRn (OpApp e1' op' fixity e2') + SourceMode -> lookupFixity op_name `thenRn` \ fixity -> + mkOpAppRn e1' op' fixity e2' + InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2') ) `thenRn` \ final_e -> returnRn (final_e, - fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2) + fv_e1 `plusFV` fv_op `plusFV` fv_e2) + +-- constant-fold some negate applications on unboxed literals. Since +-- negate is a polymorphic function, we have to do these here. +rnExpr (NegApp (HsLit (HsIntPrim i)) _) = rnExpr (HsLit (HsIntPrim (-i))) +rnExpr (NegApp (HsLit (HsFloatPrim i)) _) = rnExpr (HsLit (HsFloatPrim (-i))) +rnExpr (NegApp (HsLit (HsDoublePrim i)) _) = rnExpr (HsLit (HsDoublePrim (-i))) rnExpr (NegApp e n) = rnExpr e `thenRn` \ (e', fv_e) -> lookupImplicitOccRn negate_RDR `thenRn` \ neg -> mkNegAppRn e' (HsVar neg) `thenRn` \ final_e -> - returnRn (final_e, fv_e) + returnRn (final_e, fv_e `addOneFV` neg) rnExpr (HsPar e) = rnExpr e `thenRn` \ (e', fvs_e) -> @@ -305,18 +334,21 @@ rnExpr (HsPar e) rnExpr (SectionL expr op) = rnExpr expr `thenRn` \ (expr', fvs_expr) -> rnExpr op `thenRn` \ (op', fvs_op) -> - returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr) + returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr) rnExpr (SectionR op expr) = rnExpr op `thenRn` \ (op', fvs_op) -> rnExpr expr `thenRn` \ (expr', fvs_expr) -> - returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr) + returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr) rnExpr (CCall fun args may_gc is_casm fake_result_ty) - = lookupImplicitOccRn ccallableClass_RDR `thenRn_` - lookupImplicitOccRn creturnableClass_RDR `thenRn_` + -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls + = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc -> + lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr -> + lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io -> rnExprs args `thenRn` \ (args', fvs_args) -> - returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args) + returnRn (CCall fun args' may_gc is_casm fake_result_ty, + fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io) rnExpr (HsSCC label expr) = rnExpr expr `thenRn` \ (expr', fvs_expr) -> @@ -325,8 +357,8 @@ rnExpr (HsSCC label expr) rnExpr (HsCase expr ms src_loc) = pushSrcLocRn src_loc $ rnExpr expr `thenRn` \ (new_expr, e_fvs) -> - mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) -> - returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs)) + mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) -> + returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) = rnBinds binds $ \ binds' -> @@ -335,46 +367,46 @@ rnExpr (HsLet binds expr) rnExpr (HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ - lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too - (rnStmts rnExpr stmts $ \ stmts' -> - returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet)) + lookupImplicitOccRn monadClass_RDR `thenRn` \ monad -> + rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) -> + returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad) rnExpr (ExplicitList exps) - = addImplicitOccRn listType_name `thenRn_` - rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitList exps', fvs) + = rnExprs exps `thenRn` \ (exps', fvs) -> + returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name) -rnExpr (ExplicitTuple exps) - = addImplicitOccRn (tupleType_name (length exps)) `thenRn_` - rnExprs exps `thenRn` \ (exps', fvExps) -> - returnRn (ExplicitTuple exps', fvExps) +rnExpr (ExplicitTuple exps boxed) + = rnExprs exps `thenRn` \ (exps', fvs) -> + returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name) + where + tycon_name = tupleTyCon_name boxed (length exps) -rnExpr (RecordCon (HsVar con) rbinds) - = lookupOccRn con `thenRn` \ conname -> +rnExpr (RecordCon con_id rbinds) + = lookupOccRn con_id `thenRn` \ conname -> rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordCon (HsVar conname) rbinds', fvRbinds) + returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname) rnExpr (RecordUpd expr rbinds) = rnExpr expr `thenRn` \ (expr', fvExpr) -> rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds) + returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds) rnExpr (ExprWithTySig expr pty) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnHsSigType (\ sty -> text "an expression") pty `thenRn` \ pty' -> - returnRn (ExprWithTySig expr' pty', fvExpr) + = rnExpr expr `thenRn` \ (expr', fvExpr) -> + rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) -> + returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) rnExpr (HsIf p b1 b2 src_loc) = pushSrcLocRn src_loc $ rnExpr p `thenRn` \ (p', fvP) -> rnExpr b1 `thenRn` \ (b1', fvB1) -> rnExpr b2 `thenRn` \ (b2', fvB2) -> - returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2]) + returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) rnExpr (ArithSeqIn seq) - = lookupImplicitOccRn enumClass_RDR `thenRn_` + = lookupImplicitOccRn enumClass_RDR `thenRn` \ enum -> rn_seq seq `thenRn` \ (new_seq, fvs) -> - returnRn (ArithSeqIn new_seq, fvs) + returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum) where rn_seq (From expr) = rnExpr expr `thenRn` \ (expr', fvExpr) -> @@ -383,19 +415,19 @@ rnExpr (ArithSeqIn seq) rn_seq (FromThen expr1 expr2) = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2) + returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) rn_seq (FromTo expr1 expr2) = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2) + returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) rn_seq (FromThenTo expr1 expr2 expr3) = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> returnRn (FromThenTo expr1' expr2' expr3', - unionManyNameSets [fvExpr1, fvExpr2, fvExpr3]) + plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} %************************************************************************ @@ -406,31 +438,32 @@ rnExpr (ArithSeqIn seq) \begin{code} rnRbinds str rbinds - = mapRn field_dup_err dup_fields `thenRn_` - mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) -> - returnRn (rbinds', unionManyNameSets fvRbind_s) + = mapRn_ field_dup_err dup_fields `thenRn_` + mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) -> + returnRn (rbinds', fvRbind) where - (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ] + (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ] field_dup_err dups = addErrRn (dupFieldErr str dups) rn_rbind (field, expr, pun) = lookupGlobalOccRn field `thenRn` \ fieldname -> rnExpr expr `thenRn` \ (expr', fvExpr) -> - returnRn ((fieldname, expr', pun), fvExpr) + returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname) rnRpats rpats - = mapRn field_dup_err dup_fields `thenRn_` - mapRn rn_rpat rpats + = mapRn_ field_dup_err dup_fields `thenRn_` + mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) -> + returnRn (rpats', fvs) where - (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ] + (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ] field_dup_err dups = addErrRn (dupFieldErr "pattern" dups) rn_rpat (field, pat, pun) = lookupGlobalOccRn field `thenRn` \ fieldname -> - rnPat pat `thenRn` \ pat' -> - returnRn (fieldname, pat', pun) + rnPat pat `thenRn` \ (pat', fvs) -> + returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname) \end{code} %************************************************************************ @@ -448,51 +481,52 @@ be @{r}@, and the free var set for the entire Quals will be @{r}@. This Quals. \begin{code} -type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars) +type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) -rnStmts :: RnExprTy s +rnStmts :: RnExprTy -> [RdrNameStmt] - -> ([RenamedStmt] -> RnMS s (a, FreeVars)) - -> RnMS s (a, FreeVars) + -> RnMS ([RenamedStmt], FreeVars) -rnStmts rn_expr [] thing_inside - = thing_inside [] +rnStmts rn_expr [] + = returnRn ([], emptyFVs) -rnStmts rn_expr (stmt:stmts) thing_inside +rnStmts rn_expr (stmt:stmts) = rnStmt rn_expr stmt $ \ stmt' -> - rnStmts rn_expr stmts $ \ stmts' -> - thing_inside (stmt' : stmts') + rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) -> + returnRn (stmt' : stmts', fvs) -rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars) +rnStmt :: RnExprTy -> RdrNameStmt + -> (RenamedStmt -> RnMS (a, FreeVars)) + -> RnMS (a, FreeVars) -- Because of mutual recursion we have to pass in rnExpr. rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside = pushSrcLocRn src_loc $ rn_expr expr `thenRn` \ (expr', fv_expr) -> - bindLocalsRn "pattern in do binding" binders $ \ new_binders -> - rnPat pat `thenRn` \ pat' -> - + bindLocalsFVRn doc binders $ \ new_binders -> + rnPat pat `thenRn` \ (pat', fv_pat) -> thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders)) + returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat) where binders = collectPatBinders pat + doc = text "a pattern in do binding" rnStmt rn_expr (ExprStmt expr src_loc) thing_inside = pushSrcLocRn src_loc $ rn_expr expr `thenRn` \ (expr', fv_expr) -> thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `unionNameSets` fvs) + returnRn (result, fv_expr `plusFV` fvs) rnStmt rn_expr (GuardStmt expr src_loc) thing_inside = pushSrcLocRn src_loc $ rn_expr expr `thenRn` \ (expr', fv_expr) -> thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `unionNameSets` fvs) + returnRn (result, fv_expr `plusFV` fvs) rnStmt rn_expr (ReturnStmt expr) thing_inside = rn_expr expr `thenRn` \ (expr', fv_expr) -> thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `unionNameSets` fvs) + returnRn (result, fv_expr `plusFV` fvs) rnStmt rn_expr (LetStmt binds) thing_inside = rnBinds binds $ \ binds' -> @@ -516,7 +550,7 @@ operator appications left-associatively. \begin{code} mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr - -> RnMS s RenamedHsExpr + -> RnMS RenamedHsExpr mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 @@ -546,7 +580,10 @@ mkOpAppRn e1@(NegApp neg_arg neg_op) (nofix_error, rearrange_me) = compareFixity fix_neg fix2 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment - = ASSERT( right_op_ok fix e2 ) + = ASSERT( if right_op_ok fix e2 then True + else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op, + text "---", ppr fix, text "---", ppr e2]) + ) returnRn (OpApp e1 op fix e2) get (HsVar n) = n @@ -576,7 +613,7 @@ not_op_app mode other = True \begin{code} mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat - -> RnMS s RenamedPat + -> RnMS RenamedPat mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) op2 fix2 p2 @@ -608,15 +645,20 @@ not_op_pat other = True \end{code} \begin{code} -checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s () +checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS () checkPrecMatch False fn match = returnRn () -checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _))) - = checkPrec op p1 False `thenRn_` - checkPrec op p2 True -checkPrecMatch True op _ - = panic "checkPrecMatch" + +checkPrecMatch True op (Match _ [p1,p2] _ _) + = getModeRn `thenRn` \ mode -> + -- See comments with rnExpr (OpApp ...) + case mode of + InterfaceMode -> returnRn () + SourceMode -> checkPrec op p1 False `thenRn_` + checkPrec op p2 True + +checkPrecMatch True op _ = panic "checkPrecMatch" checkPrec op (ConOpPatIn _ op1 _ _) right = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> @@ -642,9 +684,10 @@ checkPrec op pat right \end{code} Consider +\begin{verbatim} a `op1` b `op2` c - -(compareFixity op1 op2) tells which way to arrange appication, or +\end{verbatim} +@(compareFixity op1 op2)@ tells which way to arrange appication, or whether there's an error. \begin{code} @@ -652,10 +695,10 @@ compareFixity :: Fixity -> Fixity -> (Bool, -- Error please Bool) -- Associate to the right: a op1 (b op2 c) compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) - = case prec1 `cmp` prec2 of - GT_ -> left - LT_ -> right - EQ_ -> case (dir1, dir2) of + = case prec1 `compare` prec2 of + GT -> left + LT -> right + EQ -> case (dir1, dir2) of (InfixR, InfixR) -> right (InfixL, InfixL) -> left _ -> error_please @@ -671,46 +714,87 @@ compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) %* * %************************************************************************ -When literals occur we have to make sure that the types and classes they involve +When literals occur we have to make sure +that the types and classes they involve are made available. \begin{code} litOccurrence (HsChar _) - = addImplicitOccRn charType_name + = returnRn (unitFV charTyCon_name) litOccurrence (HsCharPrim _) - = addImplicitOccRn (getName charPrimTyCon) + = returnRn (unitFV (getName charPrimTyCon)) litOccurrence (HsString _) - = addImplicitOccRn listType_name `thenRn_` - addImplicitOccRn charType_name + = returnRn (unitFV listTyCon_name `plusFV` unitFV charTyCon_name) litOccurrence (HsStringPrim _) - = addImplicitOccRn (getName addrPrimTyCon) + = returnRn (unitFV (getName addrPrimTyCon)) litOccurrence (HsInt _) - = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num + = lookupImplicitOccRn numClass_RDR `thenRn` \ num -> + returnRn (unitFV num) -- Int and Integer are forced in by Num litOccurrence (HsFrac _) - = lookupImplicitOccRn fractionalClass_RDR `thenRn_` - lookupImplicitOccRn ratioDataCon_RDR + = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac -> + lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio -> + returnRn (unitFV frac `plusFV` unitFV ratio) -- We have to make sure that the Ratio type is imported with -- its constructor, because literals of type Ratio t are - -- built with that constructor. + -- built with that constructor. + -- The Rational type is needed too, but that will come in + -- when fractionalClass does. litOccurrence (HsIntPrim _) - = addImplicitOccRn (getName intPrimTyCon) + = returnRn (unitFV (getName intPrimTyCon)) litOccurrence (HsFloatPrim _) - = addImplicitOccRn (getName floatPrimTyCon) + = returnRn (unitFV (getName floatPrimTyCon)) litOccurrence (HsDoublePrim _) - = addImplicitOccRn (getName doublePrimTyCon) + = returnRn (unitFV (getName doublePrimTyCon)) litOccurrence (HsLitLit _) - = lookupImplicitOccRn ccallableClass_RDR + = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc -> + returnRn (unitFV cc) \end{code} +%************************************************************************ +%* * +\subsubsection{Assertion utils} +%* * +%************************************************************************ + +\begin{code} +mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars) +mkAssertExpr = + mkImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name -> + getSrcLocRn `thenRn` \ sloc -> + + -- if we're ignoring asserts, return (\ _ e -> e) + -- if not, return (assertError "src-loc") + + if opt_IgnoreAsserts then + getUniqRn `thenRn` \ uniq -> + let + vname = mkSysLocalName uniq SLIT("v") + expr = HsLam ignorePredMatch + loc = nameSrcLoc vname + ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing + (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc] + EmptyBinds Nothing) + in + returnRn (expr, unitFV name) + else + let + expr = + HsApp (HsVar name) + (HsLit (HsString (_PK_ (showSDoc (ppr sloc))))) + + in + returnRn (expr, unitFV name) + +\end{code} %************************************************************************ %* * @@ -719,28 +803,34 @@ litOccurrence (HsLitLit _) %************************************************************************ \begin{code} -dupFieldErr str (dup:rest) sty - = hcat [ptext SLIT("duplicate field name `"), - ppr sty dup, - ptext SLIT("' in record "), text str] +dupFieldErr str (dup:rest) + = hsep [ptext SLIT("duplicate field name"), + quotes (ppr dup), + ptext SLIT("in record"), text str] -negPatErr pat sty - = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat] +negPatErr pat + = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)] -precParseNegPatErr op sty +precParseNegPatErr op = hang (ptext SLIT("precedence parsing error")) - 4 (hcat [ptext SLIT("prefix `-' has lower precedence than "), - pp_op sty op, - ptext SLIT(" in pattern")]) + 4 (hsep [ptext SLIT("prefix `-' has lower precedence than"), + quotes (pp_op op), + ptext SLIT("in pattern")]) -precParseErr op1 op2 sty +precParseErr op1 op2 = hang (ptext SLIT("precedence parsing error")) - 4 (hcat [ptext SLIT("cannot mix "), pp_op sty op1, ptext SLIT(" and "), pp_op sty op2, - ptext SLIT(" in the same infix expression")]) + 4 (hsep [ptext SLIT("cannot mix"), quotes (pp_op op1), ptext SLIT("and"), + quotes (pp_op op2), + ptext SLIT("in the same infix expression")]) + +nonStdGuardErr guard + = hang (ptext + SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)") + ) 4 (ppr guard) -nonStdGuardErr guard sty - = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")) - 4 (ppr sty guard) +patSigErr ty + = hang (ptext SLIT("Illegal signature in pattern:") <+> ppr ty) + 4 (ptext SLIT("Use -fglasgow-exts to permit it")) -pp_op sty (op, fix) = hcat [ppr sty op, space, parens (ppr sty fix)] +pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)] \end{code}