X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FCoercion.lhs;h=eda45a3efb99b57655c1f3fb6aaf946bcf78dbff;hb=d7b56effafe21561a127b318c9cfea2897a053c0;hp=59a1a15c03607ebabbd3adf1f41df72ceed10903;hpb=5e5310b3cb4f78e30cc7b90879eb016e97c214cb;p=ghc-hetmet.git diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 59a1a15..eda45a3 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, @@ -46,7 +46,7 @@ module Coercion ( -- * CoercionI CoercionI(..), - isIdentityCoercion, + isIdentityCoI, mkSymCoI, mkTransCoI, mkTyConAppCoI, mkAppTyCoI, mkFunTyCoI, mkForAllTyCoI, @@ -184,6 +184,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) @@ -576,13 +582,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 +621,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 +651,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