import RnHsSyn
import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch)
-import RnPat (rnPatsAndThen_LocalRightwards, rnPat_LocalRec, rnPat_TopRec,
- NameMaker, localNameMaker, topNameMaker, applyNameMaker,
+import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat,
+ NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker,
patSigErr)
import RnEnv ( lookupLocatedBndrRn,
bindLocatedLocalsFV, bindLocalNames, bindLocalNamesFV,
bindLocalNamesFV_WithFixities,
bindLocatedLocalsRn,
- checkDupNames, checkShadowing
+ checkDupAndShadowedRdrNames
)
import DynFlags ( DynFlag(..) )
import HscTypes (FixItem(..))
import Name
import NameEnv
-import UniqFM
+import LazyUniqFM
import NameSet
import PrelNames ( isUnboundName )
import RdrName ( RdrName, rdrNameOcc )
import Outputable
import Maybes ( orElse )
import Util ( filterOut )
-import Monad ( foldM )
+import Monad ( foldM, unless )
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
rnTopBindsLHS fix_env binds =
- (uncurry $ rnValBindsLHSFromDoc True) (bindersAndDoc binds) fix_env binds
+ (uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds
rnTopBindsRHS :: [Name] -- the names bound by these binds
-> HsValBindsLR Name RdrName
= rnValBindsAndThen val_binds $ \ val_binds' ->
thing_inside (HsValBinds val_binds')
-rnLocalBindsAndThen (HsIPBinds binds) thing_inside
- = rnIPBinds binds `thenM` \ (binds',fv_binds) ->
- thing_inside (HsIPBinds binds') `thenM` \ (thing, fvs_thing) ->
- returnM (thing, fvs_thing `plusFV` fv_binds)
+rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
+ (binds',fv_binds) <- rnIPBinds binds
+ (thing, fvs_thing) <- thing_inside (HsIPBinds binds')
+ return (thing, fvs_thing `plusFV` fv_binds)
-rnIPBinds (IPBinds ip_binds _no_dict_binds)
- = do { (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
- ; return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s) }
+rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
+ (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
+ return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s)
-rnIPBind (IPBind n expr)
- = newIPNameRn n `thenM` \ name ->
- rnLExpr expr `thenM` \ (expr',fvExpr) ->
+rnIPBind (IPBind n expr) = do
+ name <- newIPNameRn n
+ (expr',fvExpr) <- rnLExpr expr
return (IPBind name expr', fvExpr)
\end{code}
-- Do error checking: we need to check for dups here because we
-- don't don't bind all of the variables from the ValBinds at once
-- with bindLocatedLocals any more.
- --
- checkDupNames doc boundNames
- -- Warn about shadowing, but only in source modules
- ifOptM Opt_WarnNameShadowing (checkShadowing doc boundNames)
+ checkDupAndShadowedRdrNames doc boundNames
-- (Note that we don't want to do this at the top level, since
-- sorting out duplicates and shadowing there happens elsewhere.
-- import A(f)
-- g = let f = ... in f
-- should.
- rnValBindsLHSFromDoc False boundNames doc fix_env binds
+ rnValBindsLHSFromDoc (localRecNameMaker fix_env) boundNames doc binds
bindersAndDoc :: HsValBinds RdrName -> ([Located RdrName], SDoc)
bindersAndDoc binds =
-- renames the left-hand sides
-- generic version used both at the top level and for local binds
-- does some error checking, but not what gets done elsewhere at the top level
-rnValBindsLHSFromDoc :: Bool -- top or not
+rnValBindsLHSFromDoc :: NameMaker
-> [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice)
-> SDoc -- doc string for dup names and shadowing
- -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
- -- these fixities need to be brought into scope with the names
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
-rnValBindsLHSFromDoc topP original_bndrs doc fix_env binds@(ValBindsIn mbinds sigs)
- = do
+rnValBindsLHSFromDoc topP original_bndrs doc binds@(ValBindsIn mbinds sigs) = do
-- rename the LHSes
- mbinds' <- mapBagM (rnBindLHS topP doc fix_env) mbinds
+ mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
return $ ValBindsIn mbinds' sigs
-- assumes the LHS vars are in scope
-> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
-rnValBindsRHSGen trim bound_names binds@(ValBindsIn mbinds sigs)
- = do -- rename the sigs
+rnValBindsRHSGen trim bound_names binds@(ValBindsIn mbinds sigs) = do
+ -- rename the sigs
sigs' <- rename_sigs sigs
-- rename the RHSes
binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
-- We do the check-sigs after renaming the bindings,
-- so that we have convenient access to the binders
check_sigs (okBindSig (duDefs anal_dus)) sigs'
- returnM (valbind', valbind'_dus)
+ return (valbind', valbind'_dus)
-- wrapper for local binds
--
let bound_names = map unLoc $ collectHsValBinders new_lhs
-- and bring them (and their fixities) into scope
- bindLocalNamesFV_WithFixities bound_names new_fixities $ do
+ bindLocalNamesFV_WithFixities bound_names new_fixities $
+ warnUnusedLocalBinds bound_names $ do
-- (C) do the RHS and thing inside
(binds', dus) <- rnValBindsRHS bound_names new_lhs
-- bindings in the wrong order, and the type checker will complain
-- that x isn't in scope
- -- check for unused binders. note that we only want to do
- -- this for local ValBinds; it gets done elsewhere for
- -- top-level binds (where the scoping is different)
- unused_bndrs = [ b | b <- bound_names, not (b `elemNameSet` all_uses)]
-
- warnUnusedLocalBinds unused_bndrs
-
return (result,
-- the bound names are pruned out of all_uses
-- by the bindLocalNamesFV call above
-- renaming a single bind
-rnBindLHS :: Bool -- top if true; local if false
+rnBindLHS :: NameMaker
-> SDoc
- -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
- -- these fixities need to be brought into scope with the names
-> LHsBind RdrName
-- returns the renamed left-hand side,
-- and the FreeVars *of the LHS*
-- (i.e., any free variables of the pattern)
-> RnM (LHsBindLR Name RdrName)
-rnBindLHS topP doc fix_env (L loc (PatBind { pat_lhs = pat,
+rnBindLHS name_maker doc (L loc (PatBind { pat_lhs = pat,
pat_rhs = grhss,
bind_fvs=bind_fvs,
pat_rhs_ty=pat_rhs_ty
}))
= setSrcSpan loc $ do
-- we don't actually use the FV processing of rnPatsAndThen here
- (pat',pat'_fvs) <- (if topP then rnPat_TopRec else rnPat_LocalRec) fix_env pat
+ (pat',pat'_fvs) <- rnBindPat name_maker pat
return (L loc (PatBind { pat_lhs = pat',
pat_rhs = grhss,
-- we temporarily store the pat's FVs here;
-- when we rename the RHS
pat_rhs_ty = pat_rhs_ty }))
-rnBindLHS topP doc fix_env (L loc (FunBind { fun_id = name@(L nameLoc _),
+rnBindLHS name_maker doc (L loc (FunBind { fun_id = name@(L nameLoc _),
fun_infix = inf,
fun_matches = matches,
fun_co_fn = fun_co_fn,
bind_fvs = bind_fvs,
fun_tick = fun_tick
}))
- = setSrcSpan loc $ do
- newname <- applyNameMaker (if topP then topNameMaker else localNameMaker) name
- return (L loc (FunBind { fun_id = L nameLoc newname,
- fun_infix = inf,
- fun_matches = matches,
- -- we temporatily store the LHS's FVs (empty in this case) here
- -- gets updated when doing the RHS below
- bind_fvs = emptyFVs,
- -- everything else will get ignored in the next pass
- fun_co_fn = fun_co_fn,
- fun_tick = fun_tick
- }))
+ = setSrcSpan loc $
+ do { (newname, _fvs) <- applyNameMaker name_maker name $ \ newname ->
+ return (newname, emptyFVs)
+ ; return (L loc (FunBind { fun_id = L nameLoc newname,
+ fun_infix = inf,
+ fun_matches = matches,
+ -- we temporatily store the LHS's FVs (empty in this case) here
+ -- gets updated when doing the RHS below
+ bind_fvs = emptyFVs,
+ -- everything else will get ignored in the next pass
+ fun_co_fn = fun_co_fn,
+ fun_tick = fun_tick
+ })) }
-- assumes the left-hands-side vars are in scope
rnBind :: (Name -> [Name]) -- Signature tyvar function
rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf,
fun_matches = MatchGroup matches _ }))
- = setSrcSpan loc $
- lookupInstDeclBndr cls name `thenM` \ sel_name ->
- let plain_name = unLoc sel_name in
- -- We use the selector name as the binder
-
- bindSigTyVarsFV (sig_fn plain_name) $
- mapFvRn (rn_match plain_name) matches `thenM` \ (new_matches, fvs) ->
- let
- new_group = MatchGroup new_matches placeHolderType
- in
- checkPrecMatch inf plain_name new_group `thenM_`
- returnM (unitBag (L loc (FunBind {
- fun_id = sel_name, fun_infix = inf,
- fun_matches = new_group,
- bind_fvs = fvs, fun_co_fn = idHsWrapper,
- fun_tick = Nothing })),
- fvs `addOneFV` plain_name)
- -- The 'fvs' field isn't used for method binds
+ = setSrcSpan loc $ do
+ sel_name <- lookupInstDeclBndr cls name
+ let plain_name = unLoc sel_name
+ -- We use the selector name as the binder
+
+ bindSigTyVarsFV (sig_fn plain_name) $ do
+ (new_matches, fvs) <- mapFvRn (rn_match plain_name) matches
+ let
+ new_group = MatchGroup new_matches placeHolderType
+
+ checkPrecMatch inf plain_name new_group
+ return (unitBag (L loc (FunBind {
+ fun_id = sel_name, fun_infix = inf,
+ fun_matches = new_group,
+ bind_fvs = fvs, fun_co_fn = idHsWrapper,
+ fun_tick = Nothing })),
+ 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
-- type variables. See comments in RnSource.rnSourceDecl(ClassDecl)
-- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBind cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _))
- = addLocErr mbind methodBindErr `thenM_`
- returnM (emptyBag, emptyFVs)
+rnMethodBind cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _)) = do
+ addLocErr mbind methodBindErr
+ return (emptyBag, emptyFVs)
\end{code}
\begin{code}
renameSigs :: (LSig Name -> Bool) -> [LSig RdrName] -> RnM [LSig Name]
-- Renames the signatures and performs error checks
-renameSigs ok_sig sigs
+renameSigs ok_sig sigs
= do { sigs' <- rename_sigs sigs
; check_sigs ok_sig sigs'
; return sigs' }
----------------------
rename_sigs :: [LSig RdrName] -> RnM [LSig Name]
-rename_sigs sigs = mappM (wrapLocM renameSig) sigs
+rename_sigs sigs = mapM (wrapLocM renameSig) sigs
----------------------
check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM ()
-- Used for class and instance decls, as well as regular bindings
-check_sigs ok_sig sigs
+check_sigs ok_sig sigs = do
-- Check for (a) duplicate signatures
- -- (b) signatures for things not in this group
- = do {
- traceRn (text "SIGS" <+> ppr sigs)
- ; mappM_ unknownSigErr (filter (not . ok_sig) sigs')
- ; mappM_ dupSigDeclErr (findDupsEq eqHsSig sigs') }
+ -- (b) signatures for things not in this group = do
+ traceRn (text "SIGS" <+> ppr sigs)
+ mapM_ unknownSigErr (filter (not . ok_sig) sigs')
+ mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs')
where
-- Don't complain about an unbound name again
sigs' = filterOut bad_name sigs
renameSig :: Sig RdrName -> RnM (Sig Name)
-- FixitSig is renamed elsewhere.
-renameSig (TypeSig v ty)
- = lookupLocatedSigOccRn v `thenM` \ new_v ->
- rnHsSigType (quotes (ppr v)) ty `thenM` \ 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 inl)
- = lookupLocatedSigOccRn v `thenM` \ new_v ->
- rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty ->
- returnM (SpecSig new_v new_ty inl)
-
-renameSig (InlineSig v s)
- = lookupLocatedSigOccRn v `thenM` \ new_v ->
- returnM (InlineSig new_v s)
-
-renameSig (FixSig (FixitySig v f))
- = lookupLocatedSigOccRn v `thenM` \ new_v ->
- returnM (FixSig (FixitySig new_v f))
+renameSig (TypeSig v ty) = do
+ new_v <- lookupLocatedSigOccRn v
+ new_ty <- rnHsSigType (quotes (ppr v)) ty
+ return (TypeSig new_v new_ty)
+
+renameSig (SpecInstSig ty) = do
+ new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
+ return (SpecInstSig new_ty)
+
+renameSig (SpecSig v ty inl) = do
+ new_v <- lookupLocatedSigOccRn v
+ new_ty <- rnHsSigType (quotes (ppr v)) ty
+ return (SpecSig new_v new_ty inl)
+
+renameSig (InlineSig v s) = do
+ new_v <- lookupLocatedSigOccRn v
+ return (InlineSig new_v s)
+
+renameSig (FixSig (FixitySig v f)) = do
+ new_v <- lookupLocatedSigOccRn v
+ return (FixSig (FixitySig new_v f))
\end{code}
\begin{code}
rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
-rnMatchGroup ctxt (MatchGroup ms _)
- = mapFvRn (rnMatch ctxt) ms `thenM` \ (new_ms, ms_fvs) ->
- returnM (MatchGroup new_ms placeHolderType, ms_fvs)
+rnMatchGroup ctxt (MatchGroup ms _) = do
+ (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms
+ return (MatchGroup new_ms placeHolderType, ms_fvs)
rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
rnMatch ctxt = wrapLocFstM (rnMatch' ctxt)
rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
=
-- Deal with the rhs type signature
- bindPatSigTyVarsFV rhs_sig_tys $
- doptM Opt_PatternSignatures `thenM` \ opt_PatternSignatures ->
- (case maybe_rhs_sig of
- Nothing -> returnM (Nothing, emptyFVs)
- Just ty | opt_PatternSignatures -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) ->
- returnM (Just ty', ty_fvs)
- | otherwise -> addLocErr ty patSigErr `thenM_`
- returnM (Nothing, emptyFVs)
- ) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
-
- -- Now the main event
+ bindPatSigTyVarsFV rhs_sig_tys $ do
+ opt_PatternSignatures <- doptM Opt_PatternSignatures
+ (maybe_rhs_sig', ty_fvs) <-
+ case maybe_rhs_sig of
+ Nothing -> return (Nothing, emptyFVs)
+ Just ty | opt_PatternSignatures -> do (ty', ty_fvs) <- rnHsTypeFVs doc_sig ty
+ return (Just ty', ty_fvs)
+ | otherwise -> do addLocErr ty patSigErr
+ return (Nothing, emptyFVs)
+
+ -- Now the main event
-- note that there are no local ficity decls for matches
- rnPatsAndThen_LocalRightwards ctxt pats $ \ (pats',_) ->
- rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
+ rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do
+ (grhss', grhss_fvs) <- rnGRHSs ctxt grhss
- returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
+ return (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
-- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
where
rhs_sig_tys = case maybe_rhs_sig of
rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars)
rnGRHSs ctxt (GRHSs grhss binds)
- = rnLocalBindsAndThen binds $ \ binds' ->
- mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
- returnM (GRHSs grhss' binds', fvGRHSs)
+ = rnLocalBindsAndThen binds $ \ binds' -> do
+ (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt) grhss
+ return (GRHSs grhss' binds', fvGRHSs)
rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $
rnLExpr rhs
- ; checkM (pattern_guards_allowed || is_standard_guard guards')
+ ; unless (pattern_guards_allowed || is_standard_guard guards')
(addWarn (nonStdGuardErr guards'))
; return (GRHS guards' rhs', fvs) }
projects / ghc-hetmet.git / blobdiff