X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnBinds.lhs;h=9f7e690707cea9a1efcb5f78e2bbc52adaed998d;hb=8fc898cb0b722e72c08dce3acadbc4b2aa2249ff;hp=da97758d84647d875c5f103a305ee74f8aa1bb30;hpb=dbc254c3dcd64761015a3d1c191ac742caafbf4c;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index da97758..9f7e690 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -18,22 +18,25 @@ module RnBinds ( import HsSyn -import HsBinds ( eqHsSig, hsSigDoc ) +import HsBinds ( hsSigDoc, sigLoc, eqHsSig ) import RdrHsSyn import RnHsSyn import TcRnMonad import RnTypes ( rnHsSigType, rnHsType, rnPat ) import RnExpr ( rnMatch, rnGRHSs, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr, - lookupSigOccRn, bindPatSigTyVars, bindLocalFixities, + lookupSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV, + bindLocalFixities, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, ) import CmdLineOpts ( DynFlag(..) ) import Digraph ( SCC(..), stronglyConnComp ) import Name ( Name, nameOccName, nameSrcLoc ) import NameSet +import PrelNames ( isUnboundName ) import RdrName ( RdrName, rdrNameOcc ) -import BasicTypes ( RecFlag(..) ) +import BasicTypes ( RecFlag(..), TopLevelFlag(..), isTopLevel ) +import List ( unzip4 ) import Outputable \end{code} @@ -149,35 +152,18 @@ contains bindings for the binders of this particular binding. \begin{code} rnTopMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] - -> RnM (RenamedHsBinds, FreeVars) + -> RnM (RenamedHsBinds, DefUses) --- Assumes the binders of the binding are in scope already --- Very like rnMonoBinds, bu checks for missing signatures too +-- The binders of the binding are in scope already; +-- the top level scope resolution does that rnTopMonoBinds mbinds sigs - = bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ + = bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ \ _ -> -- Hmm; by analogy with Ids, this doesn't look right + -- Top-level bound type vars should really scope over + -- everything, but we only scope them over the other bindings - renameSigs sigs `thenM` \ siglist -> - rn_mono_binds siglist mbinds `thenM` \ (binders, final_binds, bind_fvs) -> - checkSigs okBindSig binders siglist `thenM_` - - -- Warn about missing signatures, but not in interface mode - -- (This is important when renaming bindings from 'deriving' clauses.) - getModeRn `thenM` \ mode -> - doptM Opt_WarnMissingSigs `thenM` \ warn_missing_sigs -> - (if warn_missing_sigs && not (isInterfaceMode mode) then - let - type_sig_vars = [n | Sig n _ _ <- siglist] - un_sigd_binders = filter (not . (`elem` type_sig_vars)) - (nameSetToList binders) - in - mappM_ missingSigWarn un_sigd_binders - else - returnM () - ) `thenM_` - - returnM (final_binds, bind_fvs `plusFV` hsSigsFVs siglist) + rnMonoBinds TopLevel mbinds sigs \end{code} @@ -197,27 +183,35 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds = -- Extract all the binders in this group, and extend the -- current scope, inventing new names for the new binders -- This also checks that the names form a set - bindLocatedLocalsRn doc mbinders_w_srclocs $ \ new_mbinders -> - bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ + bindLocatedLocalsRn doc mbinders_w_srclocs $ \ _ -> + bindPatSigTyVarsFV (collectSigTysFromMonoBinds mbinds) $ -- Then install local fixity declarations -- Notice that they scope over thing_inside too bindLocalFixities [sig | FixSig sig <- sigs ] $ -- Do the business - rnMonoBinds mbinds sigs `thenM` \ (binds, bind_fvs) -> + rnMonoBinds NotTopLevel mbinds sigs `thenM` \ (binds, bind_dus) -> -- Now do the "thing inside" - thing_inside binds `thenM` \ (result,result_fvs) -> + thing_inside binds `thenM` \ (result,result_fvs) -> -- Final error checking let - all_fvs = result_fvs `plusFV` bind_fvs - unused_binders = filter (not . (`elemNameSet` all_fvs)) new_mbinders + all_uses = duUses bind_dus `plusFV` result_fvs + bndrs = duDefs bind_dus + unused_bndrs = nameSetToList (bndrs `minusNameSet` all_uses) in - warnUnusedLocalBinds unused_binders `thenM_` - - returnM (result, delListFromNameSet all_fvs new_mbinders) + warnUnusedLocalBinds unused_bndrs `thenM_` + + returnM (result, all_uses `minusNameSet` bndrs) + -- duUses: It's important to return all the uses, not the 'real uses' used for + -- warning about unused bindings. Otherwise consider: + -- x = 3 + -- y = let p = x in 'x' -- NB: p not used + -- If we don't "see" the dependency of 'y' on 'x', we may put the + -- bindings in the wrong order, and the type checker will complain + -- that x isn't in scope where mbinders_w_srclocs = collectLocatedMonoBinders mbinds doc = text "In the binding group for:" @@ -225,63 +219,66 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds \end{code} -\begin{code} -rnMonoBinds :: RdrNameMonoBinds - -> [RdrNameSig] - -> RnM (RenamedHsBinds, FreeVars) - --- Assumes the binders of the binding are in scope already - -rnMonoBinds mbinds sigs - = renameSigs sigs `thenM` \ siglist -> - rn_mono_binds siglist mbinds `thenM` \ (binders, final_binds, bind_fvs) -> - checkSigs okBindSig binders siglist `thenM_` - returnM (final_binds, bind_fvs `plusFV` hsSigsFVs siglist) -\end{code} - %************************************************************************ %* * \subsubsection{ MonoBinds -- the main work is done here} %* * %************************************************************************ -@rn_mono_binds@ is used by {\em both} top-level and nested bindings. +@rnMonoBinds@ is used by {\em both} top-level and nested bindings. It assumes that all variables bound in this group are already in scope. This is done {\em either} by pass 3 (for the top-level bindings), {\em or} by @rnMonoBinds@ (for the nested ones). \begin{code} -rn_mono_binds :: [RenamedSig] -- Signatures attached to this group - -> RdrNameMonoBinds - -> RnM (NameSet, -- Binders - RenamedHsBinds, -- Dependency analysed - FreeVars) -- Free variables - -rn_mono_binds siglist mbinds - = -- Rename the bindings, returning a MonoBindsInfo +rnMonoBinds :: TopLevelFlag + -> RdrNameMonoBinds + -> [RdrNameSig] + -> RnM (RenamedHsBinds, DefUses) + +-- Assumes the binders of the binding are in scope already + +rnMonoBinds top_lvl mbinds sigs + = renameSigs sigs `thenM` \ siglist -> + + -- Rename the bindings, returning a MonoBindsInfo -- which is a list of indivisible vertices so far as -- the strongly-connected-components (SCC) analysis is concerned - flattenMonoBinds siglist mbinds `thenM` \ mbinds_info -> + flattenMonoBinds siglist mbinds `thenM` \ mbinds_info -> -- Do the SCC analysis let scc_result = rnSCC mbinds_info - final_binds = foldr (ThenBinds . reconstructCycle) EmptyBinds scc_result - - -- Deal with bound and free-var calculation - -- Caller removes binders from free-var set - rhs_fvs = plusFVs [fvs | (_,fvs,_) <- mbinds_info] - bndrs = plusFVs [defs | (defs,_,_) <- mbinds_info] + (binds_s, bind_dus_s) = unzip (map reconstructCycle scc_result) + bind_dus = mkDUs bind_dus_s + final_binds = foldr ThenBinds EmptyBinds binds_s + binders = duDefs bind_dus in - returnM (bndrs, final_binds, rhs_fvs) + -- Check for duplicate or mis-placed signatures + checkSigs (okBindSig binders) siglist `thenM_` + + -- Warn about missing signatures, + -- but only at top level, and not in interface mode + -- (The latter is important when renaming bindings from 'deriving' clauses.) + doptM Opt_WarnMissingSigs `thenM` \ warn_missing_sigs -> + (if isTopLevel top_lvl && + warn_missing_sigs + then let + type_sig_vars = [n | Sig n _ _ <- siglist] + un_sigd_binders = filter (not . (`elem` type_sig_vars)) + (nameSetToList binders) + in + mappM_ missingSigWarn un_sigd_binders + else + returnM () + ) `thenM_` + + returnM (final_binds, bind_dus `plusDU` usesOnly (hsSigsFVs siglist)) \end{code} @flattenMonoBinds@ is ever-so-slightly magical in that it sticks unique ``vertex tags'' on its output; minor plumbing required. -Sigh --- need to pass along the signatures for the group of bindings, -in case any of them \fbox{\ ???\ } - \begin{code} flattenMonoBinds :: [RenamedSig] -- Signatures -> RdrNameMonoBinds @@ -303,11 +300,10 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn) names_bound_here = mkNameSet (collectPatBinders pat') in sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> - rnGRHSs grhss `thenM` \ (grhss', fvs) -> + rnGRHSs PatBindRhs grhss `thenM` \ (grhss', fvs) -> returnM - [(names_bound_here, - fvs `plusFV` pat_fvs, - (PatMonoBind pat' grhss' locn, sigs_for_me) + [(names_bound_here, fvs `plusFV` pat_fvs, + PatMonoBind pat' grhss' locn, sigs_for_me )] flattenMonoBinds sigs (FunMonoBind name inf matches locn) @@ -317,21 +313,21 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) names_bound_here = unitNameSet new_name in sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> - mapFvRn (rnMatch (FunRhs name)) matches `thenM` \ (new_matches, fvs) -> + mapFvRn (rnMatch (FunRhs new_name)) matches `thenM` \ (new_matches, fvs) -> mappM_ (checkPrecMatch inf new_name) new_matches `thenM_` returnM - [(unitNameSet new_name, - fvs, - (FunMonoBind new_name inf new_matches locn, sigs_for_me) + [(unitNameSet new_name, fvs, + FunMonoBind new_name inf new_matches locn, sigs_for_me )] - sigsForMe names_bound_here sigs = foldlM check [] (filter (sigForThisGroup names_bound_here) sigs) where + -- sigForThisGroup only returns signatures for + -- which sigName returns a Just check sigs sig = case filter (eqHsSig sig) sigs of [] -> returnM (sig:sigs) - other -> dupSigDeclErr sig `thenM_` + other -> dupSigDeclErr sig other `thenM_` returnM sigs \end{code} @@ -370,19 +366,20 @@ rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn) lookupInstDeclBndr cls name `thenM` \ sel_name -> -- We use the selector name as the binder - mapFvRn rn_match matches `thenM` \ (new_matches, fvs) -> + mapFvRn (rn_match sel_name) matches `thenM` \ (new_matches, fvs) -> mappM_ (checkPrecMatch inf sel_name) new_matches `thenM_` returnM (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.rnSourceDecl(ClassDecl) - rn_match match@(Match (TypePat ty : _) _ _) - = extendTyVarEnvFVRn gen_tvs (rnMatch (FunRhs name) match) + rn_match sel_name match@(Match (TypePat ty : _) _ _) + = extendTyVarEnvFVRn gen_tvs $ + rnMatch (FunRhs sel_name) match where - tvs = map rdrNameOcc (extractHsTyRdrNames ty) + tvs = map rdrNameOcc (extractHsTyRdrTyVars ty) gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] - rn_match match = rnMatch (FunRhs name) match + rn_match sel_name match = rnMatch (FunRhs sel_name) match -- Can't handle method pattern-bindings which bind multiple methods. @@ -405,42 +402,40 @@ a function binding, and has itself been dependency-analysed and renamed. \begin{code} -type BindWithSigs = (RenamedMonoBinds, [RenamedSig]) +type FlatMonoBinds = (Defs, Uses, RenamedMonoBinds, [RenamedSig]) -- Signatures, if any, for this vertex -type FlatMonoBinds = (NameSet, -- Defs - NameSet, -- Uses - BindWithSigs) - -rnSCC :: [FlatMonoBinds] -> [SCC BindWithSigs] +rnSCC :: [FlatMonoBinds] -> [SCC FlatMonoBinds] rnSCC nodes = stronglyConnComp (mkEdges nodes) type VertexTag = Int -mkEdges :: [FlatMonoBinds] -> [(BindWithSigs, VertexTag, [VertexTag])] +mkEdges :: [FlatMonoBinds] -> [(FlatMonoBinds, VertexTag, [VertexTag])] + -- We keep the uses with the binding, + -- so we can track unused bindings better mkEdges nodes = [ (thing, tag, dest_vertices uses) - | ((defs, uses, thing), tag) <- tagged_nodes + | (thing@(_, uses, _, _), tag) <- tagged_nodes ] where tagged_nodes = nodes `zip` [0::VertexTag ..] -- An edge (v,v') indicates that v depends on v' dest_vertices uses = [ target_vertex - | ((defs, _, _), target_vertex) <- tagged_nodes, - mentioned_name <- nameSetToList uses, - mentioned_name `elemNameSet` defs + | ((defs, _, _, _), target_vertex) <- tagged_nodes, + defs `intersectsNameSet` uses ] -reconstructCycle :: SCC BindWithSigs -> RenamedHsBinds -reconstructCycle (AcyclicSCC (binds, sigs)) - = MonoBind binds sigs NonRecursive +reconstructCycle :: SCC FlatMonoBinds -> (RenamedHsBinds, (Defs,Uses)) +reconstructCycle (AcyclicSCC (defs, uses, binds, sigs)) + = (MonoBind binds sigs NonRecursive, (defs, uses)) reconstructCycle (CyclicSCC cycle) - = MonoBind this_gp_binds this_gp_sigs Recursive + = (MonoBind this_gp_binds this_gp_sigs Recursive, + (unionManyNameSets defs_s, unionManyNameSets uses_s)) where - (binds,sigs) = unzip cycle - this_gp_binds = foldr1 AndMonoBinds binds - this_gp_sigs = foldr1 (++) sigs + (defs_s, uses_s, binds_s, sigs_s) = unzip4 cycle + this_gp_binds = foldr1 AndMonoBinds binds_s + this_gp_sigs = foldr1 (++) sigs_s \end{code} @@ -461,17 +456,19 @@ 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} -checkSigs :: (NameSet -> RenamedSig -> Bool) -- OK-sig predicbate - -> NameSet -- Binders of this group +checkSigs :: (RenamedSig -> Bool) -- OK-sig predicbate -> [RenamedSig] -> RnM () -checkSigs ok_sig bndrs sigs +checkSigs ok_sig sigs -- Check for (a) duplicate signatures -- (b) signatures for things not in this group - -- Well, I can't see the check for (b)... ToDo! - = mappM_ unknownSigErr bad_sigs + -- Well, I can't see the check for (a)... ToDo! + = mappM_ unknownSigErr (filter bad sigs) where - bad_sigs = filter (not . ok_sig bndrs) sigs + bad sig = not (ok_sig sig) && + case sigName sig of + Just n | isUnboundName n -> False -- Don't complain about an unbound name again + other -> True -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: @@ -487,7 +484,7 @@ renameSigs sigs = mappM renameSig (filter (not . isFixitySig) sigs) -- Remove fixity sigs which have been dealt with already renameSig :: Sig RdrName -> RnM (Sig Name) --- ClassOpSig, FixitSig is renamed elsewhere. +-- FixitSig is renamed elsewhere. renameSig (Sig v ty src_loc) = addSrcLoc src_loc $ lookupSigOccRn v `thenM` \ new_v -> @@ -519,12 +516,13 @@ renameSig (InlineSig b v p src_loc) %************************************************************************ \begin{code} -dupSigDeclErr sig +dupSigDeclErr sig sigs = addSrcLoc loc $ - addErr (sep [ptext SLIT("Duplicate") <+> what_it_is <> colon, - ppr sig]) + addErr (vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon, + nest 2 (vcat (map ppr_sig (sig:sigs)))]) where (what_it_is, loc) = hsSigDoc sig + ppr_sig sig = ppr (sigLoc sig) <> colon <+> ppr sig unknownSigErr sig = addSrcLoc loc $