From 4a8695c5772772ccf9a688d82a9ce4f772c2ad20 Mon Sep 17 00:00:00 2001
From: "bjorn@bringert.net" <unknown>
Date: Wed, 20 Sep 2006 22:39:17 +0000
Subject: [PATCH] Merged stand-alone deriving with FC stuff.

---
 compiler/parser/Parser.y.pp       |    6 ++++--
 compiler/typecheck/TcDeriv.lhs    |    6 +++++-
 compiler/typecheck/TcInstDcls.lhs |   15 +++++++++------
 compiler/typecheck/TcSimplify.lhs |    2 +-
 compiler/typecheck/TcType.lhs     |    1 +
 5 files changed, 20 insertions(+), 10 deletions(-)

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index a72b47b..a57be91 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -456,8 +456,10 @@ topdecl :: { OrdList (LHsDecl RdrName) }
   	: cl_decl			{ unitOL (L1 (TyClD (unLoc $1))) }
   	| ty_decl			{ unitOL (L1 (TyClD (unLoc $1))) }
 	| 'instance' inst_type where
-		{ let (binds,sigs) = cvBindsAndSigs (unLoc $3)
-		  in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) }
+		{ let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3)
+		  in unitOL (L (comb3 $1 $2 $3) 
+			    (InstD (InstDecl $2 binds sigs ats))) }
+        | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
 	| 'default' '(' comma_types0 ')'	{ unitOL (LL $ DefD (DefaultDecl $3)) }
 	| 'foreign' fdecl			{ unitOL (LL (unLoc $2)) }
 	| '{-# DEPRECATED' deprecations '#-}'	{ $2 }
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 033e399..776199f 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -386,7 +386,11 @@ makeDerivEqns overlap_flag tycl_decls deriv_decls
         mk_eqn_help loc orig gla_exts new_or_data tycon deriv_tvs clas tys
 
     ------------------------------------------------------------------
-    mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys
+    -- data/newtype T a = ... deriving( C t1 t2 )
+    --   leads to a call to mk_eqn_help with
+    --		tycon = T, deriv_tvs = ftv(t1,t2), clas = C, tys = [t1,t2]
+
+    mk_eqn_help loc orig gla_exts DataType tycon deriv_tvs clas tys
       | Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys
       = bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err)
       | otherwise 
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 3236b67..468d9a9 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -179,16 +179,19 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
 	        -- (3) Instances from generic class declarations
        ; generic_inst_info <- getGenericInstances clas_decls
 
-	-- (3) Compute instances from "deriving" clauses; 
-	-- This stuff computes a context for the derived instance decl, so it
-	-- needs to know about all the instances possible; hence inst_env4
-    tcDeriving tycl_decls	`thenM` \ (deriv_inst_info, deriv_binds) ->
-    addInsts deriv_inst_info	$
+	        -- Next, construct the instance environment so far, consisting
+	        -- of 
+		--   a) local instance decls
+		--   b) generic instances
+		--   c) local family instance decls
+       ; addInsts local_info         $ do {
+       ; addInsts generic_inst_info  $ do {
+       ; addFamInsts at_idx_tycon    $ do {
 
 	        -- (4) Compute instances from "deriving" clauses; 
 		-- This stuff computes a context for the derived instance
 		-- decl, so it needs to know about all the instances possible
-       ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls
+       ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls deriv_decls
        ; addInsts deriv_inst_info   $ do {
 
        ; gbl_env <- getGblEnv
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 4c6c0d5..ffd88b8 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -2162,7 +2162,7 @@ tcSimplifyDeriv orig tc tyvars theta
 	-- The main loop may do unification, and that may crash if 
 	-- it doesn't see a TcTyVar, so we have to instantiate. Sigh
 	-- ToDo: what if two of them do get unified?
-    newDicts DerivOrigin (substTheta tenv theta)	`thenM` \ wanteds ->
+    newDictBndrsO orig (substTheta tenv theta)	`thenM` \ wanteds ->
     simpleReduceLoop doc reduceMe wanteds		`thenM` \ (frees, _, irreds) ->
     ASSERT( null frees )			-- reduceMe never returns Free
 
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 3f1810f..cd4c4c7 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -673,6 +673,7 @@ tcSplitPhiTy ty = split ty ty []
 	| Just p <- tcSplitPredTy_maybe arg = split res res (p:ts)
   split orig_ty ty		ts = (reverse ts, orig_ty)
 
+tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
 tcSplitSigmaTy ty = case tcSplitForAllTys ty of
 			(tvs, rho) -> case tcSplitPhiTy rho of
 					(theta, tau) -> (tvs, theta, tau)
-- 
1.7.10.4