[project @ 1996-07-25 20:43:49 by partain]

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

diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 4e1f517..db994b1 100644 (file)
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -8,13 +8,13 @@
 
 module RnHsSyn where
 
-import Ubiq
+IMP_Ubiq()
 
 import HsSyn
 
-import Id              ( GenId, Id(..) )
-import Name            ( isLocalName, nameUnique, Name, RdrName(..){-ToDo: rm ..-},
-                         mkLocalName{-ToDo:rm-}
+import Id              ( isDataCon, GenId, SYN_IE(Id) )
+import Name            ( isLocalName, nameUnique, Name, RdrName(..),
+                         mkLocalName
                        )
 import Outputable      ( Outputable(..){-instance * []-} )
 import PprStyle                ( PprStyle(..) )
@@ -23,7 +23,7 @@ import Pretty
 import TyCon           ( TyCon )
 import TyVar           ( GenTyVar )
 import Unique          ( mkAlphaTyVarUnique, Unique )
-import Util            ( panic, pprPanic, pprTrace{-ToDo:rm-} )
+import Util            ( panic, pprPanic{-, pprTrace ToDo:rm-} )
 \end{code}
 
 \begin{code}
@@ -75,13 +75,14 @@ isRnTyConOrClass (RnImplicitClass _) = True
 isRnTyConOrClass _                   = False
 
 isRnConstr (RnConstr _ _) = True
+isRnConstr (WiredInId id) = isDataCon id
 isRnConstr  _            = False
 
 isRnField  (RnField _ _)  = True
 isRnField  _             = False
 
 isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
-isRnClassOp cls _                   = False
+isRnClassOp cls n                   = True -- pprTrace "isRnClassOp:" (ppr PprShowAll n) $ True -- let it past anyway
 
 isRnImplicit (RnImplicit _)      = True
 isRnImplicit (RnImplicitTyCon _) = True
@@ -91,6 +92,14 @@ isRnImplicit _                        = False
 isRnUnbound (RnUnbound _) = True
 isRnUnbound _            = False
 
+isRnEntity (WiredInId _)       = True
+isRnEntity (WiredInTyCon _)    = True
+isRnEntity (RnName n)         = not (isLocalName n)
+isRnEntity (RnSyn _)           = True
+isRnEntity (RnData _ _ _)      = True
+isRnEntity (RnClass _ _)       = True
+isRnEntity _                   = False
+
 -- Very general NamedThing comparison, used when comparing
 -- Uniquable things with different types
 
@@ -119,10 +128,10 @@ instance NamedThing RnName where
     getName (RnImplicit n)      = n
     getName (RnImplicitTyCon n) = n
     getName (RnImplicitClass n) = n
-    getName (RnUnbound occ)     = pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ)
+    getName (RnUnbound occ)     = --pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ)
                                  (case occ of
-                                    Unqual n -> mkLocalName bottom n bottom2
-                                    Qual m n -> mkLocalName bottom n bottom2)
+                                    Unqual n -> mkLocalName bottom n False bottom2
+                                    Qual m n -> mkLocalName bottom n False bottom2)
                                where bottom = mkAlphaTyVarUnique 0 -- anything; just something that will print
                                      bottom2 = panic "getRnName: srcloc"
 
@@ -162,7 +171,7 @@ type RenamedMonoType                = MonoType              RnName
 type RenamedPat                        = InPat                 RnName
 type RenamedPolyType           = PolyType              RnName
 type RenamedRecordBinds                = HsRecordBinds         Fake Fake RnName RenamedPat
-type RenamedQual               = Qual                  Fake Fake RnName RenamedPat
+type RenamedQual               = Qualifier             Fake Fake RnName RenamedPat
 type RenamedSig                        = Sig                   RnName
 type RenamedSpecInstSig                = SpecInstSig           RnName
 type RenamedStmt               = Stmt                  Fake Fake RnName RenamedPat
@@ -184,5 +193,10 @@ collectQualBinders quals
     collect (GeneratorQual pat _) = collectPatBinders pat
     collect (FilterQual expr)    = []
     collect (LetQual    binds)   = collectTopLevelBinders binds
+
+fixDeclName :: FixityDecl name -> name
+fixDeclName (InfixL name i) = name
+fixDeclName (InfixR name i) = name
+fixDeclName (InfixN name i) = name
 \end{code}