X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=3e73732fabd4da6bbe084026e343914f3b1be1a0;hb=904f158f9fe208b8154029dff655a6eab4b2828e;hp=6eaa5ea0d6660f8b9e561f3acd860cb9b3c836a9;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 6eaa5ea..3e73732 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -11,7 +11,7 @@ free variables. \begin{code} module RnExpr ( - rnMatch, rnGRHSs, rnPat, + rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, checkPrecMatch ) where @@ -25,18 +25,21 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnEnv -import CmdLineOpts ( opt_GlasgowExts ) -import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) ) +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, - monadZeroClass_RDR, enumClass_RDR, ordClass_RDR, + monadClass_RDR, enumClass_RDR, ordClass_RDR, ratioDataCon_RDR, negate_RDR, assertErr_RDR, ioDataCon_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import Name ( nameUnique, isLocallyDefined, NamedThing(..) ) +import Name ( nameUnique, isLocallyDefined, NamedThing(..) + , mkSysLocalName, nameSrcLoc + ) import NameSet import UniqFM ( isNullUFM ) import FiniteMap ( elemFM ) @@ -56,7 +59,7 @@ import Outputable ********************************************************* \begin{code} -rnPat :: RdrNamePat -> RnMS s (RenamedPat, FreeVars) +rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars) rnPat WildPatIn = returnRn (WildPatIn, emptyFVs) @@ -77,9 +80,9 @@ rnPat (SigPatIn pat ty) 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, emptyFVs) + = 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', fvs) -> @@ -92,15 +95,21 @@ rnPat (AsPatIn name pat) rnPat (ConPatIn con pats) = lookupOccRn con `thenRn` \ con' -> - mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) -> - returnRn (ConPatIn con' patslist, plusFVs fvs_s `addOneFV` con') + mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> + returnRn (ConPatIn con' patslist, fvs `addOneFV` con') rnPat (ConOpPatIn pat1 con _ pat2) = rnPat pat1 `thenRn` \ (pat1', fvs1) -> lookupOccRn con `thenRn` \ con' -> - lookupFixity con' `thenRn` \ fixity -> rnPat pat2 `thenRn` \ (pat2', fvs2) -> - mkConOpPatRn pat1' con' fixity pat2' `thenRn` \ pat' -> + + 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 @@ -113,29 +122,32 @@ rnPat neg@(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', 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, emptyFVs) + returnRn (NPlusKPatIn name' lit, fvs `addOneFV` ord) rnPat (ListPatIn pats) - = addImplicitOccRn listTyCon_name `thenRn_` - mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) -> - returnRn (ListPatIn patslist, plusFVs fvs_s) + = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> + returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name) rnPat (TuplePatIn pats boxed) - = addImplicitOccRn (tupleTyCon_name boxed (length pats)) `thenRn_` - mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) -> - returnRn (TuplePatIn patslist boxed, plusFVs fvs_s) + = 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' -> @@ -150,7 +162,7 @@ rnPat (RecPatIn con rpats) ************************************************************************ \begin{code} -rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars) +rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars) rnMatch match@(Match _ pats maybe_rhs_sig grhss) = pushSrcLocRn (getMatchLoc match) $ @@ -162,7 +174,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats rhs_sig_tyvars = case maybe_rhs_sig of Nothing -> [] - Just ty -> extractHsTyVars ty + 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" @@ -172,9 +184,9 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) -- 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 "pattern" (collectPatsBinders pats) $ \ new_binders -> + bindLocalsFVRn doc (collectPatsBinders pats) $ \ new_binders -> - mapAndUnzipRn rnPat pats `thenRn` \ (pats', pat_fvs_s) -> + mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) -> rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) -> (case maybe_rhs_sig of Nothing -> returnRn (Nothing, emptyFVs) @@ -187,7 +199,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) let binder_set = mkNameSet new_binders unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs) - all_fvs = grhss_fvs `plusFV` plusFVs pat_fvs_s `plusFV` ty_fvs + all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs in warnUnusedMatches unused_binders `thenRn_` @@ -202,13 +214,13 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) %************************************************************************ \begin{code} -rnGRHSs :: RdrNameGRHSs -> RnMS s (RenamedGRHSs, FreeVars) +rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars) rnGRHSs (GRHSs grhss binds maybe_ty) = ASSERT( not (maybeToBool maybe_ty) ) rnBinds binds $ \ binds' -> - mapAndUnzipRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) -> - returnRn (GRHSs grhss' binds' Nothing, plusFVs fvGRHSs) + mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) -> + returnRn (GRHSs grhss' binds' Nothing, fvGRHSs) rnGRHS (GRHS guarded locn) = pushSrcLocRn locn $ @@ -236,7 +248,7 @@ rnGRHS (GRHS guarded locn) %************************************************************************ \begin{code} -rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars) +rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars) rnExprs ls = rnExprs' ls emptyUniqSet where rnExprs' [] acc = returnRn ([], acc) @@ -256,31 +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` \ name -> if nameUnique name == assertIdKey then -- We expand it to (GHCerr.assert__ location) - mkAssertExpr `thenRn` \ expr -> - returnRn (expr, emptyUniqSet) + mkAssertExpr else -- The normal case - returnRn (HsVar name, if isLocallyDefined name - then unitNameSet name - else emptyUniqSet) + 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) -> @@ -300,21 +304,28 @@ rnExpr (OpApp e1 op _ e2) -- 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 `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) -> @@ -332,11 +343,12 @@ rnExpr (SectionR op expr) rnExpr (CCall fun args may_gc is_casm fake_result_ty) -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls - = lookupImplicitOccRn ccallableClass_RDR `thenRn_` - lookupImplicitOccRn creturnableClass_RDR `thenRn_` - lookupImplicitOccRn ioDataCon_RDR `thenRn_` + = 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) -> @@ -345,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, plusFVs (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' -> @@ -355,24 +367,24 @@ rnExpr (HsLet binds expr) rnExpr (HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ - lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too + lookupImplicitOccRn monadClass_RDR `thenRn` \ monad -> rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) -> - returnRn (HsDo do_or_lc stmts' src_loc, fvs) + returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad) rnExpr (ExplicitList exps) - = addImplicitOccRn listTyCon_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 boxed) - = addImplicitOccRn (tupleTyCon_name boxed (length exps)) `thenRn_` - rnExprs exps `thenRn` \ (exps', fvExps) -> - returnRn (ExplicitTuple exps' boxed, fvExps) + = rnExprs exps `thenRn` \ (exps', fvs) -> + returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name) + where + tycon_name = tupleTyCon_name boxed (length exps) rnExpr (RecordCon con_id rbinds) = lookupOccRn con_id `thenRn` \ conname -> rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordCon conname rbinds', fvRbinds) + returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname) rnExpr (RecordUpd expr rbinds) = rnExpr expr `thenRn` \ (expr', fvExpr) -> @@ -392,9 +404,9 @@ rnExpr (HsIf p b1 b2 src_loc) 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) -> @@ -426,9 +438,9 @@ 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', plusFVs fvRbind_s) + = mapRn_ field_dup_err dup_fields `thenRn_` + mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) -> + returnRn (rbinds', fvRbind) where (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ] @@ -437,12 +449,12 @@ rnRbinds str rbinds 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_` - mapAndUnzipRn rn_rpat rpats `thenRn` \ (rpats', fvs_s) -> - returnRn (rpats', plusFVs fvs_s) + = mapRn_ field_dup_err dup_fields `thenRn_` + mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) -> + returnRn (rpats', fvs) where (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ] @@ -451,7 +463,7 @@ rnRpats rpats rn_rpat (field, pat, pun) = lookupGlobalOccRn field `thenRn` \ fieldname -> rnPat pat `thenRn` \ (pat', fvs) -> - returnRn ((fieldname, pat', pun), fvs) + returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname) \end{code} %************************************************************************ @@ -469,34 +481,35 @@ 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] - -> RnMS s ([RenamedStmt], FreeVars) + -> RnMS ([RenamedStmt], FreeVars) rnStmts rn_expr [] - = returnRn ([], emptyNameSet) + = returnRn ([], emptyFVs) rnStmts rn_expr (stmt:stmts) = rnStmt rn_expr stmt $ \ stmt' -> 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) -> - bindLocalsFVRn "pattern in do binding" binders $ \ new_binders -> + 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 `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 $ @@ -537,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 @@ -600,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 @@ -632,13 +645,19 @@ not_op_pat other = True \end{code} \begin{code} -checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS s () +checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS () checkPrecMatch False fn match = returnRn () + checkPrecMatch True op (Match _ [p1,p2] _ _) - = checkPrec op p1 False `thenRn_` - checkPrec op p2 True + = 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 @@ -699,24 +718,25 @@ are made available. \begin{code} litOccurrence (HsChar _) - = addImplicitOccRn charTyCon_name + = returnRn (unitFV charTyCon_name) litOccurrence (HsCharPrim _) - = addImplicitOccRn (getName charPrimTyCon) + = returnRn (unitFV (getName charPrimTyCon)) litOccurrence (HsString _) - = addImplicitOccRn listTyCon_name `thenRn_` - addImplicitOccRn charTyCon_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. @@ -724,16 +744,17 @@ litOccurrence (HsFrac _) -- 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} %************************************************************************ @@ -743,20 +764,34 @@ litOccurrence (HsLitLit _) %************************************************************************ \begin{code} -mkAssertExpr :: RnMS s RenamedHsExpr +mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars) mkAssertExpr = - newImportedGlobalName mod occ HiFile `thenRn` \ name -> - addOccurrenceName name `thenRn_` - getSrcLocRn `thenRn` \ sloc -> - let - expr = HsApp (HsVar name) + 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 - where - mod = rdrNameModule assertErr_RDR - occ = rdrNameOcc assertErr_RDR + in + returnRn (expr, unitFV name) + \end{code} %************************************************************************