[project @ 2001-05-18 08:46:18 by simonpj]

[ghc-hetmet.git] / ghc / compiler / rename / RnBinds.lhs

diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index 19d2355..33dacd7 100644 (file)
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -11,7 +11,7 @@ they may be affected by renaming (which isn't fully worked out yet).
 \begin{code}
 module RnBinds (
        rnTopBinds, rnTopMonoBinds,
-       rnMethodBinds, renameSigs,
+       rnMethodBinds, renameSigs, renameSigsFVs,
        rnBinds,
        unknownSigErr
    ) where
@@ -29,11 +29,10 @@ import RnExpr               ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
 import RnEnv           ( bindLocatedLocalsRn, lookupBndrRn, 
                          lookupGlobalOccRn, lookupSigOccRn,
                          warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
-                         FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV
                        )
 import CmdLineOpts     ( DynFlag(..) )
 import Digraph         ( stronglyConnComp, SCC(..) )
-import Name            ( OccName, Name, nameOccName )
+import Name            ( Name, nameOccName, nameSrcLoc )
 import NameSet
 import RdrName         ( RdrName, rdrNameOcc )
 import BasicTypes      ( RecFlag(..) )
@@ -70,8 +69,6 @@ within one @MonoBinds@, so that unique-Int plumbing is done explicitly
 
 \begin{code}
 type VertexTag = Int
-type Cycle     = [VertexTag]
-type Edge      = (VertexTag, VertexTag)
 \end{code}
 
 %************************************************************************
@@ -169,17 +166,17 @@ rnTopMonoBinds mbinds sigs
     let
        bndr_name_set = mkNameSet binder_names
     in
-    renameSigs (okBindSig bndr_name_set) sigs  `thenRn` \ (siglist, sig_fvs) ->
-    doptRn Opt_WarnMissingSigs                 `thenRn` \ warnMissing ->
-    let
-       type_sig_vars   = [n | Sig n _ _ <- siglist]
-       un_sigd_binders | warnMissing = nameSetToList (delListFromNameSet 
-                                                          bndr_name_set type_sig_vars)
-                       | otherwise   = []
-    in
-    mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders  `thenRn_`
+    renameSigsFVs (okBindSig bndr_name_set) sigs       `thenRn` \ (siglist, sig_fvs) ->
 
-    rn_mono_binds siglist mbinds                  `thenRn` \ (final_binds, bind_fvs) ->
+    ifOptRn Opt_WarnMissingSigs (
+       let
+           type_sig_vars   = [n | Sig n _ _ <- siglist]
+           un_sigd_binders = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars)
+       in
+        mapRn_ missingSigWarn un_sigd_binders
+    )                                          `thenRn_`
+
+    rn_mono_binds siglist mbinds               `thenRn` \ (final_binds, bind_fvs) ->
     returnRn (final_binds, bind_fvs `plusFV` sig_fvs)
   where
     binder_rdr_names = collectMonoBinders mbinds
@@ -226,7 +223,7 @@ rnMonoBinds mbinds sigs     thing_inside -- Non-empty monobinds
        binder_set = mkNameSet new_mbinders
     in
        -- Rename the signatures
-    renameSigs (okBindSig binder_set) sigs     `thenRn` \ (siglist, sig_fvs) ->
+    renameSigsFVs (okBindSig binder_set) sigs  `thenRn` \ (siglist, sig_fvs) ->
 
        -- Report the fixity declarations in this group that 
        -- don't refer to any of the group's binders.
@@ -240,7 +237,7 @@ rnMonoBinds mbinds sigs     thing_inside -- Non-empty monobinds
     rn_mono_binds siglist mbinds          `thenRn` \ (binds, bind_fvs) ->
 
     -- Now do the "thing inside", and deal with the free-variable calculations
-    thing_inside binds                    `thenRn` \ (result,result_fvs) ->
+    thing_inside binds                            `thenRn` \ (result,result_fvs) ->
     let
        all_fvs        = result_fvs `plusFV` bind_fvs `plusFV` sig_fvs
        unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs)
@@ -266,8 +263,8 @@ This is done {\em either} by pass 3 (for the top-level bindings),
 \begin{code}
 rn_mono_binds :: [RenamedSig]          -- Signatures attached to this group
              -> RdrNameMonoBinds       
-             -> RnMS (RenamedHsBinds,  -- 
-                        FreeVars)      -- Free variables
+             -> RnMS (RenamedHsBinds,  -- Dependency analysed
+                      FreeVars)        -- Free variables
 
 rn_mono_binds siglist mbinds
   =
@@ -388,7 +385,7 @@ rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn)
     returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name)
   where
        -- Gruesome; bring into scope the correct members of the generic type variables
-       -- See comments in RnSource.rnDecl(ClassDecl)
+       -- See comments in RnSource.rnSourceDecl(ClassDecl)
     rn_match match@(Match _ (TypePatIn ty : _) _ _)
        = extendTyVarEnvFVRn gen_tvs (rnMatch match)
        where
@@ -479,12 +476,15 @@ At the moment we don't gather free-var info from the types in
 signatures.  We'd only need this if we wanted to report unused tyvars.
 
 \begin{code}
+renameSigsFVs ok_sig sigs
+  = renameSigs ok_sig sigs     `thenRn` \ sigs' ->
+    returnRn (sigs', hsSigsFVs sigs')
+
 renameSigs ::  (RenamedSig -> Bool)            -- OK-sig predicate
            -> [RdrNameSig]
-           -> RnMS ([RenamedSig], FreeVars)
+           -> RnMS [RenamedSig]
 
-renameSigs ok_sig []
-  = returnRn ([], emptyFVs)    -- Common shortcut
+renameSigs ok_sig [] = returnRn []
 
 renameSigs ok_sig sigs
   =     -- Rename the signatures
@@ -500,7 +500,7 @@ renameSigs ok_sig sigs
        (goods, bads)    = partition ok_sig in_scope
     in
     mapRn_ unknownSigErr bads                  `thenRn_`
-    returnRn (goods, hsSigFVs goods)
+    returnRn goods
 
 -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
 -- because this won't work for:
@@ -546,29 +546,6 @@ renameSig (NoInlineSig v p src_loc)
     returnRn (NoInlineSig new_v p src_loc)
 \end{code}
 
-\begin{code}
-renameIE :: (RdrName -> RnMS Name) -> IE RdrName -> RnMS (IE Name, FreeVars)
-renameIE lookup_occ_nm (IEVar v)
-  = lookup_occ_nm v            `thenRn` \ new_v ->
-    returnRn (IEVar new_v, unitFV new_v)
-
-renameIE lookup_occ_nm (IEThingAbs v)
-  = lookup_occ_nm v            `thenRn` \ new_v ->
-    returnRn (IEThingAbs new_v, unitFV new_v)
-
-renameIE lookup_occ_nm (IEThingAll v)
-  = lookup_occ_nm v            `thenRn` \ new_v ->
-    returnRn (IEThingAll new_v, unitFV new_v)
-
-renameIE lookup_occ_nm (IEThingWith v vs)
-  = lookup_occ_nm v            `thenRn` \ new_v ->
-    mapRn lookup_occ_nm vs     `thenRn` \ new_vs ->
-    returnRn (IEThingWith new_v new_vs, plusFVs [ unitFV x | x <- new_v:new_vs ])
-
-renameIE lookup_occ_nm (IEModuleContents m)
-  = returnRn (IEModuleContents m, emptyFVs)
-\end{code}
-
 
 %************************************************************************
 %*                                                                     *
@@ -592,7 +569,8 @@ unknownSigErr sig
     (what_it_is, loc) = hsSigDoc sig
 
 missingSigWarn var
-  = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)]
+  = pushSrcLocRn (nameSrcLoc var) $
+    addWarnRn (sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)])
 
 methodBindErr mbind
  =  hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))