From 2da5e2d4ecab3eb91cd9088e156651b610753d4f Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 9 Apr 1998 10:06:45 +0000
Subject: [PATCH] [project @ 1998-04-09 10:06:39 by simonpj] Fix bug in
 TcInstDecls causing zonkIdOccs

---
 ghc/compiler/typecheck/TcBinds.lhs    |    2 +-
 ghc/compiler/typecheck/TcClassDcl.lhs |   15 +++++++++----
 ghc/compiler/typecheck/TcInstDcls.lhs |   38 ++++++++++++++++-----------------
 3 files changed, 31 insertions(+), 24 deletions(-)

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index d7da495..5ab2d1d 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -4,7 +4,7 @@
 \section[TcBinds]{TcBinds}
 
 \begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
+module TcBinds ( tcBindsAndThen, tcTopBindsAndThen, bindInstsOfLocalFuns,
 	         tcPragmaSigs, checkSigTyVars, tcBindWithSigs, 
 		 sigCtxt, TcSigInfo(..) ) where
 
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index acfc875..2482fe1 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -26,7 +26,9 @@ import TcEnv		( TcIdOcc(..), GlobalValueEnv, tcAddImportedIdInfo,
 			  tcLookupClass, tcLookupTyVar, 
 			  tcExtendGlobalTyVars, tcExtendLocalValEnv
 			)
-import TcBinds		( tcBindWithSigs, checkSigTyVars, sigCtxt, tcPragmaSigs, TcSigInfo(..) )
+import TcBinds		( tcBindWithSigs, bindInstsOfLocalFuns, 
+			  checkSigTyVars, sigCtxt, tcPragmaSigs, TcSigInfo(..)
+			)
 import TcKind		( unifyKinds, TcKind )
 import TcMonad
 import TcMonoType	( tcHsType, tcContext )
@@ -493,7 +495,7 @@ tcMethodBind clas origin inst_tys inst_tyvars
    in
    tcExtendLocalValEnv [meth_name] [meth_id] (
 	tcPragmaSigs meth_prags
-   )						`thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
+   )						`thenTc` \ (prag_info_fn, prag_binds1, prag_lie) ->
 
 	-- Check that the signatures match
    tcExtendGlobalTyVars inst_tyvars (
@@ -502,6 +504,11 @@ tcMethodBind clas origin inst_tys inst_tyvars
 		    NonRecursive prag_info_fn 	
    )							`thenTc` \ (binds, insts, _) ->
 
+	-- The prag_lie for a SPECIALISE pragma will mention the function
+	-- itself, so we have to simplify them away right now lest they float
+	-- outwards!
+   bindInstsOfLocalFuns prag_lie [meth_id]	`thenTc` \ (prag_lie', prag_binds2) ->
+
 	-- Now check that the instance type variables
 	-- (or, in the case of a class decl, the class tyvars)
 	-- have not been unified with anything in the environment
@@ -510,8 +517,8 @@ tcMethodBind clas origin inst_tys inst_tyvars
      checkSigTyVars inst_tyvars (idType meth_id)
    )							`thenTc_` 
 
-   returnTc (binds `AndMonoBinds` prag_binds, 
-	     insts `plusLIE` prag_lie, 
+   returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2, 
+	     insts `plusLIE` prag_lie', 
 	     meth)
  where
    sel_name = idName sel_id
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 2122b6f..a68c59a 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -381,10 +381,19 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
         methods_lie = plusLIEs insts_needed_s
     in
 
+	-- Ditto method bindings
+    tcAddErrCtxt methodCtxt (
+      tcSimplifyAndCheck
+		 (ptext SLIT("instance declaration context"))
+		 inst_tyvars_set			-- Local tyvars
+		 avail_insts
+		 methods_lie
+    )						 `thenTc` \ (const_lie1, lie_binds1) ->
+    
 	-- Check that we *could* construct the superclass dictionaries,
 	-- even though we are *actually* going to pass the superclass dicts in;
-	-- the check ensures that the caller will never have a problem building
-	-- them.
+	-- the check ensures that the caller will never have 
+	--a problem building them.
     tcAddErrCtxt superClassCtxt (
       tcSimplifyAndCheck
 		 (ptext SLIT("instance declaration context"))
@@ -395,26 +404,17 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
     						-- Ignore the result; we're only doing
 						-- this to make sure it can be done.
 
-	-- Ditto method bindings
-    tcAddErrCtxt methodCtxt (
-      tcSimplifyAndCheck
-		 (ptext SLIT("instance declaration context"))
-		 inst_tyvars_set			-- Local tyvars
-		 avail_insts
-		 methods_lie
-    )						 `thenTc_`
-    
-		-- Now do the simplification again, this time to get the
-		-- bindings; this time we use an enhanced "avails"
-		-- Ignore errors because they come from the *previous* tcSimplifys
+	-- Now do the simplification again, this time to get the
+	-- bindings; this time we use an enhanced "avails"
+	-- Ignore errors because they come from the *previous* tcSimplify
     discardErrsTc (
 	tcSimplifyAndCheck
 		 (ptext SLIT("instance declaration context"))
 		 inst_tyvars_set
 		 dfun_arg_dicts		-- NB! Don't include this_dict here, else the sc_dicts
 					-- get bound by just selecting from this_dict!!
-		 (sc_dicts `plusLIE` methods_lie `plusLIE` prag_lie)
-    )						 `thenTc` \ (const_lie, lie_binds) ->
+		 sc_dicts
+    )						 `thenTc` \ (const_lie2, lie_binds2) ->
 	
 
 	-- Create the result bindings
@@ -451,12 +451,12 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
 		 zonked_inst_tyvars
 		 dfun_arg_dicts_ids
 		 [(inst_tyvars', RealId final_dfun_id, this_dict_id)] 
-		 (lie_binds	`AndMonoBinds` 
+		 (lie_binds1	`AndMonoBinds` 
+		  lie_binds2	`AndMonoBinds`
 		  method_binds	`AndMonoBinds`
-		  prag_binds	`AndMonoBinds`
 		  dict_bind)
     in
-    returnTc (const_lie,
+    returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie,
 	      main_bind `AndMonoBinds` prag_binds)
 \end{code}
 
-- 
1.7.10.4