Make sure to zonk the kind of coercion variables

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

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 5b660df..543c61c 100644 (file)
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -33,8 +33,8 @@ module TcMType (
   --------------------------------
   -- Instantiation
   tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar,
-  tcInstSigTyVars,
-  tcInstSkolTyVar, tcInstSkolTyVars, tcInstSkolType, 
+  tcInstSigType,
+  tcInstSkolTyVars, tcInstSkolType, 
   tcSkolSigType, tcSkolSigTyVars, occurCheckErr,
 
   --------------------------------
@@ -430,17 +430,17 @@ tcSkolSigTyVars :: SkolemInfo -> [TyVar] -> [TcTyVar]
 tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info
                              | tv <- tyvars ]
 
-tcInstSkolTyVar :: SkolemInfo -> Maybe SrcSpan -> TyVar -> TcM TcTyVar
+tcInstSkolTyVar :: SkolemInfo -> (Name -> SrcSpan) -> TyVar -> TcM TcTyVar
 -- Instantiate the tyvar, using 
 --     * the occ-name and kind of the supplied tyvar, 
 --     * the unique from the monad,
 --     * the location either from the tyvar (mb_loc = Nothing)
 --       or from mb_loc (Just loc)
-tcInstSkolTyVar info mb_loc tyvar
+tcInstSkolTyVar info get_loc tyvar
   = do { uniq <- newUnique
        ; let old_name = tyVarName tyvar
              kind     = tyVarKind tyvar
-             loc      = mb_loc `orElse` getSrcSpan old_name
+             loc      = get_loc old_name
              new_name = mkInternalName uniq (nameOccName old_name) loc
        ; return (mkSkolTyVar new_name kind info) }
 
@@ -448,12 +448,21 @@ tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
 -- Get the location from the monad
 tcInstSkolTyVars info tyvars 
   = do         { span <- getSrcSpanM
-       ; mapM (tcInstSkolTyVar info (Just span)) tyvars }
+       ; mapM (tcInstSkolTyVar info (const span)) tyvars }
 
 tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
 -- Instantiate a type with fresh skolem constants
 -- Binding location comes from the monad
 tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty
+
+tcInstSigType :: Bool -> SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcRhoType)
+-- Instantiate with skolems or meta SigTvs; depending on use_skols
+-- Always take location info from the supplied tyvars
+tcInstSigType use_skols skol_info ty
+  = tcInstType (mapM inst_tyvar) ty
+  where
+    inst_tyvar | use_skols = tcInstSkolTyVar skol_info getSrcSpan
+              | otherwise = instMetaTyVar (SigTv skol_info)
 \end{code}
 
 
@@ -515,6 +524,7 @@ writeMetaTyVar tyvar ty
     -- TOM: It should also work for coercions
     -- ASSERT2( k2 `isSubKind` k1, (ppr tyvar <+> ppr k1) $$ (ppr ty <+> ppr k2) )
     do { ASSERTM2( do { details <- readMetaTyVar tyvar; return (isFlexi details) }, ppr tyvar )
+       ; traceTc (text "writeMetaTyVar" <+> ppr tyvar <+> text ":=" <+> ppr ty)
        ; writeMutVar (metaTvRef tyvar) (Indirect ty) }
   where
     _k1 = tyVarKind tyvar
@@ -563,16 +573,6 @@ tcInstTyVars tyvars
 %************************************************************************
 
 \begin{code}
-tcInstSigTyVars :: Bool -> SkolemInfo -> [TyVar] -> TcM [TcTyVar]
--- Instantiate with skolems or meta SigTvs; depending on use_skols
--- Always take location info from the supplied tyvars
-tcInstSigTyVars use_skols skol_info tyvars 
-  | use_skols
-  = mapM (tcInstSkolTyVar skol_info Nothing) tyvars
-
-  | otherwise
-  = mapM (instMetaTyVar (SigTv skol_info)) tyvars
-
 zonkSigTyVar :: TcTyVar -> TcM TcTyVar
 zonkSigTyVar sig_tv 
   | isSkolemTyVar sig_tv 
@@ -763,8 +763,11 @@ zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
 --
 -- We leave skolem TyVars alone; they are immutable.
 zonkQuantifiedTyVar tv
-  | ASSERT( isTcTyVar tv ) 
-    isSkolemTyVar tv = return tv
+  | ASSERT2( isTcTyVar tv, ppr tv ) 
+    isSkolemTyVar tv 
+  = do { kind <- zonkTcType (tyVarKind tv)
+       ; return $ setTyVarKind tv kind
+       }
        -- It might be a skolem type variable, 
        -- for example from a user type signature
 
@@ -896,12 +899,14 @@ zonkType unbound_var_fn ty
 
        -- The two interesting cases!
     go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar unbound_var_fn tyvar
-                      | otherwise       = return (TyVarTy tyvar)
+                      | otherwise       = liftM TyVarTy $ 
+                                             zonkTyVar unbound_var_fn tyvar
                -- Ordinary (non Tc) tyvars occur inside quantified types
 
     go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do
                              ty' <- go ty
-                             return (ForAllTy tyvar ty')
+                             tyvar' <- zonkTyVar unbound_var_fn tyvar
+                             return (ForAllTy tyvar' ty')
 
     go_pred (ClassP c tys)   = do tys' <- mapM go tys
                                   return (ClassP c tys')
@@ -911,7 +916,7 @@ zonkType unbound_var_fn ty
                                   ty2' <- go ty2
                                   return (EqPred ty1' ty2')
 
-zonk_tc_tyvar :: (TcTyVar -> TcM Type)         -- What to do for an unbound mutable variable
+zonk_tc_tyvar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable var
              -> TcTyVar -> TcM TcType
 zonk_tc_tyvar unbound_var_fn tyvar 
   | not (isMetaTyVar tyvar)    -- Skolems
@@ -922,6 +927,18 @@ zonk_tc_tyvar unbound_var_fn tyvar
        ; case cts of
            Flexi       -> unbound_var_fn tyvar    -- Unbound meta type variable
            Indirect ty -> zonkType unbound_var_fn ty  }
+
+-- Zonk the kind of a non-TC tyvar in case it is a coercion variable (their
+-- kind contains types).
+--
+zonkTyVar :: (TcTyVar -> TcM Type)      -- What to do for an unbound mutable var
+         -> TyVar -> TcM TyVar
+zonkTyVar unbound_var_fn tv 
+  | isCoVar tv
+  = do { kind <- zonkType unbound_var_fn (tyVarKind tv)
+       ; return $ setTyVarKind tv kind
+       }
+  | otherwise = return tv
 \end{code}
 
 
@@ -998,18 +1015,22 @@ checkValidType ctxt ty = do
                   | otherwise = Rank n
        rank
          = case ctxt of
-                GenPatCtxt     -> MustBeMonoType
                 DefaultDeclCtxt-> MustBeMonoType
                 ResSigCtxt     -> MustBeMonoType
                 LamPatSigCtxt  -> gen_rank 0
                 BindPatSigCtxt -> gen_rank 0
                 TySynCtxt _    -> gen_rank 0
+                GenPatCtxt     -> gen_rank 1
+                       -- This one is a bit of a hack
+                       -- See the forall-wrapping in TcClassDcl.mkGenericInstance              
+
                 ExprSigCtxt    -> gen_rank 1
                 FunSigCtxt _   -> gen_rank 1
                 ConArgCtxt _   | polycomp -> gen_rank 2
                                 -- We are given the type of the entire
                                 -- constructor, hence rank 1
                                | otherwise -> gen_rank 1
+
                 ForSigCtxt _   -> gen_rank 1
                 SpecInstCtxt   -> gen_rank 1