Add HsCoreTy to HsType

[ghc-hetmet.git] / compiler / typecheck / FamInst.lhs

diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index f85f6b9..b09f9a5 100644 (file)
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -5,24 +5,22 @@ module FamInst (
         checkFamInstConsistency, tcExtendLocalFamInstEnv
     ) where
 
         checkFamInstConsistency, tcExtendLocalFamInstEnv
     ) where
 

-#include "HsVersions.h"
-

 import HscTypes
 import FamInstEnv
 import TcMType
 import TcType
 import TcRnMonad
 import TyCon
 import HscTypes
 import FamInstEnv
 import TcMType
 import TcType
 import TcRnMonad
 import TyCon

-import Type

 import Name
 import Module
 import SrcLoc
 import Outputable
 import UniqFM
 import FiniteMap
 import Name
 import Module
 import SrcLoc
 import Outputable
 import UniqFM
 import FiniteMap

+import FastString

 
 

-import Maybe
-import Monad
+import Maybes
+import Control.Monad

 \end{code}
 
 
 \end{code}
 
 

@@ -37,6 +35,16 @@ check whether the instances in the two modules are consistent, *unless* we can
 be certain that the instances of the two modules have already been checked for
 consistency during the compilation of modules that we import.
 
 be certain that the instances of the two modules have already been checked for
 consistency during the compilation of modules that we import.
 

+Why do we need to check?  Consider 
+   module X1 where               module X2 where
+    data T1                        data T2
+    type instance F T1 b = Int     type instance F a T2 = Char
+    f1 :: F T1 a -> Int                    f2 :: Char -> F a T2
+    f1 x = x                       f2 x = x
+
+Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.
+Notice that neither instance is an orphan.
+

 How do we know which pairs of modules have already been checked?  Any pair of
 modules where both modules occur in the `HscTypes.dep_finsts' set (of the
 `HscTypes.Dependencies') of one of our directly imported modules must have
 How do we know which pairs of modules have already been checked?  Any pair of
 modules where both modules occur in the `HscTypes.dep_finsts' set (of the
 `HscTypes.Dependencies') of one of our directly imported modules must have

@@ -108,8 +116,8 @@ checkFamInstConsistency famInstMods directlyImpMods
     -- already loaded in the EPS or they are in the HPT.
     --
     check modInstsEnv (ModulePair m1 m2)
     -- already loaded in the EPS or they are in the HPT.
     --
     check modInstsEnv (ModulePair m1 m2)

-      = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
-           ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
+      = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1
+           ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m2

            ; insts1   = famInstEnvElts instEnv1
            }
         in
            ; insts1   = famInstEnvElts instEnv1
            }
         in

@@ -169,36 +177,22 @@ checkForConflicts inst_envs famInst
                -- (since we do unification).  
                -- We use tcInstSkolType because we don't want to allocate
                -- fresh *meta* type variables.  
                -- (since we do unification).  
                -- We use tcInstSkolType because we don't want to allocate
                -- fresh *meta* type variables.  

-       ; let { tycon = famInstTyCon famInst
-            ; ty    = case tyConFamInst_maybe tycon of
-                        Nothing        -> panic "FamInst.checkForConflicts"
-                        Just (tc, tys) -> tc `mkTyConApp` tys
-             }
-       ; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty
-
-       ; let (fam, tys') = tcSplitTyConApp tau'
-
-       ; let { matches   = lookupFamInstEnvUnify inst_envs fam tys'
-            ; conflicts = [ conflictingFamInst
-                          | match@(conflictingFamInst, _) <- matches
-                          , conflicting fam tys' tycon match 
-                          ]
-            }
+
+       ; skol_tvs <- tcInstSkolTyVars FamInstSkol 
+                                      (tyConTyVars (famInstTyCon famInst))
+       ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs

        ; unless (null conflicts) $
        ; unless (null conflicts) $

-          conflictInstErr famInst (head conflicts)
+          conflictInstErr famInst (fst (head conflicts))

        }
   where
        }
   where

-    -- In the case of data/newtype instances, any overlap is a conflict (as
-    -- these instances imply injective type mappings).
-    conflicting _   _    tycon _                 | isAlgTyCon tycon = True
-    conflicting fam tys' tycon (subst, cFamInst) | otherwise     =
-      panic "FamInst.checkForConflicts: overlap check for indexed synonyms is still missing"

 
 

+conflictInstErr :: FamInst -> FamInst -> TcRn ()

 conflictInstErr famInst conflictingFamInst
   = addFamInstLoc famInst $
 conflictInstErr famInst conflictingFamInst
   = addFamInstLoc famInst $

-    addErr (hang (ptext SLIT("Conflicting family instance declarations:"))
+    addErr (hang (ptext (sLit "Conflicting family instance declarations:"))

               2 (pprFamInsts [famInst, conflictingFamInst]))
 
               2 (pprFamInsts [famInst, conflictingFamInst]))
 

+addFamInstLoc :: FamInst -> TcRn a -> TcRn a

 addFamInstLoc famInst thing_inside
   = setSrcSpan (mkSrcSpan loc loc) thing_inside
   where
 addFamInstLoc famInst thing_inside
   = setSrcSpan (mkSrcSpan loc loc) thing_inside
   where