import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
-import HsBinds ( hsSigDoc, eqHsSig )
import RdrHsSyn
import RnHsSyn
import TcRnMonad
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}
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
-- 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
-- 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
-- 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:"
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
+
+ ; let (binds', bind_dus) = depAnalBinds binds_w_dus
- ; (mbinds', du_bag) <- mapAndUnzipBagM rn_bind mbinds
+ -- 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'
- ; let defs, uses :: NameSet
- (defs, uses) = foldrBag plus (emptyNameSet, emptyNameSet) du_bag
- plus (ds1,us1) (ds2,us2) = (ds1 `unionNameSets` ds2,
- us1 `unionNameSets` us2)
+ ; return (ValBindsOut binds' sigs',
+ usesOnly (hsSigsFVs sigs') `plusDU` bind_dus) }
- ; check_sigs (okBindSig defs) sigs'
- ; traceRn (text "rnValBind" <+> (ppr defs $$ ppr uses))
- ; return (ValBindsIn mbinds' sigs',
- [(Just defs, uses `plusFV` hsSigsFVs sigs')]) }
+---------------------
+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]
+
---------------------
-- Bind the top-level forall'd type variables in the 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
---------------------
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}
(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
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
check_sigs ok_sig sigs
-- Check for (a) duplicate signatures
-- (b) signatures for things not in this group
- = do { mappM_ unknownSigErr (filter bad sigs)
- ; mappM_ dupSigDeclErr (findDupsEq eqHsSig sigs) }
+ = do { mappM_ unknownSigErr (filter (not . ok_sig) sigs')
+ ; mappM_ dupSigDeclErr (findDupsEq eqHsSig sigs') }
where
- 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
+ -- Don't complain about an unbound name again
+ 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:
-- instance Foo T where
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}
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
= 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}
projects / ghc-hetmet.git / blobdiff