[project @ 1998-04-09 10:06:39 by simonpj]

Fix bug in TcInstDecls causing zonkIdOccs

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index d7da495..5ab2d1d 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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}