module RnBinds (
rnTopBindsLHS, rnTopBindsRHS, rnValBindsRHS,
rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
rnMethodBinds, renameSigs, mkSigTvFn,
rnMatchGroup, rnGRHSs, rnGRHS,
makeMiniFixityEnv, MiniFixityEnv,
HsSigCtxt(..)
) where
import RnExpr( rnLExpr, rnStmts )
import HsSyn
import TcRnMonad
import TcEvidence ( emptyTcEvBinds )
import RnTypes
import RnPat
import RnNames
import RnEnv
import DynFlags
import Module
import Name
import NameEnv
import NameSet
import RdrName ( RdrName, rdrNameOcc )
import SrcLoc
import ListSetOps ( findDupsEq )
import BasicTypes ( RecFlag(..) )
import Digraph ( SCC(..) )
import Bag
import Outputable
import FastString
import Data.List ( partition, sort )
import Maybes ( orElse )
import Control.Monad
#if __GLASGOW_HASKELL__ < 709
import Data.Traversable ( traverse )
#endif
rnTopBindsLHS :: MiniFixityEnv
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
rnTopBindsLHS fix_env binds
= rnValBindsLHS (topRecNameMaker fix_env) binds
rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
rnTopBindsRHS bound_names binds
= do { is_boot <- tcIsHsBootOrSig
; if is_boot
then rnTopBindsBoot binds
else rnValBindsRHS (TopSigCtxt bound_names False) binds }
rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
rnTopBindsBoot (ValBindsIn mbinds sigs)
= do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
; (sigs', fvs) <- renameSigs HsBootCtxt sigs
; return (ValBindsOut [] sigs', usesOnly fvs) }
rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
rnLocalBindsAndThen :: HsLocalBinds RdrName
-> (HsLocalBinds Name -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalBindsAndThen EmptyLocalBinds thing_inside
= thing_inside EmptyLocalBinds
rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
= rnLocalValBindsAndThen val_binds $ \ val_binds' ->
thing_inside (HsValBinds val_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 :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars)
rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
(ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s)
rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)
rnIPBind (IPBind ~(Left n) expr) = do
(expr',fvExpr) <- rnLExpr expr
return (IPBind (Left n) expr', fvExpr)
rnLocalValBindsLHS :: MiniFixityEnv
-> HsValBinds RdrName
-> RnM ([Name], HsValBindsLR Name RdrName)
rnLocalValBindsLHS fix_env binds
= do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds
; let bound_names = collectHsValBinders binds'
; envs <- getRdrEnvs
; checkDupAndShadowedNames envs bound_names
; return (bound_names, binds') }
rnValBindsLHS :: NameMaker
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
rnValBindsLHS topP (ValBindsIn mbinds sigs)
= do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds
; return $ ValBindsIn mbinds' sigs }
where
bndrs = collectHsBindsBinders mbinds
doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs
rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
rnValBindsRHS :: HsSigCtxt
-> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
= do { (sigs', sig_fvs) <- renameSigs ctxt sigs
; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds
; case depAnalBinds binds_w_dus of
(anal_binds, anal_dus) -> return (valbind', valbind'_dus)
where
valbind' = ValBindsOut anal_binds sigs'
valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
}
rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
rnLocalValBindsRHS :: NameSet
-> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
rnLocalValBindsRHS bound_names binds
= rnValBindsRHS (LocalBindCtxt bound_names) binds
rnLocalValBindsAndThen :: HsValBinds RdrName
-> (HsValBinds Name -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
= do {
new_fixities <- makeMiniFixityEnv [L loc sig
| L loc (FixSig sig) <- sigs]
; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
; bindLocalNamesFV bound_names $
addLocalFixities new_fixities bound_names $ do
{
(binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs
; (result, result_fvs) <- thing_inside binds'
; let real_uses = findUses dus result_fvs
implicit_uses = hsValBindsImplicits binds'
; warnUnusedLocalBinds bound_names
(real_uses `unionNameSet` implicit_uses)
; let
all_uses = allUses dus `plusFV` result_fvs
; return (result, all_uses) }}
rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)
makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv
makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
where
add_one_sig env (L loc (FixitySig names fixity)) =
foldlM add_one env [ (loc,name_loc,name,fixity)
| L name_loc name <- names ]
add_one env (loc, name_loc, name,fixity) = do
{
let { fs = occNameFS (rdrNameOcc name)
; fix_item = L loc fixity };
case lookupFsEnv env fs of
Nothing -> return $ extendFsEnv env fs fix_item
Just (L loc' _) -> do
{ setSrcSpan loc $
addErrAt name_loc (dupFixityDecl loc' name)
; return env}
}
dupFixityDecl :: SrcSpan -> RdrName -> SDoc
dupFixityDecl loc rdr_name
= vcat [ptext (sLit "Multiple fixity declarations for") <+> quotes (ppr rdr_name),
ptext (sLit "also at ") <+> ppr loc]
rnBindLHS :: NameMaker
-> SDoc
-> HsBind RdrName
-> RnM (HsBindLR Name RdrName)
rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
= do
(pat',pat'_fvs) <- rnBindPat name_maker pat
return (bind { pat_lhs = pat', bind_fvs = pat'_fvs })
rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
= do { name <- applyNameMaker name_maker rdr_name
; return (bind { fun_id = name
, bind_fvs = placeHolderNamesTc }) }
rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname })
| isTopRecNameMaker name_maker
= do { addLocM checkConName rdrname
; name <- lookupLocatedTopBndrRn rdrname
; return (PatSynBind psb{ psb_id = name }) }
| otherwise
= do { addErr localPatternSynonymErr
; name <- applyNameMaker name_maker rdrname
; return (PatSynBind psb{ psb_id = name }) }
where
localPatternSynonymErr :: SDoc
localPatternSynonymErr
= hang (ptext (sLit "Illegal pattern synonym declaration for") <+> quotes (ppr rdrname))
2 (ptext (sLit "Pattern synonym declarations are only valid at top level"))
rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
rnLBind :: (Name -> [Name])
-> LHsBindLR Name RdrName
-> RnM (LHsBind Name, [Name], Uses)
rnLBind sig_fn (L loc bind)
= setSrcSpan loc $
do { (bind', bndrs, dus) <- rnBind sig_fn bind
; return (L loc bind', bndrs, dus) }
rnBind :: (Name -> [Name])
-> HsBindLR Name RdrName
-> RnM (HsBind Name, [Name], Uses)
rnBind _ bind@(PatBind { pat_lhs = pat
, pat_rhs = grhss
, bind_fvs = pat_fvs })
= do { mod <- getModule
; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss
; let all_fvs = pat_fvs `plusFV` rhs_fvs
fvs' = filterNameSet (nameIsLocalOrFrom mod) all_fvs
bndrs = collectPatBinders pat
bind' = bind { pat_rhs = grhss',
pat_rhs_ty = placeHolderType, bind_fvs = fvs' }
is_wild_pat = case pat of
L _ (WildPat {}) -> True
L _ (BangPat (L _ (WildPat {}))) -> True
_ -> False
; whenWOptM Opt_WarnUnusedBinds $
when (null bndrs && not is_wild_pat) $
addWarn $ unusedPatBindWarn bind'
; fvs' `seq`
return (bind', bndrs, all_fvs) }
rnBind sig_fn bind@(FunBind { fun_id = name
, fun_infix = is_infix
, fun_matches = matches })
= do { let plain_name = unLoc name
; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
rnMatchGroup (FunRhs plain_name is_infix)
rnLExpr matches
; when is_infix $ checkPrecMatch plain_name matches'
; mod <- getModule
; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs
; fvs' `seq`
return (bind { fun_matches = matches'
, bind_fvs = fvs' },
[plain_name], rhs_fvs)
}
rnBind sig_fn (PatSynBind bind)
= do { (bind', name, fvs) <- rnPatSynBind sig_fn bind
; return (PatSynBind bind', name, fvs) }
rnBind _ b = pprPanic "rnBind" (ppr b)
rnPatSynBind :: (Name -> [Name])
-> PatSynBind Name RdrName
-> RnM (PatSynBind Name Name, [Name], Uses)
rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name
, psb_args = details
, psb_def = pat
, psb_dir = dir })
= do { pattern_synonym_ok <- xoptM Opt_PatternSynonyms
; unless pattern_synonym_ok (addErr patternSynonymErr)
; ((pat', details'), fvs1) <- rnPat PatSyn pat $ \pat' -> do
{ (details', fvs) <- case details of
PrefixPatSyn vars ->
do { checkDupRdrNames vars
; names <- mapM lookupVar vars
; return (PrefixPatSyn names, mkFVs (map unLoc names)) }
InfixPatSyn var1 var2 ->
do { checkDupRdrNames [var1, var2]
; name1 <- lookupVar var1
; name2 <- lookupVar var2
; return (InfixPatSyn name1 name2, mkFVs (map unLoc [name1, name2])) }
; return ((pat', details'), fvs) }
; (dir', fvs2) <- case dir of
Unidirectional -> return (Unidirectional, emptyFVs)
ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
ExplicitBidirectional mg ->
do { (mg', fvs) <- rnMatchGroup PatSyn rnLExpr mg
; return (ExplicitBidirectional mg', fvs) }
; mod <- getModule
; let fvs = fvs1 `plusFV` fvs2
fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs
; let bind' = bind{ psb_args = details'
, psb_def = pat'
, psb_dir = dir'
, psb_fvs = fvs' }
; fvs' `seq`
return (bind', [name], fvs1)
}
where
lookupVar = wrapLocM lookupOccRn
patternSynonymErr :: SDoc
patternSynonymErr
= hang (ptext (sLit "Illegal pattern synonym declaration"))
2 (ptext (sLit "Use -XPatternSynonyms to enable this extension"))
depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
-> ([(RecFlag, LHsBinds Name)], DefUses)
depAnalBinds binds_w_dus
= (map get_binds sccs, map get_du sccs)
where
sccs = depAnal (\(_, defs, _) -> defs)
(\(_, _, uses) -> nameSetElems uses)
(bagToList binds_w_dus)
get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- 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 = unionNameSets [u | (_,_,u) <- binds_w_dus]
mkSigTvFn :: [LSig Name] -> (Name -> [Name])
mkSigTvFn sigs
= \n -> lookupNameEnv env n `orElse` []
where
extractScopedTyVars :: LHsType Name -> [Name]
extractScopedTyVars (L _ (HsForAllTy Explicit _ ltvs _ _)) = hsLKiTyVarNames ltvs
extractScopedTyVars _ = []
env :: NameEnv [Name]
env = mkNameEnv [ (name, nwcs ++ extractScopedTyVars ty)
| L _ (TypeSig names ty nwcs) <- sigs
, L _ name <- names]
rnMethodBinds :: Name
-> (Name -> [Name])
-> LHsBinds RdrName
-> RnM (LHsBinds Name, FreeVars)
rnMethodBinds cls sig_fn binds
= do { checkDupRdrNames meth_names
; 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 bind
; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
rnMethodBind :: Name
-> (Name -> [Name])
-> LHsBindLR RdrName RdrName
-> RnM (Bag (LHsBindLR Name Name), FreeVars)
rnMethodBind cls sig_fn
(L loc bind@(FunBind { fun_id = name, fun_infix = is_infix
, fun_matches = MG { mg_alts = matches
, mg_origin = origin } }))
= setSrcSpan loc $ do
sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name
let plain_name = unLoc sel_name
(new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr)
matches
let new_group = mkMatchGroupName origin new_matches
when is_infix $ checkPrecMatch plain_name new_group
return (unitBag (L loc (bind { fun_id = sel_name
, fun_matches = new_group
, bind_fvs = fvs })),
fvs `addOneFV` plain_name)
rnMethodBind _ _ (L loc bind@(PatBind {})) = do
addErrAt loc (methodBindErr bind)
return (emptyBag, emptyFVs)
rnMethodBind _ _ (L loc bind@(PatSynBind {})) = do
addErrAt loc $ methodPatSynErr bind
return (emptyBag, emptyFVs)
rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b)
renameSigs :: HsSigCtxt
-> [LSig RdrName]
-> RnM ([LSig Name], FreeVars)
renameSigs ctxt sigs
= do { mapM_ dupSigDeclErr (findDupSigs sigs)
; checkDupMinimalSigs sigs
; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs
; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
; mapM_ misplacedSigErr bad_sigs
; return (good_sigs, sig_fvs) }
renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars)
renameSig _ (IdSig x)
= return (IdSig x, emptyFVs)
renameSig ctxt sig@(TypeSig vs ty _)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; (wcs, ty') <- extractWildcards ty
; bindLocatedLocalsFV wcs $ \wcs_new -> do {
(new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty'
; return (TypeSig new_vs new_ty wcs_new, fvs) } }
renameSig ctxt sig@(GenericSig vs ty)
= do { defaultSigs_on <- xoptM Opt_DefaultSignatures
; unless defaultSigs_on (addErr (defaultSigErr sig))
; new_v <- mapM (lookupSigOccRn ctxt sig) vs
; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
; return (GenericSig new_v new_ty, fvs) }
renameSig _ (SpecInstSig src ty)
= do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty
; return (SpecInstSig src new_ty,fvs) }
renameSig ctxt sig@(SpecSig v tys inl)
= do { new_v <- case ctxt of
TopSigCtxt {} -> lookupLocatedOccRn v
_ -> lookupSigOccRn ctxt sig v
; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
; return (SpecSig new_v new_ty inl, fvs) }
where
do_one (tys,fvs) ty
= do { (new_ty, fvs_ty) <- rnHsSigType (quotes (ppr v)) ty
; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
renameSig ctxt sig@(InlineSig v s)
= do { new_v <- lookupSigOccRn ctxt sig v
; return (InlineSig new_v s, emptyFVs) }
renameSig ctxt sig@(FixSig (FixitySig vs f))
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; return (FixSig (FixitySig new_vs f), emptyFVs) }
renameSig ctxt sig@(MinimalSig s bf)
= do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
return (MinimalSig s new_bf, emptyFVs)
renameSig ctxt sig@(PatSynSig v (flag, qtvs) prov req ty)
= do { v' <- lookupSigOccRn ctxt sig v
; let doc = TypeSigCtx $ quotes (ppr v)
; loc <- getSrcSpanM
; let (tv_kvs, mentioned) = extractHsTysRdrTyVars (ty:unLoc prov ++ unLoc req)
; tv_bndrs <- case flag of
Implicit ->
return $ mkHsQTvs . userHsTyVarBndrs loc $ mentioned
Explicit ->
do { let heading = ptext (sLit "In the pattern synonym type signature")
<+> quotes (ppr sig)
; warnUnusedForAlls (heading $$ docOfHsDocContext doc) qtvs mentioned
; return qtvs }
Qualified -> panic "renameSig: Qualified"
; bindHsTyVars doc Nothing tv_kvs tv_bndrs $ \ tyvars -> do
{ (prov', fvs1) <- rnContext doc prov
; (req', fvs2) <- rnContext doc req
; (ty', fvs3) <- rnLHsType doc ty
; let fvs = plusFVs [fvs1, fvs2, fvs3]
; return (PatSynSig v' (flag, tyvars) prov' req' ty', fvs) }}
ppr_sig_bndrs :: [Located RdrName] -> SDoc
ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
okHsSig :: HsSigCtxt -> LSig a -> Bool
okHsSig ctxt (L _ sig)
= case (sig, ctxt) of
(GenericSig {}, ClsDeclCtxt {}) -> True
(GenericSig {}, _) -> False
(TypeSig {}, _) -> True
(PatSynSig {}, TopSigCtxt{}) -> True
(PatSynSig {}, _) -> False
(FixSig {}, InstDeclCtxt {}) -> False
(FixSig {}, _) -> True
(IdSig {}, TopSigCtxt {}) -> True
(IdSig {}, InstDeclCtxt {}) -> True
(IdSig {}, _) -> False
(InlineSig {}, HsBootCtxt) -> False
(InlineSig {}, _) -> True
(SpecSig {}, TopSigCtxt {}) -> True
(SpecSig {}, LocalBindCtxt {}) -> True
(SpecSig {}, InstDeclCtxt {}) -> True
(SpecSig {}, _) -> False
(SpecInstSig {}, InstDeclCtxt {}) -> True
(SpecInstSig {}, _) -> False
(MinimalSig {}, ClsDeclCtxt {}) -> True
(MinimalSig {}, _) -> False
findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]]
findDupSigs sigs
= findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
where
expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig)
expand_sig sig@(InlineSig n _) = [(n,sig)]
expand_sig sig@(TypeSig ns _ _) = [(n,sig) | n <- ns]
expand_sig sig@(GenericSig ns _) = [(n,sig) | n <- ns]
expand_sig _ = []
matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2
mtch (FixSig {}) (FixSig {}) = True
mtch (InlineSig {}) (InlineSig {}) = True
mtch (TypeSig {}) (TypeSig {}) = True
mtch (GenericSig {}) (GenericSig {}) = True
mtch _ _ = False
checkDupMinimalSigs :: [LSig RdrName] -> RnM ()
checkDupMinimalSigs sigs
= case filter isMinimalLSig sigs of
minSigs@(_:_:_) -> dupMinimalSigErr minSigs
_ -> return ()
rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name
-> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
-> MatchGroup RdrName (Located (body RdrName))
-> RnM (MatchGroup Name (Located (body Name)), FreeVars)
rnMatchGroup ctxt rnBody (MG { mg_alts = ms, mg_origin = origin })
= do { empty_case_ok <- xoptM Opt_EmptyCase
; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
; return (mkMatchGroupName origin new_ms, ms_fvs) }
rnMatch :: Outputable (body RdrName) => HsMatchContext Name
-> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
-> LMatch RdrName (Located (body RdrName))
-> RnM (LMatch Name (Located (body Name)), FreeVars)
rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)
rnMatch' :: Outputable (body RdrName) => HsMatchContext Name
-> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
-> Match RdrName (Located (body RdrName))
-> RnM (Match Name (Located (body Name)), FreeVars)
rnMatch' ctxt rnBody match@(Match { m_fun_id_infix = mf, m_pats = pats
, m_type = maybe_rhs_sig, m_grhss = grhss })
= do {
case maybe_rhs_sig of
Nothing -> return ()
Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty)
; rnPats ctxt pats $ \ pats' -> do
{ (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
; let mf' = case (ctxt,mf) of
(FunRhs funid isinfix,Just (L lf _,_))
-> Just (L lf funid,isinfix)
_ -> Nothing
; return (Match { m_fun_id_infix = mf', m_pats = pats'
, m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
emptyCaseErr :: HsMatchContext Name -> SDoc
emptyCaseErr ctxt = hang (ptext (sLit "Empty list of alternatives in") <+> pp_ctxt)
2 (ptext (sLit "Use EmptyCase to allow this"))
where
pp_ctxt = case ctxt of
CaseAlt -> ptext (sLit "case expression")
LambdaExpr -> ptext (sLit "\\case expression")
_ -> ptext (sLit "(unexpected)") <+> pprMatchContextNoun ctxt
resSigErr :: Outputable body
=> HsMatchContext Name -> Match RdrName body -> HsType RdrName -> SDoc
resSigErr ctxt match ty
= vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty)
, nest 2 $ ptext (sLit
"Result signatures are no longer supported in pattern matches")
, pprMatchInCtxt ctxt match ]
rnGRHSs :: HsMatchContext Name
-> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
-> GRHSs RdrName (Located (body RdrName))
-> RnM (GRHSs Name (Located (body Name)), FreeVars)
rnGRHSs ctxt rnBody (GRHSs grhss binds)
= rnLocalBindsAndThen binds $ \ binds' -> do
(grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
return (GRHSs grhss' binds', fvGRHSs)
rnGRHS :: HsMatchContext Name
-> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
-> LGRHS RdrName (Located (body RdrName))
-> RnM (LGRHS Name (Located (body Name)), FreeVars)
rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)
rnGRHS' :: HsMatchContext Name
-> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
-> GRHS RdrName (Located (body RdrName))
-> RnM (GRHS Name (Located (body Name)), FreeVars)
rnGRHS' ctxt rnBody (GRHS guards rhs)
= do { pattern_guards_allowed <- xoptM Opt_PatternGuards
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->
rnBody rhs
; unless (pattern_guards_allowed || is_standard_guard guards')
(addWarn (nonStdGuardErr guards'))
; return (GRHS guards' rhs', fvs) }
where
is_standard_guard [] = True
is_standard_guard [L _ (BodyStmt _ _ _ _)] = True
is_standard_guard _ = False
dupSigDeclErr :: [(Located RdrName, Sig RdrName)] -> RnM ()
dupSigDeclErr pairs@((L loc name, sig) : _)
= addErrAt loc $
vcat [ ptext (sLit "Duplicate") <+> what_it_is
<> ptext (sLit "s for") <+> quotes (ppr name)
, ptext (sLit "at") <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ]
where
what_it_is = hsSigDoc sig
dupSigDeclErr [] = panic "dupSigDeclErr"
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 DefaultSignatures to enable default signatures") ]
methodBindErr :: HsBindLR RdrName RdrName -> SDoc
methodBindErr mbind
= hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
2 (ppr mbind)
methodPatSynErr :: HsBindLR RdrName RdrName -> SDoc
methodPatSynErr mbind
= hang (ptext (sLit "Pattern synonyms not allowed in class/instance declarations"))
2 (ppr mbind)
bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc
bindsInHsBootFile mbinds
= hang (ptext (sLit "Bindings in hs-boot files are not allowed"))
2 (ppr mbinds)
nonStdGuardErr :: Outputable body => [LStmtLR Name Name body] -> SDoc
nonStdGuardErr guards
= hang (ptext (sLit "accepting non-standard pattern guards (use PatternGuards to suppress this message)"))
4 (interpp'SP guards)
unusedPatBindWarn :: HsBind Name -> SDoc
unusedPatBindWarn bind
= hang (ptext (sLit "This pattern-binding binds no variables:"))
2 (ppr bind)
dupMinimalSigErr :: [LSig RdrName] -> RnM ()
dupMinimalSigErr sigs@(L loc _ : _)
= addErrAt loc $
vcat [ ptext (sLit "Multiple minimal complete definitions")
, ptext (sLit "at") <+> vcat (map ppr $ sort $ map getLoc sigs)
, ptext (sLit "Combine alternative minimal complete definitions with `|'") ]
dupMinimalSigErr [] = panic "dupMinimalSigErr"