X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FCoercion.lhs;h=05f1601431b92bc4cd94ec71659d1188e1800250;hb=34429d31b0d48352e4ffd29186e919b6248cdd5c;hp=02d92d73e13ffc8b7accb4ddf41984277b288f9b;hpb=474b582b68ea9289f3da4355da816164138604b0;p=ghc-hetmet.git

diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 02d92d7..05f1601 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -12,6 +12,13 @@ The coercion kind constructor is a special TyCon that must always be saturated
   typeKind (symCoercion type) :: TyConApp CoercionTyCon{...} [type, type]
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module Coercion (
         Coercion,
  
@@ -22,8 +29,10 @@ module Coercion (
 	isEqPred, mkEqPred, getEqPredTys, isEqPredTy,  
 
 	-- Coercion transformations
+	mkCoercion,
         mkSymCoercion, mkTransCoercion,
-        mkLeftCoercion, mkRightCoercion, mkInstCoercion, mkAppCoercion,
+        mkLeftCoercion, mkRightCoercion, mkRightCoercions,
+	mkInstCoercion, mkAppCoercion,
         mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion,
         mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
 
@@ -39,8 +48,8 @@ module Coercion (
 	mkSymCoI, mkTransCoI, 
 	mkTyConAppCoI, mkAppTyCoI, mkFunTyCoI,
 	mkNoteTyCoI, mkForAllTyCoI,
-	fromCoI,
-	mkClassPPredCoI, mkIParamPredCoI, mkEqPredCoI,
+	fromCoI, fromACo,
+	mkClassPPredCoI, mkIParamPredCoI, mkEqPredCoI
 
        ) where 
 
@@ -60,6 +69,9 @@ import BasicTypes
 import Outputable
 
 
+type Coercion     = Type
+type CoercionKind = Kind	-- A CoercionKind is always of form (ty1 :=: ty2)
+
 ------------------------------
 decomposeCo :: Arity -> Coercion -> [Coercion]
 -- (decomposeCo 3 c) = [right (left (left c)), right (left c), right c]
@@ -102,9 +114,6 @@ splitCoercionKind_maybe co | Just co' <- kindView co = splitCoercionKind_maybe c
 splitCoercionKind_maybe (PredTy (EqPred ty1 ty2)) = Just (ty1, ty2)
 splitCoercionKind_maybe other = Nothing
 
-type Coercion     = Type
-type CoercionKind = Kind	-- A CoercionKind is always of form (ty1 :=: ty2)
-
 coercionKind :: Coercion -> (Type, Type)
 -- 	c :: (t1 :=: t2)
 -- Then (coercionKind c) = (t1,t2)
@@ -227,6 +236,17 @@ mkRightCoercion  co
   | Just (co1, co2) <- splitAppCoercion_maybe co = co2
   | otherwise = mkCoercion rightCoercionTyCon [co]
 
+mkRightCoercions n co
+  = go n co []
+  where
+    go n co acc 
+       | n > 0
+       = case splitAppCoercion_maybe co of
+          Just (co1,co2) -> go (n-1) co1 (co2:acc)
+          Nothing        -> go (n-1) (mkCoercion leftCoercionTyCon [co]) (mkCoercion rightCoercionTyCon [co]:acc)
+       | otherwise
+       = acc
+
 mkInstCoercion co ty
   | Just (tv,co') <- splitForAllTy_maybe co
   = substTyWith [tv] [ty] co'	-- (forall a.co) @ ty  -->  co[ty/a]
@@ -351,7 +371,10 @@ transCoercionTyCon =
   where
     composeCoercionKindsOf (co1:co2:rest)
       = ASSERT( null rest )
-        WARN( not (r1 `coreEqType` a2), text "Strange! Type mismatch in trans coercion, probably a bug")
+        WARN( not (r1 `coreEqType` a2), 
+              text "Strange! Type mismatch in trans coercion, probably a bug"
+              $$
+              ppr r1 <+> text "=/=" <+> ppr a2)
         (a1, r2)
       where
         (a1, r1) = coercionKind co1
@@ -381,6 +404,9 @@ splitCoercionKindOf co
   , Just (ty_fun1, ty_arg1) <- splitAppTy_maybe ty1
   , Just (ty_fun2, ty_arg2) <- splitAppTy_maybe ty2
   = ((ty_fun1, ty_fun2),(ty_arg1, ty_arg2))
+splitCoercionKindOf co 
+  = pprPanic "Coercion.splitCoercionKindOf" 
+             (ppr co $$ ppr (coercionKindPredTy co))
 
 instCoercionTyCon 
   =  mkCoercionTyCon instCoercionTyConName 2 instCoercionKind
@@ -451,7 +477,6 @@ splitNewTypeRepCo_maybe other
 -- CoercionI smart constructors
 --	lifted smart constructors of ordinary coercions
 
-
 \begin{code}
 	-- CoercionI is either 
 	--	(a) proper coercion
@@ -462,6 +487,16 @@ isIdentityCoercion :: CoercionI -> Bool
 isIdentityCoercion IdCo = True
 isIdentityCoercion _    = False
 
+allIdCos :: [CoercionI] -> Bool
+allIdCos = all isIdentityCoercion
+
+zipCoArgs :: [CoercionI] -> [Type] -> [Coercion]
+zipCoArgs cois tys = zipWith fromCoI cois tys
+
+fromCoI :: CoercionI -> Type -> Type
+fromCoI IdCo ty     = ty	-- Identity coercion represented 
+fromCoI (ACo co) ty = co	-- 	by the type itself
+
 mkSymCoI :: CoercionI -> CoercionI
 mkSymCoI IdCo = IdCo
 mkSymCoI (ACo co) = ACo $ mkCoercion symCoercionTyCon [co] 
@@ -474,18 +509,9 @@ mkTransCoI aco IdCo = aco
 mkTransCoI (ACo co1) (ACo co2) = ACo $ mkTransCoercion co1 co2
 
 mkTyConAppCoI :: TyCon -> [Type] -> [CoercionI] -> CoercionI
-mkTyConAppCoI tyCon tys cois =
-	let (anyAcon,co_args) = f tys cois
-	in if anyAcon
-		then ACo (TyConApp tyCon co_args)
-		else IdCo
-	where
-		f [] [] = (False,[])
-		f (x:xs) (y:ys) = 
-			let (b,cos) = f xs ys
-			in case y of
-				IdCo   -> (b,x:cos)
-				ACo co -> (True,co:cos)
+mkTyConAppCoI tyCon tys cois
+  | allIdCos cois = IdCo
+  | otherwise	  = ACo (TyConApp tyCon (zipCoArgs cois tys))
 
 mkAppTyCoI :: Type -> CoercionI -> Type -> CoercionI -> CoercionI
 mkAppTyCoI ty1 IdCo ty2 IdCo = IdCo
@@ -505,31 +531,25 @@ mkForAllTyCoI :: TyVar -> CoercionI -> CoercionI
 mkForAllTyCoI _ IdCo = IdCo
 mkForAllTyCoI tv (ACo co) = ACo $ ForAllTy tv co
 
-fromCoI IdCo ty     = ty
-fromCoI (ACo co) ty = co
+fromACo :: CoercionI -> Coercion
+fromACo (ACo co) = co
 
 mkClassPPredCoI :: Class -> [Type] -> [CoercionI] -> CoercionI
-mkClassPPredCoI cls tys cois =
-	let (anyAcon,co_args) = f tys cois
-	in if anyAcon
-		then ACo $ PredTy $ ClassP cls co_args
-		else IdCo
-	where
-		f [] [] = (False,[])
-		f (x:xs) (y:ys) = 
-			let (b,cos) = f xs ys
-			in case y of
-				IdCo   -> (b,x:cos)
-				ACo co -> (True,co:cos)
+-- mkClassPPredCoI cls tys cois = coi
+--    coi : PredTy (cls tys) ~ predTy (cls (tys `cast` cois))
+mkClassPPredCoI cls tys cois 
+  | allIdCos cois = IdCo
+  | otherwise     = ACo $ PredTy $ ClassP cls (zipCoArgs cois tys)
 
 mkIParamPredCoI :: (IPName Name) -> CoercionI -> CoercionI 
+-- Similar invariant to mkclassPPredCoI
 mkIParamPredCoI ipn IdCo     = IdCo
 mkIParamPredCoI ipn (ACo co) = ACo $ PredTy $ IParam ipn co
 
 mkEqPredCoI :: Type -> CoercionI -> Type -> CoercionI -> CoercionI
+-- Similar invariant to mkclassPPredCoI
 mkEqPredCoI _    IdCo     _   IdCo      = IdCo
 mkEqPredCoI ty1  IdCo     _   (ACo co2) = ACo $ PredTy $ EqPred ty1 co2
 mkEqPredCoI ty1 (ACo co1) ty2 coi2      = ACo $ PredTy $ EqPred co1 (fromCoI coi2 ty2)
-
 \end{code}