From 171d4582f4b9a8e0f11f8738079accbb22bafdcb Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Mon, 25 Sep 2006 12:13:51 +0000
Subject: [PATCH] Fix newtype deriving properly (un-doing Audreys patch)

The newtype-deriving mechanism generates a HsSyn case expression looking
like this
	case (d `cast` co) of { ... }
That is, the case expression scrutinises a dictionary.  This is
otherwise never seen in HsSyn, and it made the desugarer
(Check.get_unused_cons) crash in tcTyConAppTyCon.

It would really be better to generate Core in TcInstDecls (the newtype
deriving part) but I'm not going to do that today.  Instead, I made
Check.get_unused_cons a bit more robust.

Audrey tried to fix this over the weekend, but her fix was, alas, utterly
bogus, which caused mysterious failures later.  I completely undid this
change.

Anyway it should work now!
---
 compiler/deSugar/Check.lhs        |   12 ++++++------
 compiler/typecheck/TcClassDcl.lhs |    2 ++
 compiler/typecheck/TcInstDcls.lhs |    3 +++
 compiler/typecheck/TcType.lhs     |   18 +++++++-----------
 4 files changed, 18 insertions(+), 17 deletions(-)

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 7562083..85b8f9d 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -438,12 +438,12 @@ mb_neg (Just _) v = -v
 get_unused_cons :: [Pat Id] -> [DataCon]
 get_unused_cons used_cons = unused_cons
      where
-       (ConPatOut { pat_ty = ty }) = head used_cons
-       ty_con 		      = tcTyConAppTyCon ty		-- Newtype observable
-       all_cons        	      = tyConDataCons ty_con
-       used_cons_as_id 	      = map (\ (ConPatOut{ pat_con = L _ d}) -> d) used_cons
-       unused_cons     	      = uniqSetToList
-		 (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) 
+       (ConPatOut { pat_con = l_con, pat_ty = ty }) = head used_cons
+       ty_con 	       = dataConTyCon (unLoc l_con)	-- Newtype observable
+       all_cons        = tyConDataCons ty_con
+       used_cons_as_id = map (\ (ConPatOut{ pat_con = L _ d}) -> d) used_cons
+       unused_cons     = uniqSetToList
+			 (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) 
 
 all_vars :: [Pat Id] -> Bool
 all_vars []             = True
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index e9e5843..9d0fb13 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -632,6 +632,8 @@ get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
 	--	f {| a+b |} ... = ...
 	--	f {| x+y |} ... = ...
 	-- Then at this point we'll have an InstInfo for each
+	--
+	-- The class should be unary, which is why simpleInstInfoTyCon should be ok
     let
 	tc_inst_infos :: [(TyCon, InstInfo)]
 	tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 32b51d0..1be9ffc 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -571,6 +571,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
 	           the_rhs = mkHsConApp cls_data_con cls_inst_tys $
 			     map HsVar (sc_dict_ids ++ op_ids)
 
+		-- Warning: this HsCase scrutinises a value with a PredTy, which is
+		--	    never otherwise seen in Haskell source code. It'd be
+		-- 	    nicer to generate Core directly!
 	     ; return (HsCase (noLoc coerced_rep_dict) $
 		       MatchGroup [the_match] (mkFunTy inst_head_ty inst_head_ty)) }
 	where
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index c10c2eb..21375a9 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -1,4 +1,4 @@
-
+%
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[TcType]{Types used in the typechecker}
@@ -698,10 +698,14 @@ tcMultiSplitSigmaTy sigma
 
 -----------------------
 tcTyConAppTyCon :: Type -> TyCon
-tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
+tcTyConAppTyCon ty = case tcSplitTyConApp_maybe ty of
+			Just (tc, _) -> tc
+			Nothing	     -> pprPanic "tcTyConAppTyCon" (pprType ty)
 
 tcTyConAppArgs :: Type -> [Type]
-tcTyConAppArgs ty = snd (tcSplitTyConApp ty)
+tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of
+			Just (_, args) -> args
+			Nothing	       -> pprPanic "tcTyConAppArgs" (pprType ty)
 
 tcSplitTyConApp :: Type -> (TyCon, [Type])
 tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
@@ -712,17 +716,9 @@ tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'
 tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 tcSplitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
-tcSplitTyConApp_maybe (AppTy arg res)   = Just (funTyCon, [arg,res])
 	-- Newtypes are opaque, so they may be split
 	-- However, predicates are not treated
 	-- as tycon applications by the type checker
-
--- XXX - 2006-09-24: This case is hard-coded in (rendering predicates opaque as well)
---       to make the newly reworked newtype-deriving work on the trivial case:
---              newtype T = T () deriving (Eq, Ord)
---       Please remove this if the newtype-deriving scheme no longer produces a PredTy.
-tcSplitTyConApp_maybe (PredTy (ClassP _ [ty']))   = tcSplitTyConApp_maybe ty'
-
 tcSplitTyConApp_maybe other	      	= Nothing
 
 -----------------------
-- 
1.7.10.4