include bindisttest in source distributions (fixes srcdist)

[ghc-hetmet.git] / compiler / types / Coercion.lhs

diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 49ae740..02d92d7 100644 (file)
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -27,11 +27,21 @@ module Coercion (
         mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion,
         mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
 
-        splitNewTypeRepCo_maybe, decomposeCo,
+        splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo,
 
         unsafeCoercionTyCon, symCoercionTyCon,
         transCoercionTyCon, leftCoercionTyCon, 
-        rightCoercionTyCon, instCoercionTyCon -- needed by TysWiredIn
+        rightCoercionTyCon, instCoercionTyCon, -- needed by TysWiredIn
+
+       -- CoercionI
+       CoercionI(..),
+       isIdentityCoercion,
+       mkSymCoI, mkTransCoI, 
+       mkTyConAppCoI, mkAppTyCoI, mkFunTyCoI,
+       mkNoteTyCoI, mkForAllTyCoI,
+       fromCoI,
+       mkClassPPredCoI, mkIParamPredCoI, mkEqPredCoI,
+
        ) where 
 
 #include "HsVersions.h"
@@ -39,6 +49,7 @@ module Coercion (
 import TypeRep
 import Type
 import TyCon
+import Class
 import Var
 import Name
 import OccName
@@ -402,22 +413,123 @@ unsafeCoercionTyConName = mkCoConName FSLIT("CoUnsafe") unsafeCoercionTyConKey u
 
 
 
+instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, CoercionI)
+-- instNewTyCon_maybe T ts
+--     = Just (rep_ty, co)     if   co : T ts ~ rep_ty
+instNewTyCon_maybe tc tys
+  | Just (tvs, ty, mb_co_tc) <- unwrapNewTyCon_maybe tc
+  = ASSERT( tys `lengthIs` tyConArity tc )
+    Just (substTyWith tvs tys ty, 
+         case mb_co_tc of
+          Nothing    -> IdCo
+          Just co_tc -> ACo (mkTyConApp co_tc tys))
+  | otherwise
+  = Nothing
+
 -- this is here to avoid module loops
 splitNewTypeRepCo_maybe :: Type -> Maybe (Type, Coercion)  
 -- Sometimes we want to look through a newtype and get its associated coercion
 -- It only strips *one layer* off, so the caller will usually call itself recursively
 -- Only applied to types of kind *, hence the newtype is always saturated
+--    splitNewTypeRepCo_maybe ty
+--     = Just (ty', co)  if   co : ty ~ ty'
+-- Returns Nothing for non-newtypes or fully-transparent newtypes
 splitNewTypeRepCo_maybe ty 
   | Just ty' <- coreView ty = splitNewTypeRepCo_maybe ty'
 splitNewTypeRepCo_maybe (TyConApp tc tys)
-  | isClosedNewTyCon tc 
-  = ASSERT( tys `lengthIs` tyConArity tc )     -- splitNewTypeRepCo_maybe only be applied 
-                                                --     to *types* (of kind *)
-        case newTyConRhs tc of
-         (tvs, rep_ty) -> 
-              ASSERT( length tvs == length tys )
-             Just (substTyWith tvs tys rep_ty, mkTyConApp co_con tys)
-  where
-    co_con = maybe (pprPanic "splitNewTypeRepCo_maybe" (ppr tc)) id (newTyConCo_maybe tc)
-splitNewTypeRepCo_maybe other = Nothing
+  | Just (ty', coi) <- instNewTyCon_maybe tc tys
+  = case coi of
+       ACo co -> Just (ty', co)
+       IdCo   -> panic "splitNewTypeRepCo_maybe"
+                       -- This case handled by coreView
+splitNewTypeRepCo_maybe other 
+  = Nothing
+\end{code}
+
+
+--------------------------------------
+-- CoercionI smart constructors
+--     lifted smart constructors of ordinary coercions
+
+
+\begin{code}
+       -- CoercionI is either 
+       --      (a) proper coercion
+       --      (b) the identity coercion
+data CoercionI = IdCo | ACo Coercion
+
+isIdentityCoercion :: CoercionI -> Bool
+isIdentityCoercion IdCo = True
+isIdentityCoercion _    = False
+
+mkSymCoI :: CoercionI -> CoercionI
+mkSymCoI IdCo = IdCo
+mkSymCoI (ACo co) = ACo $ mkCoercion symCoercionTyCon [co] 
+                               -- the smart constructor
+                               -- is too smart with tyvars
+
+mkTransCoI :: CoercionI -> CoercionI -> CoercionI
+mkTransCoI IdCo aco = aco
+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)
+
+mkAppTyCoI :: Type -> CoercionI -> Type -> CoercionI -> CoercionI
+mkAppTyCoI ty1 IdCo ty2 IdCo = IdCo
+mkAppTyCoI ty1 coi1 ty2 coi2 =
+       ACo $ AppTy (fromCoI coi1 ty1) (fromCoI coi2 ty2)
+
+mkFunTyCoI :: Type -> CoercionI -> Type -> CoercionI -> CoercionI
+mkFunTyCoI ty1 IdCo ty2 IdCo = IdCo
+mkFunTyCoI ty1 coi1 ty2 coi2 =
+       ACo $ FunTy (fromCoI coi1 ty1) (fromCoI coi2 ty2)
+
+mkNoteTyCoI :: TyNote -> CoercionI -> CoercionI
+mkNoteTyCoI _ IdCo = IdCo
+mkNoteTyCoI note (ACo co) = ACo $ NoteTy note co
+
+mkForAllTyCoI :: TyVar -> CoercionI -> CoercionI
+mkForAllTyCoI _ IdCo = IdCo
+mkForAllTyCoI tv (ACo co) = ACo $ ForAllTy tv co
+
+fromCoI IdCo ty     = ty
+fromCoI (ACo co) ty = 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)
+
+mkIParamPredCoI :: (IPName Name) -> CoercionI -> CoercionI 
+mkIParamPredCoI ipn IdCo     = IdCo
+mkIParamPredCoI ipn (ACo co) = ACo $ PredTy $ IParam ipn co
+
+mkEqPredCoI :: Type -> CoercionI -> Type -> CoercionI -> CoercionI
+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}
+