X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FCoercion.lhs;h=b49b35612d5d937f3b29883204c37963b630d14c;hb=24c13c1369c2ed21123c0c6eba7a7d7ab0313b86;hp=59a1a15c03607ebabbd3adf1f41df72ceed10903;hpb=5e5310b3cb4f78e30cc7b90879eb016e97c214cb;p=ghc-hetmet.git

diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 59a1a15..b49b356 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -22,7 +22,7 @@ module Coercion (
         Coercion,
  
         mkCoKind, mkReflCoKind, splitCoercionKind_maybe, splitCoercionKind,
-        coercionKind, coercionKinds, coercionKindPredTy,
+        coercionKind, coercionKinds, coercionKindPredTy, isIdentityCoercion,
 
 	-- ** Equality predicates
 	isEqPred, mkEqPred, getEqPredTys, isEqPredTy,  
@@ -31,8 +31,8 @@ module Coercion (
 	mkCoercion,
         mkSymCoercion, mkTransCoercion,
         mkLeftCoercion, mkRightCoercion, mkRightCoercions,
-	mkInstCoercion, mkAppCoercion,
-        mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion,
+	mkInstCoercion, mkAppCoercion, mkTyConCoercion, mkFunCoercion,
+        mkForAllCoercion, mkInstsCoercion, mkUnsafeCoercion,
         mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
 
         splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo,
@@ -46,7 +46,7 @@ module Coercion (
 
 	-- * CoercionI
 	CoercionI(..),
-	isIdentityCoercion,
+	isIdentityCoI,
 	mkSymCoI, mkTransCoI, 
 	mkTyConAppCoI, mkAppTyCoI, mkFunTyCoI,
 	mkForAllTyCoI,
@@ -63,10 +63,8 @@ import TyCon
 import Class
 import Var
 import Name
-import OccName
 import PrelNames
 import Util
-import Unique
 import BasicTypes
 import Outputable
 import FastString
@@ -184,6 +182,12 @@ coercionKinds :: [Coercion] -> ([Type], [Type])
 coercionKinds tys = unzip $ map coercionKind tys
 
 -------------------------------------
+isIdentityCoercion :: Coercion -> Bool
+isIdentityCoercion co  
+  = case coercionKind co of
+       (t1,t2) -> t1 `coreEqType` t2
+
+-------------------------------------
 -- Coercion kind and type mk's
 -- (make saturated TyConApp CoercionTyCon{...} args)
 
@@ -194,36 +198,40 @@ mkCoercion :: TyCon -> [Type] -> Coercion
 mkCoercion coCon args = ASSERT( tyConArity coCon == length args ) 
                         TyConApp coCon args
 
--- | Apply a 'Coercion' to another 'Coercion', which is presumably a 'Coercion' constructor of some
--- kind
+-- | Apply a 'Coercion' to another 'Coercion', which is presumably a
+-- 'Coercion' constructor of some kind
 mkAppCoercion :: Coercion -> Coercion -> Coercion
-mkAppCoercion    co1 co2 = mkAppTy co1 co2
+mkAppCoercion co1 co2 = mkAppTy co1 co2
 
 -- | Applies multiple 'Coercion's to another 'Coercion', from left to right.
 -- See also 'mkAppCoercion'
 mkAppsCoercion :: Coercion -> [Coercion] -> Coercion
-mkAppsCoercion   co1 tys = foldl mkAppTy co1 tys
+mkAppsCoercion co1 tys = foldl mkAppTy co1 tys
+
+-- | Apply a type constructor to a list of coercions.
+mkTyConCoercion :: TyCon -> [Coercion] -> Coercion
+mkTyConCoercion con cos = mkTyConApp con cos
+
+-- | Make a function 'Coercion' between two other 'Coercion's
+mkFunCoercion :: Coercion -> Coercion -> Coercion
+mkFunCoercion co1 co2 = mkFunTy co1 co2
 
 -- | Make a 'Coercion' which binds a variable within an inner 'Coercion'
 mkForAllCoercion :: Var -> Coercion -> Coercion
 -- note that a TyVar should be used here, not a CoVar (nor a TcTyVar)
 mkForAllCoercion tv  co  = ASSERT ( isTyVar tv ) mkForAllTy tv co
 
--- | Make a function 'Coercion' between two other 'Coercion's
-mkFunCoercion :: Coercion -> Coercion -> Coercion
-mkFunCoercion    co1 co2 = mkFunTy co1 co2
-
 
 -------------------------------
 
 mkSymCoercion :: Coercion -> Coercion
--- ^ Create a symmetric version of the given 'Coercion' that asserts equality between
--- the same types but in the other "direction", so a kind of @t1 ~ t2@ becomes the
--- kind @t2 ~ t1@.
+-- ^ Create a symmetric version of the given 'Coercion' that asserts equality
+-- between the same types but in the other "direction", so a kind of @t1 ~ t2@ 
+-- becomes the kind @t2 ~ t1@.
 --
--- This function attempts to simplify the generated 'Coercion' by removing redundant applications
--- of @sym@. This is done by pushing this new @sym@ down into the 'Coercion' and exploiting the fact that 
--- @sym (sym co) = co@.
+-- This function attempts to simplify the generated 'Coercion' by removing 
+-- redundant applications of @sym@. This is done by pushing this new @sym@ 
+-- down into the 'Coercion' and exploiting the fact that @sym (sym co) = co@.
 mkSymCoercion co      
   | Just co' <- coreView co = mkSymCoercion co'
 
@@ -576,13 +584,17 @@ coreEqCoercion = coreEqType
 -- 2. The identity coercion
 data CoercionI = IdCo | ACo Coercion
 
-isIdentityCoercion :: CoercionI -> Bool
-isIdentityCoercion IdCo = True
-isIdentityCoercion _    = False
+instance Outputable CoercionI where
+  ppr IdCo     = ptext (sLit "IdCo")
+  ppr (ACo co) = ppr co
+
+isIdentityCoI :: CoercionI -> Bool
+isIdentityCoI IdCo = True
+isIdentityCoI _    = False
 
 -- | Tests whether all the given 'CoercionI's represent the identity coercion
-allIdCos :: [CoercionI] -> Bool
-allIdCos = all isIdentityCoercion
+allIdCoIs :: [CoercionI] -> Bool
+allIdCoIs = all isIdentityCoI
 
 -- | For each 'CoercionI' in the input list, return either the 'Coercion' it
 -- contains or the corresponding 'Type' from the other list
@@ -611,8 +623,8 @@ mkTransCoI (ACo co1) (ACo co2) = ACo $ mkTransCoercion co1 co2
 -- | Smart constructor for type constructor application on 'CoercionI', see also 'mkAppCoercion'
 mkTyConAppCoI :: TyCon -> [Type] -> [CoercionI] -> CoercionI
 mkTyConAppCoI tyCon tys cois
-  | allIdCos cois = IdCo
-  | otherwise	  = ACo (TyConApp tyCon (zipCoArgs cois tys))
+  | allIdCoIs cois = IdCo
+  | otherwise	   = ACo (TyConApp tyCon (zipCoArgs cois tys))
 
 -- | Smart constructor for honest-to-god 'Coercion' application on 'CoercionI', see also 'mkAppCoercion'
 mkAppTyCoI :: Type -> CoercionI -> Type -> CoercionI -> CoercionI
@@ -641,8 +653,8 @@ fromACo (ACo co) = co
 -- > mkClassPPredCoI cls tys cois :: PredTy (cls tys) ~ PredTy (cls (tys `cast` cois))
 mkClassPPredCoI :: Class -> [Type] -> [CoercionI] -> CoercionI
 mkClassPPredCoI cls tys cois 
-  | allIdCos cois = IdCo
-  | otherwise     = ACo $ PredTy $ ClassP cls (zipCoArgs cois tys)
+  | allIdCoIs cois = IdCo
+  | otherwise      = ACo $ PredTy $ ClassP cls (zipCoArgs cois tys)
 
 -- | Smart constructor for implicit parameter 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI'
 mkIParamPredCoI :: (IPName Name) -> CoercionI -> CoercionI