diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs
index 922fe48ffae541a263ed58ac8769dad19f22b2be..cb8e8c9f292173c85780c88761d5450466a564da 100644
--- a/ghc/compiler/reader/RdrHsSyn.lhs
+++ b/ghc/compiler/reader/RdrHsSyn.lhs
@@ -46,7 +46,7 @@ module RdrHsSyn (
qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual,
dummyRdrVarName, dummyRdrTcName,
isUnqual, isQual,
- showRdr, rdrNameOcc, ieOcc,
+ showRdr, rdrNameOcc, rdrNameModule, ieOcc,
cmpRdr, prefixRdrName,
mkOpApp, mkClassDecl
@@ -195,6 +195,7 @@ lexVarQual (m,n,hif) = Qual m (VarOcc n) hif
dummyRdrVarName = Unqual (VarOcc SLIT("V-DUMMY"))
dummyRdrTcName = Unqual (VarOcc SLIT("TC-DUMMY"))
+
varUnqual n = Unqual (VarOcc n)
isUnqual (Unqual _) = True
@@ -218,6 +219,9 @@ rdrNameOcc :: RdrName -> OccName
rdrNameOcc (Unqual occ) = occ
rdrNameOcc (Qual _ occ _) = occ
+rdrNameModule :: RdrName -> Module
+rdrNameModule (Qual m _ _) = m
+
ieOcc :: RdrNameIE -> OccName
ieOcc ie = rdrNameOcc (ieName ie)
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index c41b0bd7a7083809b3ea20c34b465d4310ceac24..e74404632a0e88d62281208ed90d363e5b7fb381 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -17,6 +17,7 @@ import RdrHsSyn ( RdrName(..), RdrNameIE,
import HsTypes ( getTyVarName, replaceTyVarName )
import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
import RnMonad
+import ErrUtils ( ErrMsg )
import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..),
occNameFlavour, getSrcLoc,
NameSet, emptyNameSet, addListToNameSet, nameSetToList,
@@ -254,19 +255,33 @@ Looking up a name in the RnEnv.
lookupRn :: RdrName
-> Maybe Name -- Result of environment lookup
-> RnMS s Name
-
-lookupRn rdr_name (Just name)
+lookupRn rdr_name (Just name)
= -- Found the name in the envt
returnRn name -- In interface mode the only things in
-- the environment are things in local (nested) scopes
+lookupRn rdr_name nm@Nothing
+ = tryLookupRn rdr_name nm `thenRn` \ name_or_error ->
+ case name_or_error of
+ Left (nm,err) -> failWithRn nm err
+ Right nm -> returnRn nm
+
+tryLookupRn :: RdrName
+ -> Maybe Name -- Result of environment lookup
+ -> RnMS s (Either (Name, ErrMsg) Name)
+tryLookupRn rdr_name (Just name)
+ = -- Found the name in the envt
+ returnRn (Right name) -- In interface mode the only things in
+ -- the environment are things in local (nested) scopes
-lookupRn rdr_name Nothing
+-- lookup in environment, but don't flag an error if
+-- name is not found.
+tryLookupRn rdr_name Nothing
= -- We didn't find the name in the environment
getModeRn `thenRn` \ mode ->
case mode of {
- SourceMode -> failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name) ;
- -- Souurce mode; lookup failure is an error
+ SourceMode -> returnRn (Left ( mkUnboundName rdr_name
+ , unknownNameErr rdr_name));
+ -- Source mode; lookup failure is an error
InterfaceMode _ _ ->
@@ -279,9 +294,13 @@ lookupRn rdr_name Nothing
-- So, qualify the unqualified name with the
-- module of the interface file, and try again
case rdr_name of
- Unqual occ -> getModuleRn `thenRn` \ mod ->
- newImportedGlobalName mod occ HiFile
- Qual mod occ hif -> newImportedGlobalName mod occ hif
+ Unqual occ ->
+ getModuleRn `thenRn` \ mod ->
+ newImportedGlobalName mod occ HiFile `thenRn` \ nm ->
+ returnRn (Right nm)
+ Qual mod occ hif ->
+ newImportedGlobalName mod occ hif `thenRn` \ nm ->
+ returnRn (Right nm)
}
@@ -321,12 +340,28 @@ lookupBndrRn rdr_name
-- deciding which instance declarations to import.
lookupOccRn :: RdrName -> RnMS s Name
lookupOccRn rdr_name
+ = tryLookupOccRn rdr_name `thenRn` \ name_or_error ->
+ case name_or_error of
+ Left (nm, err) -> failWithRn nm err
+ Right nm -> returnRn nm
+
+-- tryLookupOccRn is the fail-safe version of lookupOccRn, returning
+-- back the error rather than immediately flagging it. It is only
+-- directly used by RnExpr.rnExpr to catch and rewrite unbound
+-- uses of `assert'.
+tryLookupOccRn :: RdrName -> RnMS s (Either (Name,ErrMsg) Name)
+tryLookupOccRn rdr_name
= lookupNameRn rdr_name `thenRn` \ maybe_name ->
- lookupRn rdr_name maybe_name `thenRn` \ name ->
- let
+ tryLookupRn rdr_name maybe_name `thenRn` \ name_or_error ->
+ case name_or_error of
+ Left _ -> returnRn name_or_error
+ Right name ->
+ let
name' = mungePrintUnqual rdr_name name
- in
- addOccurrenceName name'
+ in
+ addOccurrenceName name' `thenRn_`
+ returnRn name_or_error
+
-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
-- environment only. It's used for record field names only.
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 4a7bd2283b1856977036d7679b96bf1c7f64b4e9..5d9092b330d5bda6a2c7afc972646dbb52b34960 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -26,11 +26,11 @@ import RnHsSyn
import RnMonad
import RnEnv
import CmdLineOpts ( opt_GlasgowExts )
-import BasicTypes ( Fixity(..), FixityDirection(..) )
+import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
ccallableClass_RDR, creturnableClass_RDR,
monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
- ratioDataCon_RDR, negate_RDR,
+ ratioDataCon_RDR, negate_RDR, assert_RDR,
ioDataCon_RDR, ioOkDataCon_RDR
)
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
@@ -248,10 +248,24 @@ free-var set iff if it's a LocallyDefined Name.
rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
rnExpr (HsVar v)
- = lookupOccRn v `thenRn` \ vname ->
- returnRn (HsVar vname, if isLocallyDefined vname
- then unitNameSet vname
- else emptyUniqSet)
+ = tryLookupOccRn v `thenRn` \ res ->
+ case res of
+ Left (nm,err)
+ | opt_GlasgowExts && v == assertRdrName ->
+ -- if `assert' is not in scope,
+ -- we expand it to (GHCerr.assert__ location)
+ mkAssertExpr `thenRn` \ (expr, assert_name) ->
+ returnRn (expr, unitNameSet assert_name)
+
+ | otherwise -> -- a failure after all.
+ failWithRn nm err `thenRn_`
+ returnRn (HsVar nm, if isLocallyDefined nm
+ then unitNameSet nm
+ else emptyUniqSet)
+ Right vname ->
+ returnRn (HsVar vname, if isLocallyDefined vname
+ then unitNameSet vname
+ else emptyUniqSet)
rnExpr (HsLit lit)
= litOccurrence lit `thenRn_`
@@ -711,6 +725,31 @@ litOccurrence (HsLitLit _)
= lookupImplicitOccRn ccallableClass_RDR
\end{code}
+%************************************************************************
+%* *
+\subsubsection{Assertion utils}
+%* *
+%************************************************************************
+
+\begin{code}
+mkAssertExpr :: RnMS s (RenamedHsExpr, Name)
+mkAssertExpr =
+ newImportedGlobalName mod occ HiFile `thenRn` \ name ->
+ addOccurrenceName name `thenRn_`
+ getSrcLocRn `thenRn` \ sloc ->
+ let
+ expr = HsApp (HsVar name)
+ (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
+ in
+ returnRn (expr, name)
+
+ where
+ mod = rdrNameModule assert_RDR
+ occ = rdrNameOcc assert_RDR
+
+assertRdrName :: RdrName
+assertRdrName = Unqual (VarOcc SLIT("assert"))
+\end{code}
%************************************************************************
%* *