X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FFamInst.lhs;h=41f22bed2639b4a2b484eba0468344f3dfaa4c96;hb=311b1cdfc9b1c311cc53482c461c18cba8885b2a;hp=e38a3b13b8a35d7a12f13ba71dbcdc36ef0fd8dc;hpb=2a8cdc3aee5997374273e27365f92c161aca8453;p=ghc-hetmet.git

diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index e38a3b1..41f22be 100644
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -1,4 +1,4 @@
-\section[FamInst]{The @FamInst@ type: family instance heads}
+The @FamInst@ type: family instance heads
 
 \begin{code}
 module FamInst ( 
@@ -7,18 +7,18 @@ module FamInst (
 
 #include "HsVersions.h"
 
-import HscTypes   ( ExternalPackageState(..) )
-import FamInstEnv ( FamInstEnv, FamInst(..), famInstTyCon, extendFamInstEnv,
-		    pprFamInst, pprFamInsts )
-import TcMType	  ( tcInstSkolType )
-import TcType	  ( SkolemInfo(..), tcSplitTyConApp )
-import TcRnMonad  ( TcM, TcGblEnv(..), setGblEnv, getGblEnv, foldlM,
-		    setSrcSpan, addErr, getEps )
-import TyCon      ( tyConFamInst_maybe )
-import Type	  ( mkTyConApp )
-import Name	  ( getSrcLoc )
-import SrcLoc	  ( mkSrcSpan )
+import HscTypes
+import FamInstEnv
+import TcMType
+import TcType
+import TcRnMonad
+import TyCon
+import Type
+import Name
+import SrcLoc
 import Outputable
+
+import Monad
 \end{code}
 
 
@@ -55,36 +55,39 @@ addLocalFamInst home_fie famInst
 	      ty    = case tyConFamInst_maybe tycon of
 		        Nothing        -> panic "FamInst.addLocalFamInst"
 			Just (tc, tys) -> tc `mkTyConApp` tys
-	; (tvs', theta', tau') <- tcInstSkolType (FamInstSkol tycon) ty
+	; (tvs', _, tau') <- tcInstSkolType (FamInstSkol tycon) ty
 
-	; let	(fam, tys') = tcSplitTyConApp tau'
+	; let (fam, tys') = tcSplitTyConApp tau'
 
 		-- Load imported instances, so that we report
 		-- overlaps correctly
 	; eps <- getEps
 	; let inst_envs = (eps_fam_inst_env eps, home_fie)
 
-{- !!!TODO: Need to complete this:
-		-- Check for overlapping instance decls
-	; let { (matches, _) = lookupFamInstEnv inst_envs fam tys'
-	      ;	dup_ispecs = [ dup_ispec   --!!!adapt
-			     | (_, dup_ispec) <- matches
-			     , let (_,_,_,dup_tys) = instanceHead dup_ispec
-			     , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
-		-- Find memebers of the match list which ispec itself matches.
-		-- If the match is 2-way, it's a duplicate
-	; case dup_ispecs of
-	    dup_ispec : _ -> dupInstErr famInst dup_ispec
-	    []            -> return ()
- -}
+		-- Check for conflicting instance decls
+	; let { matches   = lookupFamInstEnvUnify inst_envs fam tys'
+	      ;	conflicts = [ conflictingFamInst
+			    | match@(_, conflictingFamInst) <- matches
+			    , conflicting fam tys' tycon match 
+			    ]
+              }
+	; unless (null conflicts) $
+	    conflictInstErr famInst (head conflicts)
 
 		-- OK, now extend the envt
-	; return (extendFamInstEnv home_fie famInst) }
+	; return (extendFamInstEnv home_fie famInst) 
+        }
+  where
+    -- In the case of data/newtype instances, any overlap is a conflicts (as
+    -- these instances imply injective type mappings).
+    conflicting _   _    tycon _                 | isAlgTyCon tycon = True
+    conflicting fam tys' tycon (subst, cFamInst) | otherwise	  =
+      panic "FamInst.addLocalFamInst: overlap check for indexed synonyms is still missing"
 
-overlapErr famInst dupFamInst
+conflictInstErr famInst conflictingFamInst
   = addFamInstLoc famInst $
-    addErr (hang (ptext SLIT("Overlapping family instance declarations:"))
-	       2 (pprFamInsts [famInst, dupFamInst]))
+    addErr (hang (ptext SLIT("Conflicting family instance declarations:"))
+	       2 (pprFamInsts [famInst, conflictingFamInst]))
 
 addFamInstLoc famInst thing_inside
   = setSrcSpan (mkSrcSpan loc loc) thing_inside