X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnBinds.lhs;h=13035e72e2831185bc58ee74c632c381ac49b151;hb=876b4ef2093cb9c104db33c7db1200b941b6d079;hp=7fa9611877148024a97d35f84f2c389f201b1b22;hpb=f5c57f6d5ec4b457ef84bd815ab3fa10bcba531a;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 7fa9611..13035e7 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -21,7 +21,6 @@ module RnBinds ( import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn -import HsBinds ( hsSigDoc, eqHsSig ) import RdrHsSyn import RnHsSyn import TcRnMonad @@ -41,9 +40,12 @@ import PrelNames ( isUnboundName ) import RdrName ( RdrName, rdrNameOcc ) import SrcLoc ( mkSrcSpan, Located(..), unLoc ) import ListSetOps ( findDupsEq ) +import BasicTypes ( RecFlag(..) ) +import Digraph ( SCC(..), stronglyConnComp ) import Bag import Outputable -import Maybes ( orElse ) +import Maybes ( orElse, isJust ) +import Util ( filterOut ) import Monad ( foldM ) \end{code} @@ -173,20 +175,15 @@ rnTopBindsBoot :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBindsBoot (ValBindsIn mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) ; sigs' <- renameSigs okHsBootSig sigs - ; return (ValBindsIn emptyLHsBinds sigs', usesOnly (hsSigsFVs sigs')) } + ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) } rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBindsSrc binds@(ValBindsIn mbinds _) - = bindPatSigTyVars (collectSigTysFromHsBinds (bagToList 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 - - do { (binds', dus) <- rnValBinds noTrim binds + = do { (binds', dus) <- rnValBinds noTrim binds -- Warn about missing signatures, - ; let { ValBindsIn _ sigs' = binds' - ; ty_sig_vars = mkNameSet [ unLoc n | L _ (Sig n _) <- sigs'] + ; let { ValBindsOut _ sigs' = binds' + ; ty_sig_vars = mkNameSet [ unLoc n | L _ (TypeSig n _) <- sigs'] ; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars } ; warn_missing_sigs <- doptM Opt_WarnMissingSigs @@ -253,7 +250,6 @@ rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside -- current scope, inventing new names for the new binders -- This also checks that the names form a set bindLocatedLocalsRn doc mbinders_w_srclocs $ \ bndrs -> - bindPatSigTyVarsFV (collectSigTysFromHsBinds (bagToList mbinds)) $ -- Then install local fixity declarations -- Notice that they scope over thing_inside too @@ -267,12 +263,7 @@ rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside -- Final error checking let - all_uses = duUses bind_dus `plusFV` result_fvs - unused_bndrs = [ b | b <- bndrs, not (b `elemNameSet` all_uses)] - in - warnUnusedLocalBinds unused_bndrs `thenM_` - - returnM (result, delListFromNameSet all_uses bndrs) + all_uses = duUses bind_dus `plusFV` result_fvs -- duUses: It's important to return all the uses, not the 'real uses' -- used for warning about unused bindings. Otherwise consider: -- x = 3 @@ -280,6 +271,12 @@ rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside -- 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 + + unused_bndrs = [ b | b <- bndrs, not (b `elemNameSet` all_uses)] + in + warnUnusedLocalBinds unused_bndrs `thenM_` + + returnM (result, delListFromNameSet all_uses bndrs) where mbinders_w_srclocs = collectHsBindLocatedBinders mbinds doc = text "In the binding group for:" @@ -294,21 +291,47 @@ rnValBinds :: (FreeVars -> FreeVars) rnValBinds trim (ValBindsIn mbinds sigs) = do { sigs' <- rename_sigs sigs - ; let { rn_bind = wrapLocFstM (rnBind sig_fn trim) - ; sig_fn = mkSigTvFn sigs' } + ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds - ; (mbinds', du_bag) <- mapAndUnzipBagM rn_bind mbinds + ; let (binds', bind_dus) = depAnalBinds binds_w_dus - ; let defs, uses :: NameSet - (defs, uses) = foldrBag plus (emptyNameSet, emptyNameSet) du_bag - plus (ds1,us1) (ds2,us2) = (ds1 `unionNameSets` ds2, - us1 `unionNameSets` us2) + -- We do the check-sigs after renaming the bindings, + -- so that we have convenient access to the binders + ; check_sigs (okBindSig (duDefs bind_dus)) sigs' - ; check_sigs (okBindSig defs) sigs' + ; return (ValBindsOut binds' sigs', + usesOnly (hsSigsFVs sigs') `plusDU` bind_dus) } + + +--------------------- +depAnalBinds :: Bag (LHsBind Name, [Name], Uses) + -> ([(RecFlag, LHsBinds Name)], DefUses) +-- Dependency analysis; this is important so that +-- unused-binding reporting is accurate +depAnalBinds binds_w_dus + = (map get_binds sccs, map get_du sccs) + where + sccs = stronglyConnComp edges + + keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..] + + edges = [ (node, key, [key | n <- nameSetToList uses, + Just key <- [lookupNameEnv key_map n] ]) + | (node@(_,_,uses), key) <- keyd_nodes ] + + key_map :: NameEnv Int -- Which binding it comes from + key_map = mkNameEnv [(bndr, key) | ((_, bndrs, _), key) <- keyd_nodes + , bndr <- bndrs ] + + get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) + get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,d,u) <- binds_w_dus]) + + get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses) + get_du (CyclicSCC binds_w_dus) = (Just defs, uses) + where + defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] + uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus] - ; traceRn (text "rnValBind" <+> (ppr defs $$ ppr uses)) - ; return (ValBindsIn mbinds' sigs', - [(Just defs, uses `plusFV` hsSigsFVs sigs')]) } --------------------- -- Bind the top-level forall'd type variables in the sigs. @@ -331,8 +354,8 @@ mkSigTvFn sigs where env :: NameEnv [Name] env = mkNameEnv [ (name, map hsLTyVarName ltvs) - | L _ (Sig (L _ name) - (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] + | L _ (TypeSig (L _ name) + (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] -- Note the pattern-match on "Explicit"; we only bind -- type variables from signatures with an explicit top-level for-all @@ -348,31 +371,34 @@ trimWith bndrs = intersectNameSet (mkNameSet bndrs) --------------------- rnBind :: (Name -> [Name]) -- Signature tyvar function -> (FreeVars -> FreeVars) -- Trimming function for rhs free vars - -> HsBind RdrName - -> RnM (HsBind Name, (Defs, Uses)) -rnBind sig_fn trim (PatBind pat grhss ty _) - = do { (pat', pat_fvs) <- rnLPat pat + -> LHsBind RdrName + -> RnM (LHsBind Name, [Name], Uses) +rnBind sig_fn trim (L loc (PatBind { pat_lhs = pat, pat_rhs = grhss })) + = setSrcSpan loc $ + do { (pat', pat_fvs) <- rnLPat pat ; let bndrs = collectPatBinders pat' ; (grhss', fvs) <- bindSigTyVarsFV (concatMap sig_fn bndrs) $ rnGRHSs PatBindRhs grhss - ; return (PatBind pat' grhss' ty (trim fvs), - (mkNameSet bndrs, pat_fvs `plusFV` fvs)) } + ; return (L loc (PatBind { pat_lhs = pat', pat_rhs = grhss', + pat_rhs_ty = placeHolderType, bind_fvs = trim fvs }), + bndrs, pat_fvs `plusFV` fvs) } -rnBind sig_fn trim (FunBind name inf matches _) - = do { new_name <- lookupLocatedBndrRn name - ; let { plain_name = unLoc new_name - ; bndrs = unitNameSet plain_name } +rnBind sig_fn trim (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches = matches })) + = setSrcSpan loc $ + do { new_name <- lookupLocatedBndrRn name + ; let plain_name = unLoc new_name ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ rnMatchGroup (FunRhs plain_name) matches ; checkPrecMatch inf plain_name matches' - ; return (FunBind new_name inf matches' (trim fvs), - (bndrs, fvs)) + ; return (L loc (FunBind { fun_id = new_name, fun_infix = inf, fun_matches = matches', + bind_fvs = trim fvs, fun_co_fn = idCoercion }), + [plain_name], fvs) } \end{code} @@ -404,7 +430,8 @@ rnMethodBinds cls gen_tyvars binds (bind', fvs_bind) <- rnMethodBind cls gen_tyvars bind return (bind' `unionBags` binds, fvs_bind `plusFV` fvs) -rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _) _)) +rnMethodBind cls gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf, + fun_matches = MatchGroup matches _ })) = setSrcSpan loc $ lookupLocatedInstDeclBndr cls name `thenM` \ sel_name -> let plain_name = unLoc sel_name in @@ -415,7 +442,9 @@ rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _) _)) new_group = MatchGroup new_matches placeHolderType in checkPrecMatch inf plain_name new_group `thenM_` - returnM (unitBag (L loc (FunBind sel_name inf new_group fvs)), fvs `addOneFV` plain_name) + returnM (unitBag (L loc (FunBind { fun_id = sel_name, fun_infix = inf, fun_matches = new_group, + bind_fvs = fvs, fun_co_fn = idCoercion })), + fvs `addOneFV` plain_name) -- The 'fvs' field isn't used for method binds where -- Truly gruesome; bring into scope the correct members of the generic @@ -473,15 +502,14 @@ check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM () check_sigs ok_sig sigs -- Check for (a) duplicate signatures -- (b) signatures for things not in this group - = do { mappM_ unknownSigErr sigs' + = do { mappM_ unknownSigErr (filter (not . ok_sig) sigs') ; mappM_ dupSigDeclErr (findDupsEq eqHsSig sigs') } where -- Don't complain about an unbound name again - sigs' = filter bad sigs - bad sig = not (ok_sig sig) && - case sigName sig of - Just n | isUnboundName n -> False - other -> True + sigs' = filterOut bad_name sigs + bad_name sig = case sigName sig of + Just n -> isUnboundName n + other -> False -- We use lookupLocatedSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: @@ -494,23 +522,23 @@ check_sigs ok_sig sigs renameSig :: Sig RdrName -> RnM (Sig Name) -- FixitSig is renamed elsewhere. -renameSig (Sig v ty) +renameSig (TypeSig v ty) = lookupLocatedSigOccRn v `thenM` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> - returnM (Sig new_v new_ty) + returnM (TypeSig new_v new_ty) renameSig (SpecInstSig ty) = rnLHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty -> returnM (SpecInstSig new_ty) -renameSig (SpecSig v ty) +renameSig (SpecSig v ty inl) = lookupLocatedSigOccRn v `thenM` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> - returnM (SpecSig new_v new_ty) + returnM (SpecSig new_v new_ty inl) -renameSig (InlineSig b v p) +renameSig (InlineSig v s) = lookupLocatedSigOccRn v `thenM` \ new_v -> - returnM (InlineSig b new_v p) + returnM (InlineSig new_v s) \end{code} @@ -575,11 +603,12 @@ rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt) rnGRHS' ctxt (GRHS guards rhs) = do { opt_GlasgowExts <- doptM Opt_GlasgowExts - ; checkM (opt_GlasgowExts || is_standard_guard guards) - (addWarn (nonStdGuardErr guards)) - ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ rnLExpr rhs + + ; checkM (opt_GlasgowExts || is_standard_guard guards') + (addWarn (nonStdGuardErr guards')) + ; return (GRHS guards' rhs', fvs) } where -- Standard Haskell 1.4 guards are just a single boolean @@ -625,8 +654,7 @@ bindsInHsBootFile mbinds = hang (ptext SLIT("Bindings in hs-boot files are not allowed")) 2 (ppr mbinds) -nonStdGuardErr guard - = hang (ptext - SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)") - ) 4 (ppr guard) +nonStdGuardErr guards + = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")) + 4 (interpp'SP guards) \end{code}