%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnBinds]{Renaming and dependency analysis of bindings}
This module does renaming and dependency analysis on value bindings in
the abstract syntax. It does {\em not} do cycle-checks on class or
type-synonym declarations; those cannot be done at this stage because
they may be affected by renaming (which isn't fully worked out yet).
\begin{code}
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 ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch, rnContext )
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(..), Origin )
import Digraph ( SCC(..) )
import Bag
import Outputable
import FastString
import Data.List ( partition, sort )
import Maybes ( orElse )
import Control.Monad
import Data.Traversable ( traverse )
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
-- place and can be used when complaining.
The code tree received by the function @rnBinds@ contains definitions
in where-clauses which are all apparently mutually recursive, but which may
not really depend upon each other. For example, in the top level program
\begin{verbatim}
f x = y where a = x
y = x
\end{verbatim}
the definitions of @a@ and @y@ do not depend on each other at all.
Unfortunately, the typechecker cannot always check such definitions.
\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
definitions. In Proceedings of the International Symposium on Programming,
Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
However, the typechecker usually can check definitions in which only the
strongly connected components have been collected into recursive bindings.
This is precisely what the function @rnBinds@ does.
ToDo: deal with case where a single monobinds binds the same variable
twice.
The vertag tag is a unique @Int@; the tags only need to be unique
within one @MonoBinds@, so that unique-Int plumbing is done explicitly
(heavy monad machinery not needed).
%************************************************************************
%* *
%* naming conventions *
%* *
%************************************************************************
\subsection[name-conventions]{Name conventions}
The basic algorithm involves walking over the tree and returning a tuple
containing the new tree plus its free variables. Some functions, such
as those walking polymorphic bindings (HsBinds) and qualifier lists in
list comprehensions (@Quals@), return the variables bound in local
environments. These are then used to calculate the free variables of the
expression evaluated in these environments.
Conventions for variable names are as follows:
\begin{itemize}
\item
new code is given a prime to distinguish it from the old.
\item
a set of variables defined in @Exp@ is written @dvExp@
\item
a set of variables free in @Exp@ is written @fvExp@
\end{itemize}
%************************************************************************
%* *
%* analysing polymorphic bindings (HsBindGroup, HsBind)
%* *
%************************************************************************
\subsubsection[dep-HsBinds]{Polymorphic bindings}
Non-recursive expressions are reconstructed without any changes at top
level, although their component expressions may have to be altered.
However, non-recursive expressions are currently not expected as
\Haskell{} programs, and this code should not be executed.
Monomorphic bindings contain information that is returned in a tuple
(a @FlatMonoBinds@) containing:
\begin{enumerate}
\item
a unique @Int@ that serves as the ``vertex tag'' for this binding.
\item
the name of a function or the names in a pattern. These are a set
referred to as @dvLhs@, the defined variables of the left hand side.
\item
the free variables of the body. These are referred to as @fvBody@.
\item
the definition's actual code. This is referred to as just @code@.
\end{enumerate}
The function @nonRecDvFv@ returns two sets of variables. The first is
the set of variables defined in the set of monomorphic bindings, while the
second is the set of free variables in those bindings.
The set of variables defined in a non-recursive binding is just the
union of all of them, as @union@ removes duplicates. However, the
free variables in each successive set of cumulative bindings is the
union of those in the previous set plus those of the newest binding after
the defined variables of the previous set have been removed.
@rnMethodBinds@ deals only with the declarations in class and
instance declarations. It expects only to see @FunMonoBind@s, and
it expects the global environment to contain bindings for the binders
(which are all class operations).
%************************************************************************
%* *
\subsubsection{ Top-level bindings}
%* *
%************************************************************************
\begin{code}
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 <- tcIsHsBoot
; 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)
\end{code}
%*********************************************************
%* *
HsLocalBinds
%* *
%*********************************************************
\begin{code}
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)
\end{code}
%************************************************************************
%* *
ValBinds
%* *
%************************************************************************
\begin{code}
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 (wrapOriginLocM (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 `unionNameSets` 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 emptyFsEnv decls
where
add_one env (L loc (FixitySig (L 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 = name@(L nameLoc _) })
= do { newname <- applyNameMaker name_maker name
; return (bind { fun_id = L nameLoc newname }) }
rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) })
= do { unless (isTopRecNameMaker name_maker) $
addErr localPatternSynonymErr
; addLocM checkConName rdrname
; name <- applyNameMaker name_maker rdrname
; return (bind{ patsyn_id = L nameLoc name }) }
where
localPatternSynonymErr :: SDoc
localPatternSynonymErr
= hang (ptext (sLit "Illegal pattern synonym declaration"))
2 (ptext (sLit "Pattern synonym declarations are only valid in the top-level scope"))
rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
rnLBind :: (Name -> [Name])
-> (Origin, LHsBindLR Name RdrName)
-> RnM ((Origin, LHsBind Name), [Name], Uses)
rnLBind sig_fn (origin, (L loc bind))
= setSrcSpan loc $
do { (bind', bndrs, dus) <- rnBind sig_fn bind
; return ((origin, 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', bind_fvs = fvs' }
is_wild_pat = case pat of
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 bind@(PatSynBind { patsyn_id = L _ name
, patsyn_args = details
, patsyn_def = pat
, patsyn_dir = dir })
= do { pattern_synonym_ok <- xoptM Opt_PatternSynonyms
; unless pattern_synonym_ok (addErr patternSynonymErr)
; ((pat', details'), fvs) <- 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' <- case dir of
Unidirectional -> return Unidirectional
ImplicitBidirectional -> return ImplicitBidirectional
; mod <- getModule
; let fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs
; let bind' = bind{ patsyn_args = details'
, patsyn_def = pat'
, patsyn_dir = dir'
, bind_fvs = fvs' }
; fvs' `seq`
return (bind', [name], fvs)
}
where
lookupVar = wrapLocM lookupOccRn
patternSynonymErr :: SDoc
patternSynonymErr
= hang (ptext (sLit "Illegal pattern synonym declaration"))
2 (ptext (sLit "Use -XPatternSynonyms to enable this extension"))
rnBind _ b = pprPanic "rnBind" (ppr b)
depAnalBinds :: Bag ((Origin, 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) -> nameSetToList 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 = unionManyNameSets [u | (_,_,u) <- binds_w_dus]
mkSigTvFn :: [LSig Name] -> (Name -> [Name])
mkSigTvFn sigs
= \n -> lookupNameEnv env n `orElse` []
where
env :: NameEnv [Name]
env = mkNameEnv [ (name, hsLKiTyVarNames ltvs)
| L _ (TypeSig names
(L _ (HsForAllTy Explicit ltvs _ _))) <- sigs
, (L _ name) <- names]
\end{code}
@rnMethodBinds@ is used for the method bindings of a class and an instance
declaration. Like @rnBinds@ but without dependency analysis.
NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.
That's crucial when dealing with an instance decl:
\begin{verbatim}
instance Foo (T a) where
op x = ...
\end{verbatim}
This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,
and unless @op@ occurs we won't treat the type signature of @op@ in the class
decl for @Foo@ as a source of instance-decl gates. But we should! Indeed,
in many ways the @op@ in an instance decl is just like an occurrence, not
a binder.
\begin{code}
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) (origin,bind)
= do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
; let bind'' = mapBag (\bind -> (origin,bind)) 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 } }))
= 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 = mkMatchGroup 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 _ _ b = pprPanic "rnMethodBind" (ppr b)
\end{code}
%************************************************************************
%* *
\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
%* *
%************************************************************************
@renameSigs@ checks for:
\begin{enumerate}
\item more than one sig for one thing;
\item signatures given for things not bound here;
\end{enumerate}
%
At the moment we don't gather free-var info from the types in
signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
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
; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
; return (TypeSig new_vs new_ty, 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 ty)
= do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty
; return (SpecInstSig new_ty,fvs) }
renameSig ctxt sig@(SpecSig v ty inl)
= do { new_v <- case ctxt of
TopSigCtxt {} -> lookupLocatedOccRn v
_ -> lookupSigOccRn ctxt sig v
; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
; return (SpecSig new_v new_ty inl, 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 v f))
= do { new_v <- lookupSigOccRn ctxt sig v
; return (FixSig (FixitySig new_v f), emptyFVs) }
renameSig ctxt sig@(MinimalSig bf)
= do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
return (MinimalSig new_bf, emptyFVs)
renameSig ctxt sig@(PatSynSig v args ty prov req)
= do v' <- lookupSigOccRn ctxt sig v
let doc = quotes (ppr v)
rn_type = rnHsSigType doc
(ty', fvs1) <- rn_type ty
(args', fvs2) <- case args of
PrefixPatSyn tys ->
do (tys, fvs) <- unzip <$> mapM rn_type tys
return (PrefixPatSyn tys, plusFVs fvs)
InfixPatSyn left right ->
do (left', fvs1) <- rn_type left
(right', fvs2) <- rn_type right
return (InfixPatSyn left' right', fvs1 `plusFV` fvs2)
(prov', fvs3) <- rnContext (TypeSigCtx doc) prov
(req', fvs4) <- rnContext (TypeSigCtx doc) req
let fvs = plusFVs [fvs1, fvs2, fvs3, fvs4]
return (PatSynSig v' args' ty' prov' req', 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 n _)) = [(n,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 ()
\end{code}
%************************************************************************
%* *
\subsection{Match}
%* *
%************************************************************************
\begin{code}
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 })
= 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 (mkMatchGroup 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 pats maybe_rhs_sig 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
; return (Match pats' Nothing 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 ]
\end{code}
%************************************************************************
%* *
\subsubsection{Guarded right-hand sides (GRHSs)}
%* *
%************************************************************************
\begin{code}
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
\end{code}
%************************************************************************
%* *
\subsection{Error messages}
%* *
%************************************************************************
\begin{code}
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)
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"
\end{code}