X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=411a7c1bdb129fa3fb78d75fa3620fcc369b2a80;hb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;hp=eeb8f26fc4ce9a45cbaa2a55828357217efbf71e;hpb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index eeb8f26..411a7c1 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -46,14 +46,15 @@ import Id		( idType, dataConArgTys, mkTupleCon,
 			  pprId{-ToDo:rm-},
 			  DataCon(..), DictVar(..), Id(..), GenId )
 import Literal		( Literal(..) )
-import TyCon		( mkTupleTyCon )
+import TyCon		( mkTupleTyCon, isNewTyCon, tyConDataCons )
 import Type		( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
-			  isUnboxedType, applyTyCon, getAppDataTyCon
+			  isUnboxedType, applyTyCon,
+			  getAppDataTyCon, getAppTyCon
 			)
 import UniqSet		( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
 import Util		( panic, assertPanic, pprTrace{-ToDo:rm-} )
 import PprCore{-ToDo:rm-}
-import PprType--ToDo:rm
+--import PprType--ToDo:rm
 import Pretty--ToDo:rm
 import TyVar--ToDo:rm
 import Unique--ToDo:rm
@@ -138,6 +139,11 @@ mkCoAlgCaseMatchResult :: Id				-- Scrutinee
 		    -> DsM MatchResult
 
 mkCoAlgCaseMatchResult var alts
+  | isNewTyCon tycon		-- newtype case; use a let
+  = ASSERT( newtype_sanity )
+    returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
+
+  | otherwise			-- datatype case  
   =	    -- Find all the constructors in the type which aren't
 	    -- explicitly mentioned in the alternatives:
     case un_mentioned_constructors of
@@ -171,8 +177,21 @@ mkCoAlgCaseMatchResult var alts
 				      (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
 				      cxt1)
   where
+	-- Common stuff
     scrut_ty = idType var
-    (tycon, tycon_arg_tys, data_cons) = pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $ getAppDataTyCon scrut_ty
+    (tycon, tycon_arg_tys) = --pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $ 
+			     getAppTyCon scrut_ty
+
+	-- Stuff for newtype
+    (con_id, arg_ids, match_result) = head alts
+    arg_id 	   		    = head arg_ids
+    coercion_bind		    = NonRec arg_id (Coerce (CoerceOut con_id) 
+							    (idType arg_id)
+							    (Var var))
+    newtype_sanity		    = null (tail alts) && null (tail arg_ids)
+
+	-- Stuff for data types
+    data_cons = tyConDataCons tycon
 
     un_mentioned_constructors
       = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
@@ -403,7 +422,7 @@ The general case:
 
 \begin{code}
 mkTupleBind tyvars dicts local_global_prs tuple_expr
-  = pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
+  = --pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
 
     newSysLocalDs tuple_var_ty	`thenDs` \ tuple_var ->