[project @ 2004-01-05 12:11:42 by simonpj]

[ghc-hetmet.git] / ghc / compiler / iface / TcIface.lhs

diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs
index c8c27e9..1d2d941 100644 (file)
--- a/ghc/compiler/iface/TcIface.lhs
+++ b/ghc/compiler/iface/TcIface.lhs
@@ -6,7 +6,7 @@
 \begin{code}
 module TcIface ( 
        tcImportDecl, typecheckIface,
-       tcIfaceKind, loadImportedInsts, loadImportedRules,
+       loadImportedInsts, loadImportedRules,
        tcExtCoreBindings
  ) where
 #include "HsVersions.h"
@@ -20,8 +20,7 @@ import IfaceEnv               ( lookupIfaceTop, newGlobalBinder, lookupOrig,
                          newIfaceName, newIfaceNames )
 import BuildTyCl       ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass )
 import TcRnMonad
-import Type            ( Kind, openTypeKind, liftedTypeKind, 
-                         unliftedTypeKind, mkArrowKind, splitTyConApp, 
+import Type            ( liftedTypeKind, splitTyConApp, 
                          mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
 import TypeRep         ( Type(..), PredType(..) )
 import TyCon           ( TyCon, tyConName )
@@ -29,7 +28,7 @@ import HscTypes               ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase,
                          HscEnv, TyThing(..), implicitTyThings, typeEnvIds,
                          ModIface(..), ModDetails(..), InstPool, ModGuts,
                          TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
-                         DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
+                         RulePool, Pool(..) )
 import InstEnv         ( extendInstEnv )
 import CoreSyn
 import PprCore         ( pprIdRules )
@@ -446,6 +445,13 @@ Then, if we are trying to resolve (C Int x), we need (a)
 if we are trying to resolve (C x [y]), we need *both* (b) and (c),
 even though T is not involved yet, so that we spot the overlap.
 
+
+NOTE: if you use an instance decl with NO type constructors
+       instance C a where ...
+and look up an Inst that only has type variables such as (C (n o))
+then GHC won't necessarily suck in the instances that overlap with this.
+
+
 \begin{code}
 loadImportedInsts :: Class -> [Type] -> TcM PackageInstEnv
 loadImportedInsts cls tys
@@ -467,7 +473,9 @@ loadImportedInsts cls tys
 
        -- Suck in the instances
        ; let { (inst_pool', iface_insts) 
-                   = selectInsts (eps_insts eps) cls_gate tc_gates }
+                   = WARN( null tc_gates, ptext SLIT("Interesting! No tycons in Inst:") 
+                                               <+> pprClassPred cls tys )
+                     selectInsts (eps_insts eps) cls_gate tc_gates }
 
        -- Empty => finish up rapidly, without writing to eps
        ; if null iface_insts then
@@ -504,18 +512,25 @@ selectInsts pool@(Pool insts n_in n_out) cls tycons
     (insts', iface_insts) 
        = case lookupNameEnv insts cls of {
                Nothing -> (insts, []) ;
-               Just gated_insts -> 
+               Just gated_insts ->
        
-         case foldl choose ([],[]) gated_insts of {
+         case choose1 gated_insts  of {
            (_, []) -> (insts, []) ;    -- None picked
            (gated_insts', iface_insts') -> 
 
          (extendNameEnv insts cls gated_insts', iface_insts') }}
 
+    choose1 gated_insts
+       | null tycons                   -- Bizarre special case of C (a b); then there are no tycons
+       = ([], map snd gated_insts)     -- Just grab all the instances, no real alternative
+       | otherwise                     -- Normal case
+       = foldl choose2 ([],[]) gated_insts
+
        -- Reverses the gated decls, but that doesn't matter
-    choose (gis, decls) (gates, decl)
-       | any (`elem` tycons) gates = (gis,                decl:decls)
-       | otherwise                 = ((gates,decl) : gis, decls)
+    choose2 (gis, decls) (gates, decl)
+       |  null gates   -- Happens when we have 'instance T a where ...'
+        || any (`elem` tycons) gates = (gis,              decl:decls)
+       | otherwise                  = ((gates,decl) : gis, decls)
 \end{code}
 
 %************************************************************************
@@ -571,7 +586,7 @@ selectRules (Pool rules n_in n_out) type_env
        | null gates' = (pool, rule:if_rules)
        | otherwise   = ((gates',rule) : pool, if_rules)
        where
-         gates' = filter (`elemNameEnv` type_env) gates
+         gates' = filter (not . (`elemNameEnv` type_env)) gates
 
 
 tcIfaceRule :: IfaceRule -> IfL IdCoreRule
@@ -596,13 +611,6 @@ tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule)
 %************************************************************************
 
 \begin{code}
-tcIfaceKind :: IfaceKind -> Kind
-tcIfaceKind IfaceOpenTypeKind     = openTypeKind
-tcIfaceKind IfaceLiftedTypeKind   = liftedTypeKind
-tcIfaceKind IfaceUnliftedTypeKind = unliftedTypeKind
-tcIfaceKind (IfaceFunKind k1 k2)  = mkArrowKind (tcIfaceKind k1) (tcIfaceKind k2)
-
------------------------------------------
 tcIfaceType :: IfaceType -> IfL Type
 tcIfaceType (IfaceTyVar n)        = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
 tcIfaceType (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
@@ -953,5 +961,5 @@ bindIfaceTyVars bndrs thing_inside
   where
     (occs,kinds) = unzip bndrs
 
-mk_iface_tyvar name kind = mkTyVar name (tcIfaceKind kind)
+mk_iface_tyvar name kind = mkTyVar name kind
 \end{code}