fix bugs, add boolean flag to identify coercion variables

Mon Sep 18 16:41:32 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * fix bugs, add boolean flag to identify coercion variables
  Sun Aug  6 17:04:02 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * fix bugs, add boolean flag to identify coercion variables
    Tue Jul 25 06:20:05 EDT 2006  kevind@bu.edu

9 files changed, 61 insertions, 24 deletions

diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs
index e4aa8c23d6..d4bf400ef6 100644
--- a/compiler/basicTypes/Var.lhs
+++ b/compiler/basicTypes/Var.lhs
@@ -10,7 +10,7 @@ module Var (
 	setVarName, setVarUnique, 
 
 	-- TyVars
-	TyVar, mkTyVar, mkTcTyVar, mkWildTyVar,
+	TyVar, mkTyVar, mkTcTyVar, mkWildCoVar,
 	tyVarName, tyVarKind,
 	setTyVarName, setTyVarUnique, setTyVarKind,
 	tcTyVarDetails,
@@ -68,7 +68,9 @@ data Var
 	realUnique :: FastInt,		-- Key for fast comparison
 					-- Identical to the Unique in the name,
 					-- cached here for speed
-	tyVarKind :: Kind }
+	tyVarKind :: Kind,
+        isCoercionVar :: Bool
+ }
 
   | TcTyVar { 				-- Used only during type inference
 					-- Used for kind variables during 
@@ -189,6 +191,7 @@ mkTyVar :: Name -> Kind -> TyVar
 mkTyVar name kind = TyVar { varName    = name
 			  , realUnique = getKey# (nameUnique name)
 			  , tyVarKind  = kind
+                          , isCoercionVar    = False
 			}
 
 mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar
@@ -199,11 +202,12 @@ mkTcTyVar name kind details
 		tcTyVarDetails = details
 	}
 
-mkWildTyVar :: Kind -> TyVar
-mkWildTyVar kind 
+mkWildCoVar :: Kind -> TyVar
+mkWildCoVar kind 
   = TyVar { varName = mkSysTvName wild_uniq FSLIT("co_wild"),
             realUnique = _ILIT(1),
-            tyVarKind = kind }
+            tyVarKind = kind,
+            isCoercionVar = True }
   where
     wild_uniq = (mkBuiltinUnique 1)
 \end{code}
@@ -223,10 +227,12 @@ setCoVarUnique = setVarUnique
 setCoVarName   = setVarName
 
 mkCoVar :: Name -> Kind -> CoVar
-mkCoVar name kind = mkTyVar name kind
+mkCoVar name kind = TyVar { varName    = name
+			  , realUnique = getKey# (nameUnique name)
+			  , tyVarKind  = kind
+                          , isCoercionVar    = True
+			}
 
-isCoVar :: TyVar -> Bool
-isCoVar ty = isCoSuperKind (tyVarKind ty)
 \end{code}
 
 %************************************************************************
@@ -342,6 +348,9 @@ isId other	   = False
 isLocalId (LocalId {}) = True
 isLocalId other	       = False
 
+isCoVar (v@(TyVar {})) = isCoercionVar v
+isCoVar other          = False
+
 -- isLocalVar returns True for type variables as well as local Ids
 -- These are the variables that we need to pay attention to when finding free
 -- variables, or doing dependency analysis.
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index 818175478f..e7d79e6162 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -175,6 +175,7 @@ make_ty (NoteTy _ t) 	= make_ty t
 
 
 make_kind :: Kind -> C.Kind
+make_kind (PredTy p) | isEqPred p = panic "coercion kinds in external core not implemented!"
 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
 make_kind k
   | isLiftedTypeKind k   = C.Klifted
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index d793343e41..9ff15487ec 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -254,7 +254,7 @@ match :: [Id]		  -- Variables rep'ing the exprs we're matching with
       -> DsM MatchResult  -- Desugared result!
 
 match [] ty eqns
-  = ASSERT( not (null eqns) )
+  = ASSERT2( not (null eqns), ppr ty )
     returnDs (foldr1 combineMatchResults match_results)
   where
     match_results = [ ASSERT( null (eqn_pats eqn) ) 
@@ -715,6 +715,9 @@ data PatGroup
 
 
 groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]
+-- If the result is of form [g1, g2, g3], 
+-- (a) all the (pg,eq) pairs in g1 have the same pg
+-- (b) none of the gi are empty
 groupEquations eqns
   = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns]
   where
diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 3c10c1c985..3751f95a83 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -256,7 +256,7 @@ matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
 	; lit_expr    <- dsOverLit lit
 	; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
 	      minusk_expr = mkApps minus_expr [Var var, lit_expr]
-	      (wraps, eqns') = mapAndUnzip (shift n1) eqns
+	      (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
 	; match_result <- match vars ty eqns'
 	; return  (mkGuardedMatchResult pred_expr 		$
 		   mkCoLetMatchResult (NonRec n1 minusk_expr)	$
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 18306a98de..c42be908bd 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -607,7 +607,9 @@ We know the list must have at least one @Match@ in it.
 
 \begin{code}
 pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc
-pprMatches ctxt (MatchGroup matches ty) = (ppr ty) $$ vcat (map (pprMatch ctxt) (map unLoc matches))
+pprMatches ctxt (MatchGroup matches ty) = vcat (map (pprMatch ctxt) (map unLoc matches))
+                                          -- Don't print the type; it's only 
+                                          -- a place-holder before typechecking
 
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
 pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 9eda9073dd..d1118c0128 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -82,15 +82,24 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
 -- because the latter is part of a knot, whereas the former is not.
 mkNewTyConRhs tycon_name tycon con 
   = do	{ co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
-	; let co_tycon = mkNewTypeCoercion co_tycon_name tycon tvs rhs_ty 
+	; let co_tycon = mkNewTypeCoercion co_tycon_name tycon tvs rhs_ty
+              cocon_maybe 
+                | all_coercions || isRecursiveTyCon tycon 
+                = Just co_tycon
+                | otherwise              
+                = Nothing
 	; return (NewTyCon { data_con = con, 
- 		       	     nt_co = Just co_tycon, 
+ 		       	     nt_co = cocon_maybe, 
                              -- Coreview looks through newtypes with a Nothing
                              -- for nt_co, or uses explicit coercions otherwise
 		       	     nt_rhs = rhs_ty,
 		       	     nt_etad_rhs = eta_reduce tvs rhs_ty,
 		       	     nt_rep = mkNewTyConRep tycon rhs_ty }) }
   where
+        -- if all_coercions is True then we use coercions for all newtypes
+        -- otherwise we use coercions for recursive newtypes and look through
+        -- non-recursive newtypes
+    all_coercions = True
     tvs    = tyConTyVars tycon
     rhs_ty = head (dataConInstOrigArgTys con (mkTyVarTys tvs))
 	-- Instantiate the data con with the 
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 727d0abe7e..a3828082e3 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -170,7 +170,6 @@ import Type		(	-- Re-exports
 			  pprPred, pprTheta, pprThetaArrow, pprClassPred
 			)
 import TyCon		( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique )
-import Coercion         ( splitForAllCo_maybe )
 import DataCon		( DataCon, dataConStupidTheta, dataConResTys )
 import Class		( Class )
 import Var		( TyVar, Id, isCoVar, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
@@ -645,20 +644,23 @@ tcSplitForAllTys ty = split ty ty []
      split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
      split orig_ty (ForAllTy tv ty) tvs 
        | not (isCoVar tv) = split ty ty (tv:tvs)
-     split orig_ty t		    tvs = (reverse tvs, orig_ty)
+     split orig_ty t tvs = (reverse tvs, orig_ty)
 
 tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
-tcIsForAllTy (ForAllTy tv ty) = True
+tcIsForAllTy (ForAllTy tv ty) = not (isCoVar tv)
 tcIsForAllTy t		      = False
 
 tcSplitPhiTy :: Type -> (ThetaType, Type)
 tcSplitPhiTy ty = split ty ty []
  where
   split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
+
+  split orig_ty (ForAllTy tv ty) ts
+        | isCoVar tv = split ty ty (eq_pred:ts)
+        where
+           PredTy eq_pred = tyVarKind tv
   split orig_ty (FunTy arg res) ts 
 	| Just p <- tcSplitPredTy_maybe arg = split res res (p:ts)
-  split orig_ty ty ts
-        | Just (p, ty') <- splitForAllCo_maybe ty = split ty' ty' (p:ts) 
   split orig_ty ty		ts = (reverse ts, orig_ty)
 
 tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
@@ -985,9 +987,14 @@ tcTyVarsOfType (NoteTy _ ty)	    = tcTyVarsOfType ty
 tcTyVarsOfType (PredTy sty)	    = tcTyVarsOfPred sty
 tcTyVarsOfType (FunTy arg res)	    = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
 tcTyVarsOfType (AppTy fun arg)	    = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
-tcTyVarsOfType (ForAllTy tyvar ty)  = tcTyVarsOfType ty `delVarSet` tyvar
+tcTyVarsOfType (ForAllTy tyvar ty)  = (tcTyVarsOfType ty `delVarSet` tyvar)
+                                      `unionVarSet` tcTyVarsOfTyVar tyvar
 	-- We do sometimes quantify over skolem TcTyVars
 
+tcTyVarsOfTyVar :: TcTyVar -> TyVarSet
+tcTyVarsOfTyVar tv | isCoVar tv = tcTyVarsOfType (tyVarKind tv)
+                   | otherwise  = emptyVarSet
+
 tcTyVarsOfTypes :: [Type] -> TyVarSet
 tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
 
@@ -1030,11 +1037,15 @@ exactTyVarsOfType ty
     go (FunTy arg res)	    	  = go arg `unionVarSet` go res
     go (AppTy fun arg)	    	  = go fun `unionVarSet` go arg
     go (ForAllTy tyvar ty)  	  = delVarSet (go ty) tyvar
+                                    `unionVarSet` go_tv tyvar
 
     go_pred (IParam _ ty)    = go ty
     go_pred (ClassP _ tys)   = exactTyVarsOfTypes tys
     go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2
 
+    go_tv tyvar | isCoVar tyvar = go (tyVarKind tyvar)
+                | otherwise     = emptyVarSet
+
 exactTyVarsOfTypes :: [TcType] -> TyVarSet
 exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
 \end{code}
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index b7f521a15d..579914755e 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -106,7 +106,7 @@ import TypeRep
 
 -- friends:
 import Var	( Var, TyVar, tyVarKind, tyVarName, 
-		  setTyVarName, setTyVarKind, mkWildTyVar )
+		  setTyVarName, setTyVarKind, mkWildCoVar )
 import VarEnv
 import VarSet
 
@@ -307,7 +307,7 @@ splitAppTys ty = split ty ty []
 
 \begin{code}
 mkFunTy :: Type -> Type -> Type
-mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildTyVar (PredTy (EqPred ty1 ty2))) res
+mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildCoVar (PredTy (EqPred ty1 ty2))) res
 mkFunTy arg res = FunTy arg res
 
 mkFunTys :: [Type] -> Type -> Type
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index cef77a126e..544b822f28 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -313,7 +313,7 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] lif
 
 
 tySuperKindTyCon     = mkSuperKindTyCon tySuperKindTyConName
-coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName
+coSuperKindTyCon     = mkSuperKindTyCon coSuperKindTyConName
 
 liftedTypeKindTyCon   = mkKindTyCon liftedTypeKindTyConName
 openTypeKindTyCon     = mkKindTyCon openTypeKindTyConName
@@ -329,8 +329,8 @@ mkKindTyCon name = mkVoidPrimTyCon name tySuperKind 0
 --------------------------
 -- ... and now their names
 
-tySuperKindTyConName     = mkPrimTyConName FSLIT("BOX") tySuperKindTyConKey tySuperKindTyCon
-coSuperKindTyConName = mkPrimTyConName FSLIT("COERCION") coSuperKindTyConKey coSuperKindTyCon
+tySuperKindTyConName      = mkPrimTyConName FSLIT("BOX") tySuperKindTyConKey tySuperKindTyCon
+coSuperKindTyConName      = mkPrimTyConName FSLIT("COERCION") coSuperKindTyConKey coSuperKindTyCon
 liftedTypeKindTyConName   = mkPrimTyConName FSLIT("*") liftedTypeKindTyConKey liftedTypeKindTyCon
 openTypeKindTyConName     = mkPrimTyConName FSLIT("?") openTypeKindTyConKey openTypeKindTyCon
 unliftedTypeKindTyConName = mkPrimTyConName FSLIT("#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
@@ -372,9 +372,11 @@ tySuperKind, coSuperKind :: SuperKind
 tySuperKind = kindTyConType tySuperKindTyCon 
 coSuperKind = kindTyConType coSuperKindTyCon 
 
+isTySuperKind (NoteTy _ ty)    = isTySuperKind ty
 isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
 isTySuperKind other            = False
 
+isCoSuperKind (NoteTy _ ty)    = isCoSuperKind ty
 isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey
 isCoSuperKind other            = False