X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsBinds.lhs;h=4050a2e275f43a09bba56ad476b7253cc312670e;hb=2c6d73e2ca9a545c4295c6f532cd3612e7fd3d8d;hp=bcc9133cb307b97ffde1c2bf73354bd13bd6aae2;hpb=f9120c200bcf613b58d742802172fb4c08171f0d;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index bcc9133..4050a2e 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -1,31 +1,33 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
 
 Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.
 
 \begin{code}
-#include "HsVersions.h"
-
 module HsBinds where
 
-import Ubiq
+#include "HsVersions.h"
+
+import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr,
+			       Match,  pprFunBind,
+			       GRHSs,  pprPatBind )
 
 -- friends:
-import HsLoop
-import HsMatches	( pprMatches, pprGRHSsAndBinds,
-			  Match, GRHSsAndBinds )
-import HsPat		( collectPatBinders, InPat )
-import HsPragmas	( GenPragmas, ClassOpPragmas )
-import HsTypes		( PolyType )
+import HsTypes		( HsType )
+import CoreSyn		( CoreExpr )
+import PprCore		( {- instance Outputable (Expr a) -} )
 
 --others:
-import Id		( DictVar(..), Id(..), GenId )
-import Outputable
-import Pretty
-import SrcLoc		( SrcLoc{-instances-} )
---import TyVar		( GenTyVar{-instances-} )
+import Name		( Name )
+import PrelNames	( isUnboundName )
+import NameSet		( NameSet, elemNameSet, nameSetToList )
+import BasicTypes	( RecFlag(..), Fixity )
+import Outputable	
+import SrcLoc		( SrcLoc )
+import Var		( TyVar )
+import Class            ( DefMeth (..) )
 \end{code}
 
 %************************************************************************
@@ -43,26 +45,90 @@ grammar.
 Collections of bindings, created by dependency analysis and translation:
 
 \begin{code}
-data HsBinds tyvar uvar id pat		-- binders and bindees
+data HsBinds id pat		-- binders and bindees
   = EmptyBinds
 
-  | ThenBinds	(HsBinds tyvar uvar id pat)
-		(HsBinds tyvar uvar id pat)
+  | ThenBinds	(HsBinds id pat)
+		(HsBinds id pat)
+
+  | MonoBind 	(MonoBinds id pat)
+		[Sig id]		-- Empty on typechecker output
+		RecFlag
+\end{code}
+
+\begin{code}
+nullBinds :: HsBinds id pat -> Bool
+
+nullBinds EmptyBinds		= True
+nullBinds (ThenBinds b1 b2)	= nullBinds b1 && nullBinds b2
+nullBinds (MonoBind b _ _)	= nullMonoBinds b
+
+mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
+mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
+mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
+\end{code}
+
+\begin{code}
+instance (Outputable pat, Outputable id) =>
+		Outputable (HsBinds id pat) where
+    ppr binds = ppr_binds binds
+
+ppr_binds EmptyBinds = empty
+ppr_binds (ThenBinds binds1 binds2)
+    = ppr_binds binds1 $$ ppr_binds binds2
+ppr_binds (MonoBind bind sigs is_rec)
+     = vcat [ppr_isrec,
+     	     vcat (map ppr sigs),
+	     ppr bind
+       ]
+     where
+       ppr_isrec = getPprStyle $ \ sty -> 
+		   if userStyle sty then empty else
+		   case is_rec of
+		   	Recursive    -> ptext SLIT("{- rec -}")
+			NonRecursive -> ptext SLIT("{- nonrec -}")
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Bindings: @MonoBinds@}
+%*									*
+%************************************************************************
+
+Global bindings (where clauses)
+
+\begin{code}
+data MonoBinds id pat
+  = EmptyMonoBinds
 
-  | SingleBind	(Bind  tyvar uvar id pat)
+  | AndMonoBinds    (MonoBinds id pat)
+		    (MonoBinds id pat)
 
-  | BindWith		-- Bind with a type signature.
-			-- These appear only on typechecker input
-			-- (PolyType [in Sigs] can't appear on output)
-		(Bind tyvar uvar id pat)
-		[Sig id]
+  | FunMonoBind     id		-- Used for both functions 	f x = e
+				-- and variables		f = \x -> e
+				-- Reason: the Match stuff lets us have an optional
+				--	   result type sig	f :: a->a = ...mentions a...
+		    Bool		-- True => infix declaration
+		    [Match id pat]
+		    SrcLoc
+
+  | PatMonoBind     pat		-- The pattern is never a simple variable;
+				-- That case is done by FunMonoBind
+		    (GRHSs id pat)
+		    SrcLoc
+
+  | VarMonoBind	    id			-- TRANSLATION
+		    (HsExpr id pat)
 
-  | AbsBinds			-- Binds abstraction; TRANSLATION
-		[tyvar]
-		[id]		-- Dicts
-		[(id, id)]	-- (old, new) pairs
-		[(id, HsExpr tyvar uvar id pat)]	-- local dictionaries
-		(Bind tyvar uvar id pat)		-- "the business end"
+  | CoreMonoBind    id			-- TRANSLATION
+		    CoreExpr		-- No zonking; this is a final CoreExpr with Ids and Types!
+
+  | AbsBinds				-- Binds abstraction; TRANSLATION
+		[TyVar]	  		-- Type variables
+		[id]			-- Dicts
+		[([TyVar], id, id)]	-- (type variables, polymorphic, momonmorphic) triples
+		NameSet			-- Set of *polymorphic* variables that have an INLINE pragma
+		(MonoBinds id pat)      -- The "business end"
 
 	-- Creates bindings for *new* (polymorphic, overloaded) locals
 	-- in terms of *old* (monomorphic, non-overloaded) ones.
@@ -72,36 +138,87 @@ data HsBinds tyvar uvar id pat		-- binders and bindees
 	--  of this last construct.)
 \end{code}
 
+What AbsBinds means
+~~~~~~~~~~~~~~~~~~~
+	 AbsBinds tvs
+		  [d1,d2]
+		  [(tvs1, f1p, f1m), 
+		   (tvs2, f2p, f2m)]
+		  BIND
+means
+
+	f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND 
+				      in fm
+
+	gp = ...same again, with gm instead of fm
+
+This is a pretty bad translation, because it duplicates all the bindings.
+So the desugarer tries to do a better job:
+
+	fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
+					(fm,gm) -> fm
+	..ditto for gp..
+
+	p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND 
+				      in (fm,gm)
+
 \begin{code}
-nullBinds :: HsBinds tyvar uvar id pat -> Bool
+-- We keep the invariant that a MonoBinds is only empty 
+-- if it is exactly EmptyMonoBinds
 
-nullBinds EmptyBinds		= True
-nullBinds (ThenBinds b1 b2)	= nullBinds b1 && nullBinds b2
-nullBinds (SingleBind b)	= nullBind b
-nullBinds (BindWith b _)	= nullBind b
-nullBinds (AbsBinds _ _ _ ds b)	= null ds && nullBind b
+nullMonoBinds :: MonoBinds id pat -> Bool
+nullMonoBinds EmptyMonoBinds	     = True
+nullMonoBinds other_monobind	     = False
+
+andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
+andMonoBinds EmptyMonoBinds mb = mb
+andMonoBinds mb EmptyMonoBinds = mb
+andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
+
+andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
+andMonoBindList binds
+  = loop1 binds
+  where
+    loop1 [] = EmptyMonoBinds
+    loop1 (EmptyMonoBinds : binds) = loop1 binds
+    loop1 (b:bs) = loop2 b bs
+
+	-- acc is non-empty
+    loop2 acc [] = acc
+    loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
+    loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
 \end{code}
 
+
 \begin{code}
-instance (Outputable pat, NamedThing id, Outputable id,
-	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
-		Outputable (HsBinds tyvar uvar id pat) where
-
-    ppr sty EmptyBinds = ppNil
-    ppr sty (ThenBinds binds1 binds2)
-     = ppAbove (ppr sty binds1) (ppr sty binds2)
-    ppr sty (SingleBind bind) = ppr sty bind
-    ppr sty (BindWith bind sigs)
-     = ppAbove (if null sigs 
-		then ppNil
-		else ppAboves (map (ppr sty) sigs))
-	       (ppr sty bind)
-    ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
-     = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
-		      ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
-		      ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
-		      ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
-	    (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
+instance (Outputable id, Outputable pat) =>
+		Outputable (MonoBinds id pat) where
+    ppr mbind = ppr_monobind mbind
+
+
+ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
+ppr_monobind EmptyMonoBinds = empty
+ppr_monobind (AndMonoBinds binds1 binds2)
+      = ppr_monobind binds1 $$ ppr_monobind binds2
+
+ppr_monobind (PatMonoBind pat grhss locn)	= pprPatBind pat grhss
+ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
+      -- ToDo: print infix if appropriate
+
+ppr_monobind (VarMonoBind name expr)
+      = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
+
+ppr_monobind (CoreMonoBind name expr)
+      = sep [ppr name <+> equals, nest 4 (ppr expr)]
+
+ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
+     = sep [ptext SLIT("AbsBinds"),
+	    brackets (interpp'SP tyvars),
+	    brackets (interpp'SP dictvars),
+	    brackets (sep (punctuate comma (map ppr exports))),
+	    brackets (interpp'SP (nameSetToList inlines))]
+       $$
+       nest 4 (ppr val_binds)
 \end{code}
 
 %************************************************************************
@@ -118,211 +235,152 @@ serves for both.
 \begin{code}
 data Sig name
   = Sig		name		-- a bog-std type signature
-		(PolyType name)
-		(GenPragmas name) -- only interface ones have pragmas
+		(HsType name)
 		SrcLoc
 
-  | ClassOpSig	name		-- class-op sigs have different pragmas
-		(PolyType name)
-		(ClassOpPragmas name)	-- only interface ones have pragmas
+  | 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 ...
-		(PolyType name) -- ... to these types
-		(Maybe name)	-- ... maybe using this as the code for it
+		(HsType name)	-- ... to these types
 		SrcLoc
 
-  | InlineSig	name		  -- INLINE f
+  | InlineSig	name		-- INLINE f
+	 	(Maybe Int)	-- phase
 		SrcLoc
 
-  -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER
-  | DeforestSig name            -- Deforest using this function definition
-	      	SrcLoc
+  | NoInlineSig	name		-- NOINLINE f
+	 	(Maybe Int)	-- phase
+		SrcLoc
 
-  | MagicUnfoldingSig
-		name		-- Associate the "name"d function with
-		FAST_STRING	-- the compiler-builtin unfolding (known
-		SrcLoc		-- by the String name)
-\end{code}
+  | SpecInstSig (HsType name)	-- (Class tys); should be a specialisation of the 
+				-- current instance decl
+		SrcLoc
 
-\begin{code}
-instance (NamedThing name, Outputable name) => Outputable (Sig name) where
-    ppr sty (Sig var ty pragmas _)
-      = ppHang (ppCat [pprNonOp sty var, ppPStr SLIT("::")])
-	     4 (ppHang (ppr sty ty)
-		     4 (ifnotPprForUser sty (ppr sty pragmas)))
-
-    ppr sty (ClassOpSig var ty pragmas _)
-      = ppHang (ppCat [pprNonOp sty var, ppPStr SLIT("::")])
-	     4 (ppHang (ppr sty ty)
-		     4 (ifnotPprForUser sty (ppr sty pragmas)))
-
-    ppr sty (DeforestSig var _)
-      = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonOp sty var])
-		   4 (ppStr "#-}")
-
-    ppr sty (SpecSig var ty using _)
-      = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonOp sty var, ppPStr SLIT("::")])
-	     4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")])
-      where
-	pp_using Nothing   = ppNil
-	pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
+  | FixSig	(FixitySig name)	-- Fixity declaration
 
-    ppr sty (InlineSig var _)
-      = ppCat [ppPStr SLIT("{-# INLINE"), pprNonOp sty var, ppPStr SLIT("#-}")]
 
-    ppr sty (MagicUnfoldingSig var str _)
-      = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonOp sty var, ppPStr str, ppPStr SLIT("#-}")]
-\end{code}
+data FixitySig name = FixitySig name Fixity SrcLoc 
 
-%************************************************************************
-%*									*
-\subsection{Binding: @Bind@}
-%*									*
-%************************************************************************
-
-\begin{code}
-data Bind tyvar uvar id pat		-- binders and bindees
-  = EmptyBind	-- because it's convenient when parsing signatures
-  | NonRecBind	(MonoBinds tyvar uvar id pat)
-  | RecBind	(MonoBinds tyvar uvar id pat)
+instance Eq name => Eq (FixitySig name) where
+   (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
 \end{code}
 
 \begin{code}
-nullBind :: Bind tyvar uvar id pat -> Bool
-
-nullBind EmptyBind	 = True
-nullBind (NonRecBind bs) = nullMonoBinds bs
-nullBind (RecBind bs)	 = nullMonoBinds bs
+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
+
+okInstDclSig :: NameSet -> Sig Name -> Bool
+okInstDclSig ns (Sig _ _ _)					   = False
+okInstDclSig ns (FixSig _)					   = False
+okInstDclSig ns (SpecInstSig _ _)				   = True
+okInstDclSig ns sig = sigForThisGroup ns sig
+
+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
+
+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 (NoInlineSig n _   _)           = Just n
+sigName (FixSig (FixitySig n _ _))      = Just n
+sigName other				= Nothing
+
+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 (NoInlineSig _ _ _) = True
+isPragSig (SpecInstSig _ _)   = True
+isPragSig other		      = False
 \end{code}
 
 \begin{code}
-bindIsRecursive :: Bind tyvar uvar id pat -> Bool
-
-bindIsRecursive EmptyBind	= False
-bindIsRecursive (NonRecBind _)	= False
-bindIsRecursive (RecBind _)	= True
+hsSigDoc (Sig        _ _ loc) 	      = (SLIT("type signature"),loc)
+hsSigDoc (ClassOpSig _ _ _ loc)       = (SLIT("class-method type signature"), loc)
+hsSigDoc (SpecSig    _ _ loc) 	      = (SLIT("SPECIALISE pragma"),loc)
+hsSigDoc (InlineSig  _ _    loc)      = (SLIT("INLINE pragma"),loc)
+hsSigDoc (NoInlineSig  _ _  loc)      = (SLIT("NOINLINE pragma"),loc)
+hsSigDoc (SpecInstSig _ loc)	      = (SLIT("SPECIALISE instance pragma"),loc)
+hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
 \end{code}
 
 \begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
-	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
-		Outputable (Bind tyvar uvar id pat) where
-    ppr sty EmptyBind = ppNil
-    ppr sty (NonRecBind binds)
-     = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}"))
-	       (ppr sty binds)
-    ppr sty (RecBind binds)
-     = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}"))
-	       (ppr sty binds)
-\end{code}
+instance (Outputable name) => Outputable (Sig name) where
+    ppr sig = ppr_sig sig
 
-%************************************************************************
-%*									*
-\subsection{Bindings: @MonoBinds@}
-%*									*
-%************************************************************************
+ppr_sig :: Outputable name => Sig name -> SDoc
+ppr_sig (Sig var ty _)
+      = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 
-Global bindings (where clauses)
+ppr_sig (ClassOpSig var dm ty _)
+      = sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
+      where
+	pp_dm = case dm of 
+		  DefMeth _  -> equals 	-- Default method indicator
+		  GenDefMeth -> semi    -- Generic method indicator
+		  NoDefMeth  -> empty   -- No Method at all
 
-\begin{code}
-data MonoBinds tyvar uvar id pat
-  = EmptyMonoBinds
-  | AndMonoBinds    (MonoBinds tyvar uvar id pat)
-		    (MonoBinds tyvar uvar id pat)
-  | PatMonoBind     pat
-		    (GRHSsAndBinds tyvar uvar id pat)
-		    SrcLoc
-  | FunMonoBind     id
-		    [Match tyvar uvar id pat]	-- must have at least one Match
-		    SrcLoc
-  | VarMonoBind	    id			-- TRANSLATION
-		    (HsExpr tyvar uvar id pat)
-\end{code}
+ppr_sig (SpecSig var ty _)
+      = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
+	      nest 4 (ppr ty <+> text "#-}")
+	]
 
-\begin{code}
-nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
+ppr_sig (InlineSig var phase _)
+      = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
 
-nullMonoBinds EmptyMonoBinds	     = True
-nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
-nullMonoBinds other_monobind	     = False
-\end{code}
+ppr_sig (NoInlineSig var phase _)
+      = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
 
-\begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
-	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
-		Outputable (MonoBinds tyvar uvar id pat) where
-    ppr sty EmptyMonoBinds = ppNil
-    ppr sty (AndMonoBinds binds1 binds2)
-      = ppAbove (ppr sty binds1) (ppr sty binds2)
+ppr_sig (SpecInstSig ty _)
+      = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 
-    ppr sty (PatMonoBind pat grhss_n_binds locn)
-      = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
+ppr_sig (FixSig fix_sig) = ppr fix_sig
 
-    ppr sty (FunMonoBind fun matches locn)
-      = pprMatches sty (False, pprNonOp sty fun) matches
 
-    ppr sty (VarMonoBind name expr)
-      = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr)
+instance Outputable name => Outputable (FixitySig name) where
+  ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
+
+ppr_phase :: Maybe Int -> SDoc
+ppr_phase Nothing  = empty
+ppr_phase (Just n) = int n
 \end{code}
 
-%************************************************************************
-%*									*
-\subsection{Collecting binders from @HsBinds@}
-%*									*
-%************************************************************************
+Checking for distinct signatures; oh, so boring
 
-Get all the binders in some @MonoBinds@, IN THE ORDER OF
-APPEARANCE; e.g., in:
-\begin{verbatim}
-...
-where
-  (x, y) = ...
-  f i j  = ...
-  [a, b] = ...
-\end{verbatim}
-it should return @[x, y, f, a, b]@ (remember, order important).
 
 \begin{code}
-collectTopLevelBinders :: HsBinds tyvar uvar name (InPat name) -> [name]
-collectTopLevelBinders EmptyBinds     = []
-collectTopLevelBinders (SingleBind b) = collectBinders b
-collectTopLevelBinders (BindWith b _) = collectBinders b
-collectTopLevelBinders (ThenBinds b1 b2)
- = collectTopLevelBinders b1 ++ collectTopLevelBinders b2
-
-collectBinders :: Bind tyvar uvar name (InPat name) -> [name]
-collectBinders EmptyBind 	      = []
-collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
-collectBinders (RecBind monobinds)    = collectMonoBinders monobinds
-
-collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name]
-collectMonoBinders EmptyMonoBinds		     = []
-collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat
-collectMonoBinders (FunMonoBind f matches _)	     = [f]
-collectMonoBinders (VarMonoBind v expr) 	     = error "collectMonoBinders"
-collectMonoBinders (AndMonoBinds bs1 bs2)
- = collectMonoBinders bs1 ++ collectMonoBinders bs2
-
--- We'd like the binders -- and where they came from --
--- so we can make new ones with equally-useful origin info.
-
-collectMonoBindersAndLocs
-	:: MonoBinds tyvar uvar name (InPat name) -> [(name, SrcLoc)]
-
-collectMonoBindersAndLocs EmptyMonoBinds = []
-
-collectMonoBindersAndLocs (AndMonoBinds bs1 bs2)
-  = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2
-
-collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn)
-  = collectPatBinders pat `zip` repeat locn
-
-collectMonoBindersAndLocs (FunMonoBind f matches locn) = [(f, locn)]
-
-#ifdef DEBUG
-collectMonoBindersAndLocs (VarMonoBind v expr)
-  = trace "collectMonoBindersAndLocs:VarMonoBind" []
-	-- ToDo: this is dubious, i.e., wrong, but harmless?
-#endif
+eqHsSig :: Sig Name -> Sig Name -> Bool
+eqHsSig (Sig n1 _ _)         (Sig n2 _ _)         = n1 == n2
+eqHsSig (InlineSig n1 _ _)   (InlineSig n2 _ _)   = n1 == n2
+eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = 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
 \end{code}