[project @ 1998-04-07 16:40:08 by simonpj]

[ghc-hetmet.git] / ghc / compiler / rename / RnExpr.lhs

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 165555e..87ac92d 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -26,22 +26,20 @@ 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, assertErr_RDR,
                          ioDataCon_RDR, ioOkDataCon_RDR
                        )
 import TysPrim         ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
                          floatPrimTyCon, doublePrimTyCon
                        )
 import Name
-import UniqFM          ( lookupUFM, {- ToDo:rm-} isNullUFM )
-import UniqSet         ( emptyUniqSet, unitUniqSet,
-                         unionUniqSets, unionManyUniqSets,
-                         UniqSet
-                       )
+import UniqFM          ( isNullUFM )
+import UniqSet         ( emptyUniqSet, unionManyUniqSets, UniqSet )
+import Unique          ( assertIdKey )
 import Util            ( removeDups )
 import Outputable
 \end{code}
@@ -251,10 +249,16 @@ 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)
+  = lookupOccRn v      `thenRn` \ name ->
+    if nameUnique name == assertIdKey then
+       -- We expand it to (GHCerr.assert__ location)
+        mkAssertExpr  `thenRn` \ expr ->
+       returnRn (expr, emptyUniqSet)
+    else
+        -- The normal case
+       returnRn (HsVar name, if isLocallyDefined name
+                            then unitNameSet name
+                            else emptyUniqSet)
 
 rnExpr (HsLit lit) 
   = litOccurrence lit          `thenRn_`
@@ -714,6 +718,28 @@ litOccurrence (HsLitLit _)
   = lookupImplicitOccRn ccallableClass_RDR
 \end{code}
 
+%************************************************************************
+%*                                                                     *
+\subsubsection{Assertion utils}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+mkAssertExpr :: RnMS s RenamedHsExpr
+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
+
+  where
+   mod = rdrNameModule assertErr_RDR
+   occ = rdrNameOcc assertErr_RDR
+\end{code}
 
 %************************************************************************
 %*                                                                     *