X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsBinds.lhs;h=34ebac65266818375c5b92e01b9f09608a21de64;hb=ab5c070d518a94522477388df9f8817d52296bb6;hp=efdb9e481ab84f3e199d45e12a1c8000508e9097;hpb=203a687fbdb9bf54592f907302d8e47e174bb549;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index efdb9e4..34ebac6 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -15,21 +15,16 @@ import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr,
 			       GRHSs,  pprPatBind )
 
 -- friends:
-import HsImpExp		( pprHsVar )
 import HsPat		( Pat )
 import HsTypes		( HsType )
-import CoreSyn		( CoreExpr )
-import PprCore		( {- instance Outputable (Expr a) -} )
 
 --others:
 import Name		( Name )
-import PrelNames	( isUnboundName )
 import NameSet		( NameSet, elemNameSet, nameSetToList )
-import BasicTypes	( RecFlag(..), FixitySig(..), Activation(..), IPName )
+import BasicTypes	( RecFlag(..), Activation(..), Fixity, IPName )
 import Outputable	
 import SrcLoc		( SrcLoc )
 import Var		( TyVar )
-import Class            ( DefMeth (..) )
 \end{code}
 
 %************************************************************************
@@ -59,8 +54,6 @@ data HsBinds id		-- binders and bindees
   | IPBinds			-- Implcit parameters
 				-- Not allowed at top level
 	[(IPName id, HsExpr id)]
-	Bool		-- True <=> this was a 'with' binding
-			--  (tmp, until 'with' is removed)
 \end{code}
 
 \begin{code}
@@ -69,7 +62,7 @@ nullBinds :: HsBinds id -> Bool
 nullBinds EmptyBinds		= True
 nullBinds (ThenBinds b1 b2)	= nullBinds b1 && nullBinds b2
 nullBinds (MonoBind b _ _)	= nullMonoBinds b
-nullBinds (IPBinds b _)   	= null b
+nullBinds (IPBinds b)   	= null b
 
 mkMonoBind :: RecFlag -> MonoBinds id -> HsBinds id
 mkMonoBind _      EmptyMonoBinds  = EmptyBinds
@@ -84,7 +77,7 @@ ppr_binds EmptyBinds = empty
 ppr_binds (ThenBinds binds1 binds2)
     = ppr_binds binds1 $$ ppr_binds binds2
 
-ppr_binds (IPBinds binds is_with)
+ppr_binds (IPBinds binds)
   = sep (punctuate semi (map pp_item binds))
   where
     pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> pprExpr rhs
@@ -251,12 +244,6 @@ data Sig name
 		(HsType name)
 		SrcLoc
 
-  | ClassOpSig	name		-- Selector name
-                (DefMeth name)	-- Default-method info
-				-- See "THE NAMING STORY" in HsDecls
-		(HsType name)
-		SrcLoc
-
   | SpecSig 	name		-- specialise a function or datatype ...
 		(HsType name)	-- ... to these types
 		SrcLoc
@@ -271,16 +258,17 @@ data Sig name
 		SrcLoc
 
   | FixSig	(FixitySig name)	-- Fixity declaration
+
+data FixitySig name = FixitySig name Fixity SrcLoc 
 \end{code}
 
 \begin{code}
 okBindSig :: NameSet -> Sig Name -> Bool
-okBindSig ns (ClassOpSig _ _ _ _) = False
 okBindSig ns sig		  = sigForThisGroup ns sig
 
-okClsDclSig :: NameSet -> Sig Name -> Bool
-okClsDclSig ns (Sig _ _ _) = False
-okClsDclSig ns sig 	   = sigForThisGroup ns sig
+okClsDclSig :: Sig Name -> Bool
+okClsDclSig (SpecInstSig _ _) = False
+okClsDclSig sig 	      = True	-- All others OK
 
 okInstDclSig :: NameSet -> Sig Name -> Bool
 okInstDclSig ns (Sig _ _ _)	  = False
@@ -288,39 +276,38 @@ okInstDclSig ns (FixSig _)	  = False
 okInstDclSig ns (SpecInstSig _ _) = True
 okInstDclSig ns sig		  = sigForThisGroup ns sig
 
+sigForThisGroup :: NameSet -> Sig Name -> Bool
 sigForThisGroup ns sig 
   = case sigName sig of
-	Nothing 		 -> False
-	Just n | isUnboundName n -> True	-- Don't complain about an unbound name again
-	       | otherwise 	 -> n `elemNameSet` ns
+	Nothing -> False
+	Just n  -> n `elemNameSet` ns
 
 sigName :: Sig name -> Maybe name
 sigName (Sig         n _ _)        = Just n
-sigName (ClassOpSig  n _ _ _)      = Just n
 sigName (SpecSig     n _ _)        = Just n
 sigName (InlineSig _ n _ _)        = Just n
 sigName (FixSig (FixitySig n _ _)) = Just n
 sigName other			   = Nothing
 
+sigLoc :: Sig name -> SrcLoc
+sigLoc (Sig         _ _ loc)        = loc
+sigLoc (SpecSig     _ _ loc)        = loc
+sigLoc (InlineSig _ _ _ loc)        = loc
+sigLoc (FixSig (FixitySig n _ loc)) = loc
+sigLoc (SpecInstSig _ loc)	    = loc
+
 isFixitySig :: Sig name -> Bool
 isFixitySig (FixSig _) = True
 isFixitySig _	       = False
 
-isClassOpSig :: Sig name -> Bool
-isClassOpSig (ClassOpSig _ _ _ _) = True
-isClassOpSig _			  = False
-
 isPragSig :: Sig name -> Bool
 	-- Identifies pragmas 
 isPragSig (SpecSig _ _ _)     = True
 isPragSig (InlineSig _ _ _ _) = True
 isPragSig (SpecInstSig _ _)   = True
 isPragSig other		      = False
-\end{code}
 
-\begin{code}
 hsSigDoc (Sig        _ _ loc) 	      = (ptext SLIT("type signature"),loc)
-hsSigDoc (ClassOpSig _ _ _ loc)       = (ptext SLIT("class-method type signature"), loc)
 hsSigDoc (SpecSig    _ _ loc) 	      = (ptext SLIT("SPECIALISE pragma"),loc)
 hsSigDoc (InlineSig True  _ _ loc)    = (ptext SLIT("INLINE pragma"),loc)
 hsSigDoc (InlineSig False _ _ loc)    = (ptext SLIT("NOINLINE pragma"),loc)
@@ -328,6 +315,19 @@ hsSigDoc (SpecInstSig _ loc)	      = (ptext SLIT("SPECIALISE instance pragma"),l
 hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext SLIT("fixity declaration"), loc)
 \end{code}
 
+Signature equality is used when checking for duplicate signatures
+
+\begin{code}
+eqHsSig :: Sig Name -> Sig Name -> Bool
+eqHsSig (FixSig (FixitySig n1 _ _)) (FixSig (FixitySig n2 _ _)) = n1 == n2
+eqHsSig (Sig n1 _ _)         	    (Sig n2 _ _)          	= n1 == n2
+eqHsSig (InlineSig b1 n1 _ _)	    (InlineSig b2 n2 _ _) 	= b1 == b2 && n1 == n2
+ 	-- For specialisations, we don't have equality over
+	-- HsType, so it's not convenient to spot duplicate 
+	-- specialisations here.  Check for this later, when we're in Type land
+eqHsSig _other1 _other2 = False
+\end{code}
+
 \begin{code}
 instance (Outputable name) => Outputable (Sig name) where
     ppr sig = ppr_sig sig
@@ -336,20 +336,6 @@ ppr_sig :: Outputable name => Sig name -> SDoc
 ppr_sig (Sig var ty _)
       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 
-ppr_sig (ClassOpSig var dm ty _)
-      = sep [ pprHsVar var <+> dcolon, 
-	      nest 4 (ppr ty),
-	      nest 4 (pp_dm_comment) ]
-      where
-	pp_dm = case dm of 
-		  DefMeth _  -> equals 	-- Default method indicator
-		  GenDefMeth -> semi    -- Generic method indicator
-		  NoDefMeth  -> empty   -- No Method at all
-	pp_dm_comment = case dm of 
-		  DefMeth _  -> text "{- has default method -}"
-		  GenDefMeth -> text "{- has generic method -}"
-		  NoDefMeth  -> empty   -- No Method at all
-
 ppr_sig (SpecSig var ty _)
       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 	      nest 4 (ppr ty <+> text "#-}")
@@ -365,21 +351,7 @@ ppr_sig (SpecInstSig ty _)
       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 
 ppr_sig (FixSig fix_sig) = ppr fix_sig
-\end{code}
-
-Checking for distinct signatures; oh, so boring
-
 
-\begin{code}
-eqHsSig :: Sig Name -> Sig Name -> Bool
-eqHsSig (Sig n1 _ _)         (Sig n2 _ _)          = n1 == n2
-eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
-
-eqHsSig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = ty1 == ty2
-eqHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _)   =
-    -- may have many specialisations for one value;
-    -- but not ones that are exactly the same...
-    (n1 == n2) && (ty1 == ty2)
-
-eqHsSig _other1 _other2 = False
+instance Outputable name => Outputable (FixitySig name) where
+  ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
 \end{code}