X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FCoercion.lhs;h=02d92d73e13ffc8b7accb4ddf41984277b288f9b;hb=1c5499d4d5d506ce0cc971e98c09bfbf7bc290a1;hp=98b5a0721b59ae03c0c8af44ad4a228fd9a2de17;hpb=701797c3f724090508e06ded276723edfa431ab4;p=ghc-hetmet.git

diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 98b5a07..02d92d7 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -27,7 +27,7 @@ module Coercion (
         mkForAllCoercion, mkFunCoercion, mkInstsCoercion, mkUnsafeCoercion,
         mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
 
-        splitNewTypeRepCo_maybe, decomposeCo,
+        splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo,
 
         unsafeCoercionTyCon, symCoercionTyCon,
         transCoercionTyCon, leftCoercionTyCon, 
@@ -413,24 +413,37 @@ 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}
 
 
@@ -440,11 +453,10 @@ splitNewTypeRepCo_maybe other = Nothing
 
 
 \begin{code}
-
 	-- CoercionI is either 
 	--	(a) proper coercion
 	--	(b) the identity coercion
-data CoercionI     = IdCo     | ACo Coercion
+data CoercionI = IdCo | ACo Coercion
 
 isIdentityCoercion :: CoercionI -> Bool
 isIdentityCoercion IdCo = True