module RnBinds (
rnTopBinds,
rnLocalBindsAndThen, rnValBindsAndThen, rnValBinds, trimWith,
- rnMethodBinds, renameSigs,
+ rnMethodBinds, renameSigs, mkSigTvFn,
rnMatchGroup, rnGRHSs
) where
import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,
rnLPat, rnPatsAndThen, patSigErr, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn,
- lookupLocatedInstDeclBndr, newIPNameRn,
- lookupLocatedSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV,
+ lookupInstDeclBndr, newIPNameRn,
+ lookupLocatedSigOccRn, bindPatSigTyVarsFV,
bindLocalFixities, bindSigTyVarsFV,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
)
import DynFlags ( DynFlag(..) )
-import Name ( Name, nameOccName, nameSrcLoc )
+import Name
import NameEnv
import NameSet
import PrelNames ( isUnboundName )
import RdrName ( RdrName, rdrNameOcc )
-import SrcLoc ( mkSrcSpan, Located(..), unLoc )
+import SrcLoc ( Located(..), unLoc )
import ListSetOps ( findDupsEq )
import BasicTypes ( RecFlag(..) )
import Digraph ( SCC(..), stronglyConnComp )
import Bag
import Outputable
-import Maybes ( orElse, isJust )
+import Maybes ( orElse )
import Util ( filterOut )
import Monad ( foldM )
\end{code}
; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }
rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses)
-rnTopBindsSrc binds@(ValBindsIn mbinds _)
- = do { (binds', dus) <- rnValBinds noTrim binds
-
- -- Warn about missing signatures,
- ; 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
- ; ifM (warn_missing_sigs)
- (mappM_ missingSigWarn (nameSetToList un_sigd_bndrs))
-
- ; return (binds', dus)
- }
+rnTopBindsSrc binds = rnValBinds noTrim binds
\end{code}
; let bndrs = collectPatBinders pat'
- ; (grhss', fvs) <- bindSigTyVarsFV (concatMap sig_fn bndrs) $
- rnGRHSs PatBindRhs grhss
+ ; (grhss', fvs) <- rnGRHSs PatBindRhs grhss
+ -- No scoped type variables for pattern bindings
; return (L loc (PatBind { pat_lhs = pat', pat_rhs = grhss',
pat_rhs_ty = placeHolderType, bind_fvs = trim fvs }),
; let plain_name = unLoc new_name
; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
- rnMatchGroup (FunRhs plain_name) matches
+ -- bindSigTyVars tests for Opt_ScopedTyVars
+ rnMatchGroup (FunRhs plain_name inf) matches
; checkPrecMatch inf plain_name matches'
; return (L loc (FunBind { fun_id = new_name, fun_infix = inf, fun_matches = matches',
- bind_fvs = trim fvs, fun_co_fn = idCoercion }),
+ bind_fvs = trim fvs, fun_co_fn = idHsWrapper, fun_tick = Nothing }),
[plain_name], fvs)
}
\end{code}
\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 gen_tyvars binds
+rnMethodBinds cls sig_fn gen_tyvars binds
= foldM do_one (emptyBag,emptyFVs) (bagToList binds)
where do_one (binds,fvs) bind = do
- (bind', fvs_bind) <- rnMethodBind cls gen_tyvars bind
+ (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind
return (bind' `unionBags` binds, fvs_bind `plusFV` fvs)
-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
+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 = idCoercion })),
+ 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
where
-- type variables. See comments in RnSource.rnSourceDecl(ClassDecl)
rn_match sel_name match@(L _ (Match (L _ (TypePat ty) : _) _ _))
= extendTyVarEnvFVRn gen_tvs $
- rnMatch (FunRhs sel_name) match
+ rnMatch (FunRhs sel_name inf) match
where
tvs = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty)
gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs]
- rn_match sel_name match = rnMatch (FunRhs sel_name) match
+ rn_match sel_name match = rnMatch (FunRhs sel_name inf) match
-- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _ _ _))
+rnMethodBind cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _))
= addLocErr mbind methodBindErr `thenM_`
returnM (emptyBag, emptyFVs)
\end{code}
+
%************************************************************************
%* *
\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
=
-- Deal with the rhs type signature
bindPatSigTyVarsFV rhs_sig_tys $
- doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
+ doptM Opt_PatternSignatures `thenM` \ opt_PatternSignatures ->
(case maybe_rhs_sig of
Nothing -> returnM (Nothing, emptyFVs)
- Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) ->
+ 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)
rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
rnGRHS' ctxt (GRHS guards rhs)
- = do { opt_GlasgowExts <- doptM Opt_GlasgowExts
+ = do { pattern_guards_allowed <- doptM Opt_PatternGuards
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $
rnLExpr rhs
- ; checkM (opt_GlasgowExts || is_standard_guard guards')
+ ; checkM (pattern_guards_allowed || is_standard_guard guards')
(addWarn (nonStdGuardErr guards'))
; return (GRHS guards' rhs', fvs) }
ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig
unknownSigErr (L loc sig)
- = addErrAt loc $
- sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig]
+ = do { mod <- getModule
+ ; addErrAt loc $
+ vcat [sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig],
+ extra_stuff mod sig] }
where
what_it_is = hsSigDoc sig
+ extra_stuff mod (TypeSig (L _ n) _)
+ | nameIsLocalOrFrom mod n
+ = ptext SLIT("The type signature must be given where")
+ <+> quotes (ppr n) <+> ptext SLIT("is declared")
+ | otherwise
+ = ptext SLIT("You cannot give a type signature for an imported value")
-missingSigWarn var
- = addWarnAt (mkSrcSpan loc loc) $
- sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
- where
- loc = nameSrcLoc var -- TODO: make a proper span
+ extra_stuff mod other = empty
methodBindErr mbind
= hang (ptext SLIT("Pattern bindings (except simple variables) not allowed in instance declarations"))
2 (ppr mbinds)
nonStdGuardErr guards
- = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
+ = 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