they may be affected by renaming (which isn't fully worked out yet).
\begin{code}
-module RnBinds (rnTopBinds, rnTopBindsLHS, rnTopBindsRHS, -- use these for top-level bindings
- rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, -- or these for local bindings
- rnMethodBinds, renameSigs, mkSigTvFn,
- rnMatchGroup, rnGRHSs,
- makeMiniFixityEnv, MiniFixityEnv
+module RnBinds (
+ -- Renaming top-level bindings
+ rnTopBinds, rnTopBindsLHS, rnTopBindsRHS,
+
+ -- Renaming local bindings
+ rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
+
+ -- Other bindings
+ rnMethodBinds, renameSigs, mkSigTvFn,
+ rnMatchGroup, rnGRHSs,
+ makeMiniFixityEnv, MiniFixityEnv,
+ misplacedSigErr
) where
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
-import RdrHsSyn
import RnHsSyn
import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch)
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
rnTopBindsLHS fix_env binds
- = rnValBindsLHSFromDoc (topRecNameMaker fix_env) binds
+ = rnValBindsLHS (topRecNameMaker fix_env) binds
-rnTopBindsRHS :: NameSet -- Names bound by these binds
- -> HsValBindsLR Name RdrName
+rnTopBindsRHS :: HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
-rnTopBindsRHS bound_names binds =
- do { is_boot <- tcIsHsBoot
+rnTopBindsRHS binds
+ = do { is_boot <- tcIsHsBoot
; if is_boot
then rnTopBindsBoot binds
- else rnValBindsRHSGen (\x -> x) -- don't trim free vars
- bound_names binds }
+ else rnValBindsRHS noTrimFVs -- don't trim free vars
+ Nothing -- Allow SPEC prags for imports
+ binds }
-- Wrapper if we don't need to do anything in between the left and right,
-- or anything else in the scope of the left
-- Never used when there are fixity declarations
rnTopBinds :: HsValBinds RdrName
-> RnM (HsValBinds Name, DefUses)
-rnTopBinds b =
- do nl <- rnTopBindsLHS emptyFsEnv b
- let bound_names = collectHsValBinders nl
- bindLocalNames bound_names $ rnTopBindsRHS (mkNameSet bound_names) nl
+rnTopBinds b
+ = do { nl <- rnTopBindsLHS emptyFsEnv b
+ ; let bound_names = collectHsValBinders nl
+ ; bindLocalNames bound_names $
+ rnValBindsRHS noTrimFVs (Just (mkNameSet bound_names)) nl }
rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
\end{code}
-
%*********************************************************
%* *
HsLocalBinds
= thing_inside EmptyLocalBinds
rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
- = rnValBindsAndThen val_binds $ \ val_binds' ->
+ = rnLocalValBindsAndThen val_binds $ \ val_binds' ->
thing_inside (HsValBinds val_binds')
rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
\begin{code}
-- Renaming local binding gropus
-- Does duplicate/shadow check
-rnValBindsLHS :: MiniFixityEnv
- -> HsValBinds RdrName
- -> RnM ([Name], HsValBindsLR Name RdrName)
-rnValBindsLHS fix_env binds
+rnLocalValBindsLHS :: MiniFixityEnv
+ -> HsValBinds RdrName
+ -> RnM ([Name], HsValBindsLR Name RdrName)
+rnLocalValBindsLHS fix_env binds
= do { -- 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.
-- import A(f)
-- g = let f = ... in f
-- should.
- ; binds' <- rnValBindsLHSFromDoc (localRecNameMaker fix_env) binds
+ ; binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds
; let bound_names = collectHsValBinders binds'
; envs <- getRdrEnvs
; checkDupAndShadowedNames envs bound_names
-- 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 :: NameMaker
- -> HsValBinds RdrName
- -> RnM (HsValBindsLR Name RdrName)
-rnValBindsLHSFromDoc topP (ValBindsIn mbinds sigs)
+rnValBindsLHS :: NameMaker
+ -> HsValBinds RdrName
+ -> RnM (HsValBindsLR Name RdrName)
+rnValBindsLHS topP (ValBindsIn mbinds sigs)
= do { mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
; return $ ValBindsIn mbinds' sigs }
where
bndrs = collectHsBindsBinders mbinds
doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs
-rnValBindsLHSFromDoc _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
+rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
-- General version used both from the top-level and for local things
-- Assumes the LHS vars are in scope
--
-- Does not bind the local fixity declarations
-rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets
+rnValBindsRHS :: (FreeVars -> FreeVars) -- for trimming free var sets
-- The trimming function trims the free vars we attach to a
-- binding so that it stays reasonably small
- -> NameSet -- Names bound by the LHSes
- -> HsValBindsLR Name RdrName
- -> RnM (HsValBinds Name, DefUses)
-
-rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs)
- = do { -- rename the sigs
- sigs' <- renameSigs (Just bound_names) okBindSig sigs
- -- rename the RHSes
+ -> Maybe NameSet -- Names bound by the LHSes
+ -- Nothing if expect sigs for imports
+ -> HsValBindsLR Name RdrName
+ -> RnM (HsValBinds Name, DefUses)
+
+rnValBindsRHS trim mb_bound_names (ValBindsIn mbinds sigs)
+ = do { sigs' <- renameSigs mb_bound_names okBindSig sigs
; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
; case depAnalBinds binds_w_dus of
- (anal_binds, anal_dus) -> do
- { let valbind' = ValBindsOut anal_binds sigs'
- valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus
- ; return (valbind', valbind'_dus) }}
+ (anal_binds, anal_dus) -> return (valbind', valbind'_dus)
+ where
+ valbind' = ValBindsOut anal_binds sigs'
+ valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs')
+ -- Put the sig uses *after* the bindings
+ -- so that the binders are removed from
+ -- the uses in the sigs
+ }
+
+rnValBindsRHS _ _ b = pprPanic "rnValBindsRHS" (ppr b)
-rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b)
+noTrimFVs :: FreeVars -> FreeVars
+noTrimFVs fvs = fvs
-- Wrapper for local binds
--
-- it doesn't (and can't: we don't have the thing inside the binds) happen here
--
-- The client is also responsible for bringing the fixities into scope
-rnValBindsRHS :: NameSet -- names bound by the LHSes
- -> HsValBindsLR Name RdrName
- -> RnM (HsValBinds Name, DefUses)
-rnValBindsRHS bound_names binds
- = rnValBindsRHSGen trim bound_names binds
+rnLocalValBindsRHS :: NameSet -- names bound by the LHSes
+ -> HsValBindsLR Name RdrName
+ -> RnM (HsValBinds Name, DefUses)
+rnLocalValBindsRHS bound_names binds
+ = rnValBindsRHS trim (Just bound_names) binds
where
trim fvs = intersectNameSet bound_names fvs
-- Only keep the names the names from this group
--
-- here there are no local fixity decls passed in;
-- the local fixity decls come from the ValBinds sigs
-rnValBindsAndThen :: HsValBinds RdrName
- -> (HsValBinds Name -> RnM (result, FreeVars))
- -> RnM (result, FreeVars)
-rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
+rnLocalValBindsAndThen :: HsValBinds RdrName
+ -> (HsValBinds Name -> RnM (result, FreeVars))
+ -> RnM (result, FreeVars)
+rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
= do { -- (A) Create the local fixity environment
new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs]
-- (B) Rename the LHSes
- ; (bound_names, new_lhs) <- rnValBindsLHS new_fixities binds
+ ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
-- ...and bring them (and their fixities) into scope
; bindLocalNamesFV bound_names $
addLocalFixities new_fixities bound_names $ do
{ -- (C) Do the RHS and thing inside
- (binds', dus) <- rnValBindsRHS (mkNameSet bound_names) new_lhs
+ (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs
; (result, result_fvs) <- thing_inside binds'
-- Report unused bindings based on the (accurate)
-- let x = x in 3
-- should report 'x' unused
; let real_uses = findUses dus result_fvs
- ; warnUnusedLocalBinds bound_names real_uses
+ -- Insert fake uses for variables introduced implicitly by wildcards (#4404)
+ implicit_uses = hsValBindsImplicits binds'
+ ; warnUnusedLocalBinds bound_names (real_uses `unionNameSets` implicit_uses)
; let
-- The variables "used" in the val binds are:
-- The bound names are pruned out of all_uses
-- by the bindLocalNamesFV call above
-rnValBindsAndThen bs _ = pprPanic "rnValBindsAndThen" (ppr bs)
+rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)
-- Process the fixity declarations, making a FastString -> (Located Fixity) map
rnBind _ trim (L loc bind@(PatBind { pat_lhs = pat
, pat_rhs = grhss
-- pat fvs were stored in bind_fvs
- -- after processing the LHS
+ -- after processing the LHS
, bind_fvs = pat_fvs }))
= setSrcSpan loc $
do { let bndrs = collectPatBinders pat
, fun_infix = is_infix
, fun_matches = matches }))
-- invariant: no free vars here when it's a FunBind
- = setSrcSpan loc $
+ = setSrcSpan loc $
do { let plain_name = unLoc name
; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
\begin{code}
rnMethodBinds :: Name -- Class name
-> (Name -> [Name]) -- Signature tyvar function
- -> [Name] -- Names for generic type variables
-> LHsBinds RdrName
-> RnM (LHsBinds Name, FreeVars)
-rnMethodBinds cls sig_fn gen_tyvars binds
- = foldlM do_one (emptyBag,emptyFVs) (bagToList binds)
+rnMethodBinds cls sig_fn binds
+ = do { checkDupRdrNames meth_names
+ -- Check that the same method is not given twice in the
+ -- same instance decl instance C T where
+ -- f x = ...
+ -- g y = ...
+ -- f x = ...
+ -- We must use checkDupRdrNames because the Name of the
+ -- method is the Name of the class selector, whose SrcSpan
+ -- points to the class declaration; and we use rnMethodBinds
+ -- for instance decls too
+
+ ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
where
+ meth_names = collectMethodBinders binds
do_one (binds,fvs) bind
- = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind
+ = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
rnMethodBind :: Name
-> (Name -> [Name])
- -> [Name]
-> LHsBindLR RdrName RdrName
-> RnM (Bag (LHsBindLR Name Name), FreeVars)
-rnMethodBind cls sig_fn gen_tyvars
+rnMethodBind cls sig_fn
(L loc bind@(FunBind { fun_id = name, fun_infix = is_infix
, fun_matches = MatchGroup matches _ }))
= setSrcSpan loc $ do
-- We use the selector name as the binder
(new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
- mapFvRn (rn_match (FunRhs plain_name is_infix)) matches
+ mapFvRn (rnMatch (FunRhs plain_name is_infix)) matches
let new_group = MatchGroup new_matches placeHolderType
when is_infix $ checkPrecMatch plain_name new_group
, bind_fvs = fvs })),
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)
- rn_match info match@(L _ (Match (L _ (TypePat ty) : _) _ _))
- = extendTyVarEnvFVRn gen_tvs $
- rnMatch info match
- where
- tvs = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty)
- gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs]
-
- rn_match info match = rnMatch info match
-- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do
+rnMethodBind _ _ (L loc bind@(PatBind {})) = do
addErrAt loc (methodBindErr bind)
return (emptyBag, emptyFVs)
-rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b)
+rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b)
\end{code}
\begin{code}
renameSigs :: Maybe NameSet -- If (Just ns) complain if the sig isn't for one of ns
- -> (Sig RdrName -> Bool) -- Complain about the wrong kind of signature if this is False
+ -> (Sig Name -> Bool) -- Complain about the wrong kind of signature if this is False
-> [LSig RdrName]
-> RnM [LSig Name]
-- Renames the signatures and performs error checks
renameSigs mb_names ok_sig sigs
- = do { let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs
- ; mapM_ unknownSigErr bad_sigs -- Misplaced
- ; mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs) -- Duplicate
- ; sigs' <- mapM (wrapLocM (renameSig mb_names)) good_sigs
- ; return sigs' }
+ = do { mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs) -- Duplicate
+ -- Check for duplicates on RdrName version,
+ -- because renamed version has unboundName for
+ -- not-in-scope binders, which gives bogus dup-sig errors
+ -- NB: in a class decl, a 'generic' sig is not considered
+ -- equal to an ordinary sig, so we allow, say
+ -- class C a where
+ -- op :: a -> a
+ -- default op :: Eq a => a -> a
+
+ ; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs
+
+ ; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs'
+ ; mapM_ misplacedSigErr bad_sigs -- Misplaced
+
+ ; return good_sigs }
----------------------
-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; return (TypeSig new_v new_ty) }
+renameSig mb_names sig@(GenericSig v ty)
+ = do { defaultSigs_on <- xoptM Opt_DefaultSignatures
+ ; unless defaultSigs_on (addErr (defaultSigErr sig))
+ ; new_v <- lookupSigOccRn mb_names sig v
+ ; new_ty <- rnHsSigType (quotes (ppr v)) ty
+ ; return (GenericSig new_v new_ty) }
+
renameSig _ (SpecInstSig ty)
= do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
; return (SpecInstSig new_ty) }
+-- {-# SPECIALISE #-} pragmas can refer to imported Ids
+-- so, in the top-level case (when mb_names is Nothing)
+-- we use lookupOccRn. If there's both an imported and a local 'f'
+-- then the SPECIALISE pragma is ambiguous, unlike all other signatures
renameSig mb_names sig@(SpecSig v ty inl)
- = do { new_v <- lookupSigOccRn mb_names sig v
+ = do { new_v <- case mb_names of
+ Just {} -> lookupSigOccRn mb_names sig v
+ Nothing -> lookupLocatedOccRn v
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; return (SpecSig new_v new_ty inl) }
rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars)
rnGRHS' ctxt (GRHS guards rhs)
= do { pattern_guards_allowed <- xoptM Opt_PatternGuards
- ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $
+ ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ \ _ ->
rnLExpr rhs
; unless (pattern_guards_allowed || is_standard_guard guards')
-- Standard Haskell 1.4 guards are just a single boolean
-- expression, rather than a list of qualifiers as in the
-- Glasgow extension
- is_standard_guard [] = True
- is_standard_guard [L _ (ExprStmt _ _ _)] = True
- is_standard_guard _ = False
+ is_standard_guard [] = True
+ is_standard_guard [L _ (ExprStmt _ _ _ _)] = True
+ is_standard_guard _ = False
\end{code}
%************************************************************************
ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig
dupSigDeclErr [] = panic "dupSigDeclErr"
-unknownSigErr :: LSig RdrName -> RnM ()
-unknownSigErr (L loc sig)
+misplacedSigErr :: LSig Name -> RnM ()
+misplacedSigErr (L loc sig)
= addErrAt loc $
sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
+defaultSigErr :: Sig RdrName -> SDoc
+defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:"))
+ 2 (ppr sig)
+ , ptext (sLit "Use -XDefaultSignatures to enable default signatures") ]
+
methodBindErr :: HsBindLR RdrName RdrName -> SDoc
methodBindErr mbind
= hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
nonStdGuardErr guards
= hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))
4 (interpp'SP guards)
+
\end{code}
projects / ghc-hetmet.git / blobdiff