X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTyCon.lhs;h=1464fabcc7d3aa7223d99b4ed88546b3267f8b33;hb=27897431cf24d4bde04b15947440c7205f2d703c;hp=15be3e2cef672270d7177d5d55c94e79b9d33ede;hpb=53569e145c8ff8af89303742f261302fdcd98f04;p=ghc-hetmet.git

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 15be3e2..1464fab 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -14,7 +14,8 @@ module TyCon(
 	SynTyConRhs(..),
 
 	isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
-	isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
+	isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isClosedNewTyCon,
+	isPrimTyCon, 
 	isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
 	assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss,
 	isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
@@ -550,13 +551,23 @@ isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})
 	OpenNewTyCon  -> False
 	NewTyCon {}   -> False
 	AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
-
 isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
 isDataTyCon other = False
 
 isNewTyCon :: TyCon -> Bool
-isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True 
-isNewTyCon other			       = False
+isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of
+					   OpenNewTyCon -> True
+					   NewTyCon {}  -> True
+					   _	        -> False
+isNewTyCon other			= False
+
+-- This is an important refinement as typical newtype optimisations do *not*
+-- hold for newtype families.  Why?  Given a type `T a', if T is a newtype
+-- family, there is no unique right hand side by which `T a' can be replaced
+-- by a cast.
+--
+isClosedNewTyCon :: TyCon -> Bool
+isClosedNewTyCon tycon = isNewTyCon tycon && not (isOpenTyCon tycon)
 
 isProductTyCon :: TyCon -> Bool
 -- A "product" tycon
@@ -746,7 +757,10 @@ newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }})
 newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
 
 newTyConCo :: TyCon -> Maybe TyCon
-newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co
+newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }})
+  = co
+newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = OpenNewTyCon})
+  = Nothing
 newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
 
 tyConPrimRep :: TyCon -> PrimRep