[project @ 2003-02-21 13:02:58 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcBinds.lhs

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 1dee32a..7a2ef3f 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -4,8 +4,7 @@
 \section[TcBinds]{TcBinds}
 
 \begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds,
-                tcSpecSigs, tcBindWithSigs ) where
+module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
 
 #include "HsVersions.h"
 
@@ -89,6 +88,9 @@ dictionaries, which we resolve at the module level.
 
 \begin{code}
 tcTopBinds :: RenamedHsBinds -> TcM (TcMonoBinds, TcLclEnv)
+       -- Note: returning the TcLclEnv is more than we really
+       --       want.  The bit we care about is the local bindings
+       --       and the free type variables thereof
 tcTopBinds binds
   = tc_binds_and_then TopLevel glue binds      $
     getLclEnv                                  `thenM` \ env ->
@@ -150,39 +152,26 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
        --      c) the scope of the binding group (the "in" part)
       tcAddScopedTyVars (collectSigTysFromMonoBinds bind)      $
 
-       -- TYPECHECK THE SIGNATURES
-      mappM tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenM` \ tc_ty_sigs ->
+      tcBindWithSigs top_lvl bind sigs is_rec  `thenM` \ (poly_binds, poly_ids) ->
   
-
-      tcBindWithSigs top_lvl bind 
-                    tc_ty_sigs sigs is_rec     `thenM` \ (poly_binds, poly_ids) ->
-  
-      getLIE (
-         -- Extend the environment to bind the new polymorphic Ids
-         tcExtendLocalValEnv poly_ids                  $
-  
-         -- Build bindings and IdInfos corresponding to user pragmas
-         tcSpecSigs sigs               `thenM` \ prag_binds ->
-
-         -- Now do whatever happens next, in the augmented envt
-         do_next                       `thenM` \ thing ->
-
-         returnM (prag_binds, thing)
-      )          `thenM` \ ((prag_binds, thing), lie) ->
-
       case top_lvl of
-
-               -- For the top level don't bother will all this bindInstsOfLocalFuns stuff
-               -- All the top level things are rec'd together anyway, so it's fine to
-               -- leave them to the tcSimplifyTop, and quite a bit faster too
-       TopLevel
-               -> extendLIEs lie       `thenM_`
+       TopLevel        -- For the top level don't bother will all this
+                       --  bindInstsOfLocalFuns stuff. All the top level 
+                       -- things are rec'd together anyway, so it's fine to
+                       -- leave them to the tcSimplifyTop, and quite a bit faster too
+                       --
+                       -- Subtle (and ugly) point: furthermore at top level we
+                       -- return the TcLclEnv, which contains the LIE var; we
+                       -- don't want to return the wrong one!
+               -> tc_body poly_ids                     `thenM` \ (prag_binds, thing) ->
                   returnM (combiner (mkMonoBind Recursive (poly_binds `andMonoBinds` prag_binds)) 
                                     thing)
 
-       NotTopLevel
-               -> bindInstsOfLocalFuns lie poly_ids    `thenM` \ lie_binds ->
+       NotTopLevel     -- For nested bindings we must
+               -> getLIE (tc_body poly_ids)            `thenM` \ ((prag_binds, thing), lie) ->
+
                        -- Create specialisations of functions bound here
+                   bindInstsOfLocalFuns lie poly_ids   `thenM` \ lie_binds ->
 
                        -- We want to keep non-recursive things non-recursive
                        -- so that we desugar unlifted bindings correctly
@@ -202,6 +191,18 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
                                -- aren't guaranteed in dependency order (though we could change
                                -- that); hence the Recursive marker.
                        thing)
+  where
+    tc_body poly_ids   -- Type check the pragmas and "thing inside"
+      =   -- Extend the environment to bind the new polymorphic Ids
+         tcExtendLocalValEnv poly_ids                  $
+  
+         -- Build bindings and IdInfos corresponding to user pragmas
+         tcSpecSigs sigs               `thenM` \ prag_binds ->
+
+         -- Now do whatever happens next, in the augmented envt
+         do_next                       `thenM` \ thing ->
+
+         returnM (prag_binds, thing)
 \end{code}
 
 
@@ -225,13 +226,18 @@ so all the clever stuff is in here.
 tcBindWithSigs 
        :: TopLevelFlag
        -> RenamedMonoBinds
-       -> [TcSigInfo]
        -> [RenamedSig]         -- Used solely to get INLINE, NOINLINE sigs
        -> RecFlag
        -> TcM (TcMonoBinds, [TcId])
 
-tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
-  = recoverM (
+tcBindWithSigs top_lvl mbind sigs is_rec
+  =    -- TYPECHECK THE SIGNATURES
+     recoverM (returnM []) (
+       mappM tcTySig [sig | sig@(Sig name _ _) <- sigs]
+     )                                         `thenM` \ tc_ty_sigs ->
+
+       -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
+   recoverM (
        -- If typechecking the binds fails, then return with each
        -- signature-less binder given type (forall a.a), to minimise subsequent
        -- error messages
@@ -244,6 +250,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
                            Just sig -> tcSigPolyId sig                 -- Signature
                            Nothing  -> mkLocalId name forall_a_a       -- No signature
        in
+       traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)   `thenM_`
        returnM (EmptyMonoBinds, poly_ids)
     )                                          $
 
@@ -285,10 +292,10 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
        poly_ids = [poly_id | (_, poly_id, _) <- exports]
        dict_tys = map idType zonked_dict_ids
 
-       inlines    = mkNameSet [name | InlineSig True name _ loc <- inline_sigs]
+       inlines    = mkNameSet [name | InlineSig True name _ loc <- sigs]
                        -- Any INLINE sig (regardless of phase control) 
                        -- makes the RHS look small
-        inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- inline_sigs, 
+        inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- sigs, 
                                                  not (isAlwaysActive phase)]
                        -- Set the IdInfo field to control the inline phase
                        -- AlwaysActive is the default, so don't bother with them