%
% (c) The GRASP/AQUA Project, Glasgow University, 19921998
%
\section[RnSource]{Main pass of renamer}
\begin{code}
module RnSource (
rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice
) where
#include "HsVersions.h"
import RnExpr( rnLExpr )
#ifdef GHCI
import TcSplice ( runQuasiQuoteDecl )
#endif /* GHCI */
import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
makeMiniFixityEnv)
import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
lookupTopBndrRn, lookupLocatedTopBndrRn,
lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
bindLocalNames, checkDupRdrNames, mapFvRn
)
import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn )
import HscTypes ( GenAvailInfo(..), availsToNameSet )
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
import ForeignCall ( CCallTarget(..) )
import Module
import HscTypes ( Warnings(..), plusWarns )
import Class ( FunDep )
import Name ( Name, nameOccName )
import NameSet
import NameEnv
import Outputable
import Bag
import FastString
import Util ( filterOut )
import SrcLoc
import DynFlags
import HscTypes ( HscEnv, hsc_dflags )
import BasicTypes ( Boxity(..) )
import ListSetOps ( findDupsEq )
import Control.Monad
import Data.Maybe
\end{code}
\begin{code}
thenM :: Monad a => a b -> (b -> a c) -> a c
thenM = (>>=)
thenM_ :: Monad a => a b -> a c -> a c
thenM_ = (>>)
\end{code}
@rnSourceDecl@ `renames' declarations.
It simultaneously performs dependency analysis and precedence parsing.
It also does the following error checks:
\begin{enumerate}
\item
Checks that tyvars are used properly. This includes checking
for undefined tyvars, and tyvars in contexts that are ambiguous.
(Some of this checking has now been moved to module @TcMonoType@,
since we don't have functional dependency information at this point.)
\item
Checks that all variable occurences are defined.
\item
Checks the @(..)@ etc constraints in the export list.
\end{enumerate}
\begin{code}
rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
rnSrcDecls group@(HsGroup { hs_valds = val_decls,
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_derivds = deriv_decls,
hs_fixds = fix_decls,
hs_warnds = warn_decls,
hs_annds = ann_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_decls,
hs_docs = docs })
= do {
local_fix_env <- makeMiniFixityEnv fix_decls;
tc_avails <- getLocalNonValBinders group ;
tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ;
setEnvs tc_envs $ do {
failIfErrsM ;
inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
let { val_binders = collectHsValBinders new_lhs ;
val_bndr_set = mkNameSet val_binders ;
all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
val_avails = map Avail val_binders
} ;
(tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
setEnvs (tcg_env, tcl_env) $ do {
traceRn (text "Start rnTyClDecls") ;
(rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
traceRn (text "Start rnmono") ;
(rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ;
traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
(rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ;
(rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $
rnList rnHsRuleDecl rule_decls ;
(rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
(rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ;
(rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ;
(rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ;
rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
let {rn_group = HsGroup { hs_valds = rn_val_decls,
hs_tyclds = rn_tycl_decls,
hs_instds = rn_inst_decls,
hs_derivds = rn_deriv_decls,
hs_fixds = rn_fix_decls,
hs_warnds = [],
hs_fords = rn_foreign_decls,
hs_annds = rn_ann_decls,
hs_defds = rn_default_decls,
hs_ruleds = rn_rule_decls,
hs_docs = rn_docs } ;
tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
src_fvs5, src_fvs6, src_fvs7] ;
src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
in
tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
} ;
traceRn (text "finish rnSrc" <+> ppr rn_group) ;
traceRn (text "finish Dus" <+> ppr src_dus ) ;
return (final_tcg_env, rn_group)
}}}}
inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
inNewEnv env cont = do e <- env
setGblEnv e $ cont e
rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
rnTyClDecls tycl_decls = do (decls', _fvs) <- rnList rnTyClDecl tycl_decls
return decls'
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
rnList f xs = mapFvRn (wrapLocFstM f) xs
\end{code}
%*********************************************************
%* *
HsDoc stuff
%* *
%*********************************************************
\begin{code}
rnDocDecl :: DocDecl -> RnM DocDecl
rnDocDecl (DocCommentNext doc) = do
rn_doc <- rnHsDoc doc
return (DocCommentNext rn_doc)
rnDocDecl (DocCommentPrev doc) = do
rn_doc <- rnHsDoc doc
return (DocCommentPrev rn_doc)
rnDocDecl (DocCommentNamed str doc) = do
rn_doc <- rnHsDoc doc
return (DocCommentNamed str rn_doc)
rnDocDecl (DocGroup lev doc) = do
rn_doc <- rnHsDoc doc
return (DocGroup lev rn_doc)
\end{code}
%*********************************************************
%* *
Sourcecode fixity declarations
%* *
%*********************************************************
\begin{code}
rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
rnSrcFixityDecls bound_names fix_decls
= do fix_decls <- mapM rn_decl fix_decls
return (concat fix_decls)
where
rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
= setSrcSpan name_loc $
do names <- lookupLocalDataTcNames bound_names what rdr_name
return [ L loc (FixitySig (L name_loc name) fixity)
| name <- names ]
what = ptext (sLit "fixity signature")
\end{code}
%*********************************************************
%* *
Sourcecode deprecations declarations
%* *
%*********************************************************
Check that the deprecated names are defined, are defined locally, and
that there are no duplicate deprecations.
It's only imported deprecations, dealt with in RnIfaces, that we
gather them together.
\begin{code}
rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
rnSrcWarnDecls _bound_names []
= return NoWarnings
rnSrcWarnDecls bound_names decls
= do {
; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
in addErrAt loc (dupWarnDecl lrdr' rdr))
warn_rdr_dups
; pairs_s <- mapM (addLocM rn_deprec) decls
; return (WarnSome ((concat pairs_s))) }
where
rn_deprec (Warning rdr_name txt)
= lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names ->
return [(nameOccName name, txt) | name <- names]
what = ptext (sLit "deprecation")
warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
(map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
dupWarnDecl :: Located RdrName -> RdrName -> SDoc
dupWarnDecl (L loc _) rdr_name
= vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
ptext (sLit "also at ") <+> ppr loc]
\end{code}
%*********************************************************
%* *
\subsection{Annotation declarations}
%* *
%*********************************************************
\begin{code}
rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
rnAnnDecl (HsAnnotation provenance expr) = do
(provenance', provenance_fvs) <- rnAnnProvenance provenance
(expr', expr_fvs) <- rnLExpr expr
return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs)
rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
rnAnnProvenance provenance = do
provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance
return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
\end{code}
%*********************************************************
%* *
\subsection{Default declarations}
%* *
%*********************************************************
\begin{code}
rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
rnDefaultDecl (DefaultDecl tys)
= mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) ->
return (DefaultDecl tys', fvs)
where
doc_str = text "In a `default' declaration"
\end{code}
%*********************************************************
%* *
\subsection{Foreign declarations}
%* *
%*********************************************************
\begin{code}
rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
rnHsForeignDecl (ForeignImport name ty spec)
= getTopEnv `thenM` \ (topEnv :: HscEnv) ->
lookupLocatedTopBndrRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
let packageId = thisPackage $ hsc_dflags topEnv
spec' = patchForeignImport packageId spec
in return (ForeignImport name' ty' spec', fvs)
rnHsForeignDecl (ForeignExport name ty spec)
= lookupLocatedOccRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
return (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name')
fo_decl_msg :: Located RdrName -> SDoc
fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
patchForeignImport :: PackageId -> ForeignImport -> ForeignImport
patchForeignImport packageId (CImport cconv safety fs spec)
= CImport cconv safety fs (patchCImportSpec packageId spec)
patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec
patchCImportSpec packageId spec
= case spec of
CFunction callTarget -> CFunction $ patchCCallTarget packageId callTarget
_ -> spec
patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
patchCCallTarget packageId callTarget
= case callTarget of
StaticTarget label Nothing
-> StaticTarget label (Just packageId)
_ -> callTarget
\end{code}
%*********************************************************
%* *
\subsection{Instance declarations}
%* *
%*********************************************************
\begin{code}
rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
= rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' ->
let
meth_names = collectMethodBinders mbinds
(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
in
checkDupRdrNames meth_names `thenM_`
extendTyVarEnvForMethodBinds inst_tyvars (
rnMethodBinds cls (\_ -> [])
[] mbinds
) `thenM` \ (mbinds', meth_fvs) ->
let
at_names = map (head . hsTyClDeclBinders) ats
in
checkDupRdrNames at_names `thenM_`
rnATInsts ats `thenM` \ (ats', at_fvs) ->
let
binders = collectHsBindsBinders mbinds'
bndr_set = mkNameSet binders
in
bindLocalNames binders
(renameSigs (Just bndr_set) okInstDclSig uprags) `thenM` \ uprags' ->
return (InstDecl inst_ty' mbinds' uprags' ats',
meth_fvs `plusFV` at_fvs
`plusFV` hsSigsFVs uprags'
`plusFV` extractHsTyNames inst_ty')
\end{code}
Renaming of the associated types in instances.
\begin{code}
rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
rnATInsts atDecls = rnList rnATInst atDecls
where
rnATInst tydecl@TyData {} = rnTyClDecl tydecl
rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl
rnATInst tydecl =
pprPanic "RnSource.rnATInsts: invalid AT instance"
(ppr (tcdName tydecl))
\end{code}
For the method bindings in class and instance decls, we extend the
type variable environment iff fglasgowexts
\begin{code}
extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
-> RnM (Bag (LHsBind Name), FreeVars)
-> RnM (Bag (LHsBind Name), FreeVars)
extendTyVarEnvForMethodBinds tyvars thing_inside
= do { scoped_tvs <- xoptM Opt_ScopedTypeVariables
; if scoped_tvs then
extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
else
thing_inside }
\end{code}
%*********************************************************
%* *
\subsection{Standalone deriving declarations}
%* *
%*********************************************************
\begin{code}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
rnSrcDerivDecl (DerivDecl ty)
= do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
; unless standalone_deriv_ok (addErr standaloneDerivErr)
; ty' <- rnLHsType (text "a deriving decl") ty
; let fvs = extractHsTyNames ty'
; return (DerivDecl ty', fvs) }
standaloneDerivErr :: SDoc
standaloneDerivErr
= hang (ptext (sLit "Illegal standalone deriving declaration"))
2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
\end{code}
%*********************************************************
%* *
\subsection{Rules}
%* *
%*********************************************************
\begin{code}
rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
= bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $
bindLocatedLocalsFV (map get_var vars) $ \ ids ->
do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
; (lhs', fv_lhs') <- rnLExpr lhs
; (rhs', fv_rhs') <- rnLExpr rhs
; checkValidRule rule_name ids lhs' fv_lhs'
; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
where
doc = text "In the transformation rule" <+> ftext rule_name
get_var (RuleBndr v) = v
get_var (RuleBndrSig v _) = v
rn_var (RuleBndr (L loc _), id)
= return (RuleBndr (L loc id), emptyFVs)
rn_var (RuleBndrSig (L loc _) t, id)
= rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
return (RuleBndrSig (L loc id) t', fvs)
badRuleVar :: FastString -> Name -> SDoc
badRuleVar name var
= sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
ptext (sLit "does not appear on left hand side")]
\end{code}
Note [Rule LHS validity checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Check the shape of a transformation rule LHS. Currently we only allow
LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
@forall@'d variables.
We used restrict the form of the 'ei' to prevent you writing rules
with LHSs with a complicated desugaring (and hence unlikely to match);
(e.g. a case expression is not allowed: too elaborate.)
But there are legitimate nontrivial args ei, like sections and
lambdas. So it seems simmpler not to check at all, and that is why
check_e is commented out.
\begin{code}
checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
checkValidRule rule_name ids lhs' fv_lhs'
= do {
case (validRuleLhs ids lhs') of
Nothing -> return ()
Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
; mapM_ (addErr . badRuleVar rule_name) bad_vars }
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
validRuleLhs foralls lhs
= checkl lhs
where
checkl (L _ e) = check e
check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
check (HsVar v) | v `notElem` foralls = Nothing
check other = Just other
checkl_e (L _ _e) = Nothing
badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
badRuleLhsErr name lhs bad_e
= sep [ptext (sLit "Rule") <+> ftext name <> colon,
nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e,
ptext (sLit "in left-hand side:") <+> ppr lhs])]
$$
ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
\end{code}
%*********************************************************
%* *
\subsection{Type, class and iface sig declarations}
%* *
%*********************************************************
@rnTyDecl@ uses the `global name function' to create a new type
declaration in which local names have been replaced by their original
names, reporting any unknown names.
Renaming type variables is a pain. Because they now contain uniques,
it is necessary to pass in an association list which maps a parsed
tyvar to its @Name@ representation.
In some cases (type signatures of values),
it is even necessary to go over the type first
in order to get the set of tyvars used by it, make an assoc list,
and then go over it again to rename the tyvars!
However, we can also do some scoping checks at the same time.
\begin{code}
rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
= lookupLocatedTopBndrRn name `thenM` \ name' ->
return (ForeignType {tcdLName = name', tcdExtName = ext_name},
emptyFVs)
rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV
rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
tcdLName = tycon, tcdTyVars = tyvars,
tcdTyPats = typats, tcdCons = condecls,
tcdKindSig = sig, tcdDerivs = derivs}
= do { tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon
else lookupLocatedTopBndrRn tycon
; checkTc (h98_style || null (unLoc context))
(badGadtStupidTheta tycon)
; ((tyvars', context', typats', derivs'), stuff_fvs)
<- bindTyVarsFV tyvars $ \ tyvars' -> do
{ context' <- rnContext data_doc context
; (typats', fvs1) <- rnTyPats data_doc tycon' typats
; (derivs', fvs2) <- rn_derivs derivs
; let fvs = fvs1 `plusFV` fvs2 `plusFV`
extractHsCtxtTyNames context'
; return ((tyvars', context', typats', derivs'), fvs) }
; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
| otherwise = []
; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
rnConDecls condecls
; return (TyData {tcdND = new_or_data, tcdCtxt = context',
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = typats', tcdKindSig = sig,
tcdCons = condecls', tcdDerivs = derivs'},
con_fvs `plusFV` stuff_fvs)
}
where
h98_style = case condecls of
L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False
_ -> True
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
rn_derivs Nothing = return (Nothing, emptyFVs)
rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
return (Just ds', extractHsTyNames_s ds')
rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
tcdTyPats = typats, tcdSynRhs = ty})
= bindTyVarsFV tyvars $ \ tyvars' -> do
{
name' <- if isFamInstDecl tydecl
then lookupLocatedOccRn name
else lookupLocatedTopBndrRn name
; (typats',fvs1) <- rnTyPats syn_doc name' typats
; (ty', fvs2) <- rnHsTypeFVs syn_doc ty
; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
, tcdTyPats = typats', tcdSynRhs = ty'},
fvs1 `plusFV` fvs2) }
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
= do { cname' <- lookupLocatedTopBndrRn cname
; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
<- bindTyVarsFV tyvars $ \ tyvars' -> do
{ context' <- rnContext cls_doc context
; fds' <- rnFds cls_doc fds
; (ats', at_fvs) <- rnATs ats
; sigs' <- renameSigs Nothing okClsDclSig sigs
; let fvs = at_fvs `plusFV`
extractHsCtxtTyNames context' `plusFV`
hsSigsFVs sigs'
; return ((tyvars', context', fds', ats', sigs'), fvs) }
; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
; checkDupRdrNames sig_rdr_names_w_locs
; (mbinds', meth_fvs)
<- extendTyVarEnvForMethodBinds tyvars' $ do
{ name_env <- getLocalRdrEnv
; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
not (unLoc tv `elemLocalRdrEnv` name_env) ]
; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
; docs' <- mapM (wrapLocM rnDocDecl) docs
; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
meth_fvs `plusFV` stuff_fvs) }
where
cls_doc = text "In the declaration for class" <+> ppr cname
badGadtStupidTheta :: Located RdrName -> SDoc
badGadtStupidTheta _
= vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
ptext (sLit "(You can put a context on each contructor, though.)")]
\end{code}
Note [Stupid theta]
~~~~~~~~~~~~~~~~~~~
Trac #3850 complains about a regression wrt 6.10 for
data Show a => T a
There is no reason not to allow the stupid theta if there are no data
constructors. It's still stupid, but does no harm, and I don't want
to cause programs to break unnecessarily (notably HList). So if there
are no data constructors we allow h98_style = True
%*********************************************************
%* *
\subsection{Support code for type/data declarations}
%* *
%*********************************************************
\begin{code}
rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
rnTyPats _ _ Nothing
= return (Nothing, emptyFVs)
rnTyPats doc tc (Just typats)
= do { typats' <- rnLHsTypes doc typats
; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc)
; return (Just typats', fvs) }
rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
rnConDecls condecls
= do { condecls' <- mapM (wrapLocM rnConDecl) condecls
; return (condecls', plusFVs (map conDeclFVs condecls')) }
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
, con_cxt = cxt, con_details = details
, con_res = res_ty, con_doc = mb_doc
, con_old_rec = old_rec, con_explicit = expl })
= do { addLocM checkConName name
; when old_rec (addWarn (deprecRecSyntax decl))
; new_name <- lookupLocatedTopBndrRn name
; rdr_env <- getLocalRdrEnv
; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc
arg_tys = hsConDeclArgTys details
implicit_tvs = case res_ty of
ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
new_tvs = case expl of
Explicit -> tvs
Implicit -> userHsTyVarBndrs implicit_tvs
; mb_doc' <- rnMbLHsDoc mb_doc
; bindTyVarsRn new_tvs $ \new_tyvars -> do
{ new_context <- rnContext doc cxt
; new_details <- rnConDeclDetails doc details
; (new_details', new_res_ty) <- rnConResult doc new_details res_ty
; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
, con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
rnConResult :: SDoc
-> HsConDetails (LHsType Name) [ConDeclField Name]
-> ResType RdrName
-> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
ResType Name)
rnConResult _ details ResTyH98 = return (details, ResTyH98)
rnConResult doc details (ResTyGADT ty)
= do { ty' <- rnLHsType doc ty
; let (arg_tys, res_ty) = splitHsFunType ty'
details' = case details of
RecCon {} -> details
PrefixCon {} -> PrefixCon arg_tys
InfixCon {} -> pprPanic "rnConResult" (ppr ty)
; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
(addErr (badRecResTy doc))
; return (details', ResTyGADT res_ty) }
rnConDeclDetails :: SDoc
-> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
-> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
rnConDeclDetails doc (PrefixCon tys)
= mapM (rnLHsType doc) tys `thenM` \ new_tys ->
return (PrefixCon new_tys)
rnConDeclDetails doc (InfixCon ty1 ty2)
= rnLHsType doc ty1 `thenM` \ new_ty1 ->
rnLHsType doc ty2 `thenM` \ new_ty2 ->
return (InfixCon new_ty1 new_ty2)
rnConDeclDetails doc (RecCon fields)
= do { new_fields <- rnConDeclFields doc fields
; return (RecCon new_fields) }
rnFamily :: TyClDecl RdrName
-> ([LHsTyVarBndr RdrName] ->
([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
RnM (TyClDecl Name, FreeVars))
-> RnM (TyClDecl Name, FreeVars)
rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
tcdLName = tycon, tcdTyVars = tyvars})
bindIdxVars =
do { bindIdxVars tyvars $ \tyvars' -> do {
; tycon' <- lookupLocatedTopBndrRn tycon
; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
emptyFVs)
} }
rnFamily d _ = pprPanic "rnFamily" (ppr d)
rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
where
rn_at (tydecl@TyFamily {}) = rnFamily tydecl lookupIdxVars
rn_at (tydecl@TySynonym {}) =
do
unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
rnTyClDecl tydecl
rn_at _ = panic "RnSource.rnATs: invalid TyClDecl"
lookupIdxVars tyvars cont =
do { checkForDups tyvars
; tyvars' <- mapM lookupIdxVar tyvars
; cont tyvars'
}
lookupIdxVar (L l tyvar) =
do
name' <- lookupOccRn (hsTyVarName tyvar)
return $ L l (replaceTyVarName tyvar name')
checkForDups [] = return ()
checkForDups (L loc tv:ltvs) =
do { setSrcSpan loc $
when (hsTyVarName tv `ltvElem` ltvs) $
addErr (repeatedTyVar tv)
; checkForDups ltvs
}
_ `ltvElem` [] = False
rdrName `ltvElem` (L _ tv:ltvs)
| rdrName == hsTyVarName tv = True
| otherwise = rdrName `ltvElem` ltvs
deprecRecSyntax :: ConDecl RdrName -> SDoc
deprecRecSyntax decl
= vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
<+> ptext (sLit "uses deprecated syntax")
, ptext (sLit "Instead, use the form")
, nest 2 (ppr decl) ]
badRecResTy :: SDoc -> SDoc
badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
noPatterns :: SDoc
noPatterns = text "Default definition for an associated synonym cannot have"
<+> text "type pattern"
repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
quotes (ppr tv)
checkConName :: RdrName -> TcRn ()
checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
badDataCon :: RdrName -> SDoc
badDataCon name
= hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
\end{code}
%*********************************************************
%* *
\subsection{Support code for type/data declarations}
%* *
%*********************************************************
Get the mapping from constructors to fields for this module.
It's convenient to do this after the data type decls have been renamed
\begin{code}
extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
extendRecordFieldEnv tycl_decls inst_decls
= do { tcg_env <- getGblEnv
; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
; return (tcg_env { tcg_field_env = field_env' }) }
where
lookup x = do { x' <- lookupLocatedTopBndrRn x
; return $ unLoc x'}
all_data_cons :: [ConDecl RdrName]
all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
, L _ con <- cons ]
all_tycl_decls = at_tycl_decls ++ tycl_decls
at_tycl_decls = instDeclATs inst_decls
get_con (ConDecl { con_name = con, con_details = RecCon flds })
(RecFields env fld_set)
= do { con' <- lookup con
; flds' <- mapM lookup (map cd_fld_name flds)
; let env' = extendNameEnv env con' flds'
fld_set' = addListToNameSet fld_set flds'
; return $ (RecFields env' fld_set') }
get_con _ env = return env
\end{code}
%*********************************************************
%* *
\subsection{Support code to rename types}
%* *
%*********************************************************
\begin{code}
rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
rnFds doc fds
= mapM (wrapLocM rn_fds) fds
where
rn_fds (tys1, tys2)
= rnHsTyVars doc tys1 `thenM` \ tys1' ->
rnHsTyVars doc tys2 `thenM` \ tys2' ->
return (tys1', tys2')
rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
rnHsTyVars doc tvs = mapM (rnHsTyVar doc) tvs
rnHsTyVar :: SDoc -> RdrName -> RnM Name
rnHsTyVar _doc tyvar = lookupOccRn tyvar
\end{code}
%*********************************************************
%* *
findSplice
%* *
%*********************************************************
This code marches down the declarations, looking for the first
Template Haskell splice. As it does so it
a) groups the declarations into a HsGroup
b) runs any toplevel quasiquotes
\begin{code}
findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
findSplice ds = addl emptyRdrGroup ds
addl :: HsGroup RdrName -> [LHsDecl RdrName]
-> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
addl gp [] = return (gp, Nothing)
addl gp (L l d : ds) = add gp l d ds
add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
-> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
= do {
case flag of
Explicit -> return ()
Implicit -> do { th_on <- xoptM Opt_TemplateHaskell
; unless th_on $ setSrcSpan loc $
failWith badImplicitSplice }
; return (gp, Just (splice, ds)) }
where
badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
#ifndef GHCI
add _ _ (QuasiQuoteD qq) _
= pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq)
#else
add gp _ (QuasiQuoteD qq) ds
= do { ds' <- runQuasiQuoteDecl qq
; addl gp (ds' ++ ds) }
#endif
add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
| isClassDecl d
= let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
| otherwise
= addl (gp { hs_tyclds = L l d : ts }) ds
add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
= addl (gp {hs_fixds = L l f : ts}) ds
add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
= addl (gp {hs_valds = add_sig (L l d) ts}) ds
add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
= addl (gp { hs_valds = add_bind (L l d) ts }) ds
add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
= addl (gp { hs_instds = L l d : ts }) ds
add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
= addl (gp { hs_derivds = L l d : ts }) ds
add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
= addl (gp { hs_defds = L l d : ts }) ds
add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
= addl (gp { hs_fords = L l d : ts }) ds
add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
= addl (gp { hs_warnds = L l d : ts }) ds
add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
= addl (gp { hs_annds = L l d : ts }) ds
add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
= addl (gp { hs_ruleds = L l d : ts }) ds
add gp l (DocD d) ds
= addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
add_sig :: LSig a -> HsValBinds a -> HsValBinds a
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
\end{code}