From 618a704d4c3a1ebcf3b5eba7b16268695f02a369 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 5 Oct 2004 07:46:41 +0000
Subject: [PATCH] [project @ 2004-10-05 07:46:41 by simonpj] Report bogus
 strictness annotation on newtype

---
 ghc/compiler/typecheck/TcTyClsDecls.lhs |   19 +++++++++++++++++--
 1 file changed, 17 insertions(+), 2 deletions(-)

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index e4bc357..a99aa2f 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -419,7 +419,21 @@ tcConDecl :: Bool 		-- True <=> -funbox-strict_fields
 	  -> NewOrData -> TyCon -> [TyVar]
 	  -> ConDecl Name -> TcM DataCon
 
-tcConDecl unbox_strict new_or_data tycon tc_tvs
+tcConDecl unbox_strict NewType tycon tc_tvs	-- Newtypes
+	  (ConDecl name ex_tvs ex_ctxt details)
+  = ASSERT( null ex_tvs && null (unLoc ex_ctxt) )	
+    do	{ let tc_datacon field_lbls arg_ty
+		= do { arg_ty' <- tcHsKindedType arg_ty	-- No bang on newtype
+		     ; buildDataCon (unLoc name) False {- Prefix -} 
+				    True {- Vanilla -} [NotMarkedStrict]
+		    		    (map unLoc field_lbls)
+			   	    tc_tvs [] [arg_ty']
+				    tycon (mkTyVarTys tc_tvs) }
+	; case details of
+	    PrefixCon [arg_ty] -> tc_datacon [] arg_ty
+	    RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty }
+
+tcConDecl unbox_strict DataType tycon tc_tvs	-- Ordinary data types
 	  (ConDecl name ex_tvs ex_ctxt details)
   = tcTyVarBndrs ex_tvs		$ \ ex_tvs' -> do 
     { ex_ctxt' <- tcHsKindedContext ex_ctxt
@@ -444,7 +458,7 @@ tcConDecl unbox_strict new_or_data tycon tc_tvs
 				 ; let { (field_names, btys) = unzip fields }
 				 ; tc_datacon False field_names btys } }
 
-tcConDecl unbox_strict new_or_data tycon tc_tvs
+tcConDecl unbox_strict DataType tycon tc_tvs	-- GADTs
 	  decl@(GadtDecl name con_ty)
   = do	{ traceTc (text "tcConDecl"  <+> ppr name)
 	; (tvs, theta, bangs, arg_tys, tc, res_tys) <- tcLHsConSig con_ty
@@ -466,6 +480,7 @@ tcConDecl unbox_strict new_or_data tycon tc_tvs
 		       [{- No field labels -}]
 		       tvs' theta arg_tys' tycon res_tys' }
 
+-------------------
 tcStupidTheta :: LHsContext Name -> [LConDecl Name] -> TcM (Maybe ThetaType)
 -- For GADTs we don't allow a context on the data declaration
 -- whereas for standard Haskell style data declarations, we do
-- 
1.7.10.4