X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FbasicTypes%2FMkId.lhs;h=d1d7a020a74cc4925ee0d7362ac4e0eb39a8c5e5;hb=c94408e522e5af3b79a5beadc7e6d15cee553ee7;hp=33482feff91a8d6c94346ae95e6fa9365471c6a3;hpb=d5bba9ee196f64a077e922680b16fe6f28fb79db;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 33482fe..d1d7a02 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -709,35 +709,23 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 -- body of the wrapper, namely
 --	e `cast` CoT [a]
 --
--- For non-recursive newtypes, GHC currently treats them like type
--- synonyms, so no cast is necessary.  This function is the only
--- place in the compiler that generates 
+-- If a coercion constructor is prodivided in the newtype, then we use
+-- it, otherwise the wrap/unwrap are both no-ops 
 --
 wrapNewTypeBody tycon args result_expr
---  | isRecursiveTyCon tycon	-- Recursive case; use a coerce
-  = Cast result_expr co
---  | otherwise
---  = result_expr
-  where
-    co = mkTyConApp (newTyConCo tycon) args
+  | Just co_con <- newTyConCo tycon
+  = Cast result_expr (mkTyConApp co_con args)
+  | otherwise
+  = result_expr
 
 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr
---  | isRecursiveTyCon tycon	-- Recursive case; use a coerce
-  = Cast result_expr sym_co
---  | otherwise
---  = result_expr
-  where
-    sym_co = mkSymCoercion co
-    co     = mkTyConApp (newTyConCo tycon) args
-
--- Old Definition of mkNewTypeBody
--- Used for both wrapping and unwrapping
---mkNewTypeBody tycon result_ty result_expr
---  | isRecursiveTyCon tycon	-- Recursive case; use a coerce
---  = Note (Coerce result_ty (exprType result_expr)) result_expr
---  | otherwise			-- Normal case
---  = result_expr
+  | Just co_con <- newTyConCo tycon
+  = Cast result_expr (mkSymCoercion (mkTyConApp co_con args))
+  | otherwise
+  = result_expr
+
+
 \end{code}