[project @ 1996-05-17 16:02:43 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 9c8ab0d..c80f351 100644 (file)
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -12,32 +12,35 @@ import Ubiq
 
 import HsSyn
 
-import Name            ( isLocalName, nameUnique, Name, RdrName )
-import Id              ( GenId, Id(..) )
-import Outputable      ( Outputable(..) )
-import PprType         ( GenType, GenTyVar, TyCon )
+import Id              ( isDataCon, GenId, Id(..) )
+import Name            ( isLocalName, nameUnique, Name, RdrName(..){-ToDo: rm ..-},
+                         mkLocalName{-ToDo:rm-}
+                       )
+import Outputable      ( Outputable(..){-instance * []-} )
 import PprStyle                ( PprStyle(..) )
+import PprType         ( GenType, GenTyVar, TyCon )
 import Pretty
 import TyCon           ( TyCon )
 import TyVar           ( GenTyVar )
-import Unique          ( Unique )
-import Util            ( panic, pprPanic )
+import Unique          ( mkAlphaTyVarUnique, Unique )
+import Util            ( panic, pprPanic, pprTrace{-ToDo:rm-} )
 \end{code}
 
 \begin{code}
 data RnName
   = WiredInId       Id
   | WiredInTyCon    TyCon
-  | RnName          Name        -- funtions/binders/tyvars
-  | RnSyn           Name        -- type synonym
-  | RnData          Name [Name] -- data type   (with constrs)
-  | RnConstr        Name  Name  -- constructor (with data type)
-  | RnClass         Name [Name] -- class       (with class ops)
-  | RnClassOp       Name  Name  -- class op    (with class)
-  | RnImplicit      Name       -- implicitly imported
-  | RnImplicitTyCon Name       -- implicitly imported
-  | RnImplicitClass Name       -- implicitly imported
-  | RnUnbound      RdrName     -- place holder
+  | RnName          Name               -- functions/binders/tyvars
+  | RnSyn           Name               -- type synonym
+  | RnData          Name [Name] [Name] -- data type   (with constrs and fields)
+  | RnConstr        Name  Name         -- constructor (with data type)
+  | RnField        Name  Name          -- field       (with data type)
+  | RnClass         Name [Name]        -- class       (with class ops)
+  | RnClassOp       Name  Name         -- class op    (with class)
+  | RnImplicit      Name               -- implicitly imported
+  | RnImplicitTyCon Name               -- implicitly imported
+  | RnImplicitClass Name               -- implicitly imported
+  | RnUnbound      RdrName             -- place holder
 
 mkRnName          = RnName
 mkRnImplicit      = RnImplicit
@@ -52,10 +55,9 @@ isRnWired _             = False
 isRnLocal (RnName n) = isLocalName n
 isRnLocal _         = False
 
-
 isRnTyCon (WiredInTyCon _)    = True
 isRnTyCon (RnSyn _)                  = True
-isRnTyCon (RnData _ _)               = True
+isRnTyCon (RnData _ _ _)      = True
 isRnTyCon (RnImplicitTyCon _) = True
 isRnTyCon _                          = False
 
@@ -63,8 +65,23 @@ isRnClass (RnClass _ _)       = True
 isRnClass (RnImplicitClass _) = True
 isRnClass _                   = False
 
+-- a common need: isRnTyCon || isRnClass:
+isRnTyConOrClass (WiredInTyCon _)    = True
+isRnTyConOrClass (RnSyn _)          = True
+isRnTyConOrClass (RnData _ _ _)             = True
+isRnTyConOrClass (RnImplicitTyCon _) = True
+isRnTyConOrClass (RnClass _ _)       = True
+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 (RnImplicit _)      = True     -- ho hummm ...
 isRnClassOp cls _                   = False
 
 isRnImplicit (RnImplicit _)      = True
@@ -91,23 +108,32 @@ instance Uniquable RnName where
     uniqueOf = nameUnique . getName
 
 instance NamedThing RnName where
-    getName (WiredInId id)    = getName id
-    getName (WiredInTyCon tc) = getName tc
-    getName (RnName n)       = n
-    getName (RnSyn n)        = n
-    getName (RnData n _)      = n
-    getName (RnConstr n _)    = n
-    getName (RnClass n _)     = n
-    getName (RnClassOp n _)   = n
-    getName (RnImplicit n)    = n
-    getName (RnUnbound occ)   = pprPanic "getRnName:RnUnbound" (ppr PprDebug occ)
+    getName (WiredInId id)      = getName id
+    getName (WiredInTyCon tc)   = getName tc
+    getName (RnName n)         = n
+    getName (RnSyn n)          = n
+    getName (RnData n _ _)      = n
+    getName (RnConstr n _)      = n
+    getName (RnField n _)       = n
+    getName (RnClass n _)       = n
+    getName (RnClassOp n _)     = n
+    getName (RnImplicit n)      = n
+    getName (RnImplicitTyCon n) = n
+    getName (RnImplicitClass n) = n
+    getName (RnUnbound occ)     = pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ)
+                                 (case occ of
+                                    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"
 
 instance Outputable RnName where
 #ifdef DEBUG
-    ppr sty@PprShowAll (RnData n cs)   = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppStr "-}"]
-    ppr sty@PprShowAll (RnConstr n d)  = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
-    ppr sty@PprShowAll (RnClass n ops) = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"]
-    ppr sty@PprShowAll (RnClassOp n c) = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"]
+    ppr sty@PprShowAll (RnData n cs fs)  = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppr sty fs, ppStr "-}"]
+    ppr sty@PprShowAll (RnConstr n d)    = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
+    ppr sty@PprShowAll (RnField  n d)    = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
+    ppr sty@PprShowAll (RnClass n ops)   = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"]
+    ppr sty@PprShowAll (RnClassOp n c)   = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"]
 #endif
     ppr sty (WiredInId id)      = ppr sty id
     ppr sty (WiredInTyCon tycon)= ppr sty tycon
@@ -159,5 +185,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}