import RnHsSyn
import RnMonad
import RnEnv
-import CmdLineOpts ( opt_GlasgowExts )
-import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
+import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts )
+import BasicTypes ( Fixity(..), FixityDirection(..) )
import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
ccallableClass_RDR, creturnableClass_RDR,
monadClass_RDR, enumClass_RDR, ordClass_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 )
-- 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 "a pattern" (collectPatsBinders pats) $ \ new_binders ->
mapAndUnzipRn rnPat pats `thenRn` \ (pats', pat_fvs_s) ->
rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
| 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)
returnRn (expr, emptyUniqSet)
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)
+ returnRn (HsLit lit, emptyFVs)
rnExpr (HsLam match)
= rnMatch match `thenRn` \ (match', fvMatch) ->
\begin{code}
rnRbinds str rbinds
- = mapRn field_dup_err dup_fields `thenRn_`
+ = mapRn_ field_dup_err dup_fields `thenRn_`
mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
returnRn (rbinds', plusFVs fvRbind_s)
where
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_ field_dup_err dup_fields `thenRn_`
mapAndUnzipRn rn_rpat rpats `thenRn` \ (rpats', fvs_s) ->
returnRn (rpats', plusFVs fvs_s)
where
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}
%************************************************************************
-> RnMS s ([RenamedStmt], FreeVars)
rnStmts rn_expr []
- = returnRn ([], emptyNameSet)
+ = returnRn ([], emptyFVs)
rnStmts rn_expr (stmt:stmts)
= rnStmt rn_expr stmt $ \ stmt' ->
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 "a pattern in do binding" 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)
\begin{code}
mkAssertExpr :: RnMS s RenamedHsExpr
mkAssertExpr =
- newImportedGlobalName mod occ HiFile `thenRn` \ name ->
- addOccurrenceName name `thenRn_`
- getSrcLocRn `thenRn` \ sloc ->
- let
- expr = HsApp (HsVar name)
+ newImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name ->
+ addOccurrenceName name `thenRn_`
+ 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
+ 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
+
\end{code}
%************************************************************************