qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual,
dummyRdrVarName, dummyRdrTcName,
isUnqual, isQual,
- showRdr, rdrNameOcc, ieOcc,
+ showRdr, rdrNameOcc, rdrNameModule, ieOcc,
cmpRdr, prefixRdrName,
mkOpApp, mkClassDecl
dummyRdrVarName = Unqual (VarOcc SLIT("V-DUMMY"))
dummyRdrTcName = Unqual (VarOcc SLIT("TC-DUMMY"))
+
varUnqual n = Unqual (VarOcc n)
isUnqual (Unqual _) = True
rdrNameOcc (Unqual occ) = occ
rdrNameOcc (Qual _ occ _) = occ
+rdrNameModule :: RdrName -> Module
+rdrNameModule (Qual m _ _) = m
+
ieOcc :: RdrNameIE -> OccName
ieOcc ie = rdrNameOcc (ieName ie)
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,
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 _ _ ->
-- 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)
}
-- 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.
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,
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_`
= 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}
%************************************************************************
%* *
projects / ghc-hetmet.git / commitdiff