module RnSource (
rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice
) where
#include "HsVersions.h"
import RnExpr( rnLExpr )
import RnSplice ( rnSpliceDecl )
import TcSplice ( runQuasiQuoteDecl )
import HsSyn
import RdrName
import RnTypes
import RnBinds
import RnEnv
import RnNames
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcAnnotations ( annCtxt )
import TcRnMonad
import ForeignCall ( CCallTarget(..) )
import Module
import HscTypes ( Warnings(..), plusWarns )
import Class ( FunDep )
import PrelNames ( isUnboundName )
import Name
import NameSet
import NameEnv
import Avail
import Outputable
import Bag
import BasicTypes ( RuleName )
import FastString
import SrcLoc
import DynFlags
import HscTypes ( HscEnv, hsc_dflags )
import ListSetOps ( findDupsEq, removeDups )
import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
import Util ( mapSnd )
import Control.Monad
import Data.List( partition, sortBy )
#if __GLASGOW_HASKELL__ < 709
import Data.Traversable (traverse)
#endif
import Maybes( orElse, mapMaybe )
rnSrcDecls :: [Name] -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
hs_splcds = splice_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_vects = vect_decls,
hs_docs = docs })
= do {
local_fix_env <- makeMiniFixityEnv fix_decls ;
(tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
setEnvs tc_envs $ do {
failIfErrsM ;
inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
let { val_binders = collectHsIdBinders new_lhs ;
all_bndrs = extendNameSetList tc_bndrs val_binders ;
val_avails = map Avail val_binders } ;
traceRn (text "rnSrcDecls" <+> ppr val_avails) ;
(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) <- rnTyClDecls extra_deps tycl_decls ;
traceRn (text "Start rnmono") ;
(rn_val_decls, bind_dus) <- rnTopBindsRHS all_bndrs new_lhs ;
traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
(rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ;
(rn_rule_decls, src_fvs3) <- setXOptM Opt_ScopedTypeVariables $
rnList rnHsRuleDecls rule_decls ;
(rn_vect_decls, src_fvs4) <- rnList rnHsVectDecl vect_decls ;
(rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ;
(rn_ann_decls, src_fvs6) <- rnList rnAnnDecl ann_decls ;
(rn_default_decls, src_fvs7) <- rnList rnDefaultDecl default_decls ;
(rn_deriv_decls, src_fvs8) <- rnList rnSrcDerivDecl deriv_decls ;
(rn_splice_decls, src_fvs9) <- rnList rnSpliceDecl splice_decls ;
rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
last_tcg_env <- getGblEnv ;
let {rn_group = HsGroup { hs_valds = rn_val_decls,
hs_splcds = rn_splice_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_vects = rn_vect_decls,
hs_docs = rn_docs } ;
tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_inst_decls rn_foreign_decls ;
other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
src_fvs5, src_fvs6, src_fvs7, src_fvs8,
src_fvs9] ;
src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
final_tcg_env = let tcg_env' = (last_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
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
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)
rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
rnSrcFixityDecls bndr_set fix_decls
= do fix_decls <- mapM rn_decl fix_decls
return (concat fix_decls)
where
sig_ctxt = TopSigCtxt bndr_set True
rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
rn_decl (L loc (FixitySig fnames fixity))
= do names <- mapM lookup_one fnames
return [ L loc (FixitySig name fixity)
| name <- names ]
lookup_one :: Located RdrName -> RnM [Located Name]
lookup_one (L name_loc rdr_name)
= setSrcSpan name_loc $
do names <- lookupLocalTcNames sig_ctxt what rdr_name
return [ L name_loc name | name <- names ]
what = ptext (sLit "fixity signature")
rnSrcWarnDecls :: NameSet -> [LWarnDecls RdrName] -> RnM Warnings
rnSrcWarnDecls _ []
= return NoWarnings
rnSrcWarnDecls bndr_set 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
decls = concatMap (\(L _ d) -> wd_warnings d) decls'
sig_ctxt = TopSigCtxt bndr_set True
rn_deprec (Warning rdr_names txt)
= do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
rdr_names
; return [(nameOccName name, txt) | name <- names] }
what = ptext (sLit "deprecation")
warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
decls
findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
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]
rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
rnAnnDecl ann@(HsAnnotation s provenance expr)
= addErrCtxt (annCtxt ann) $
do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
; (expr', expr_fvs) <- setStage (Splice False) $
rnLExpr expr
; return (HsAnnotation s provenance' expr',
provenance_fvs `plusFV` expr_fvs) }
rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
rnAnnProvenance provenance = do
provenance' <- traverse lookupTopBndrRn provenance
return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
rnDefaultDecl (DefaultDecl tys)
= do { (tys', fvs) <- rnLHsTypes doc_str tys
; return (DefaultDecl tys', fvs) }
where
doc_str = DefaultDeclCtx
rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
rnHsForeignDecl (ForeignImport name ty _ spec)
= do { topEnv :: HscEnv <- getTopEnv
; name' <- lookupLocatedTopBndrRn name
; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
; let packageKey = thisPackage $ hsc_dflags topEnv
spec' = patchForeignImport packageKey spec
; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) }
rnHsForeignDecl (ForeignExport name ty _ spec)
= do { name' <- lookupLocatedOccRn name
; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
patchForeignImport :: PackageKey -> ForeignImport -> ForeignImport
patchForeignImport packageKey (CImport cconv safety fs spec src)
= CImport cconv safety fs (patchCImportSpec packageKey spec) src
patchCImportSpec :: PackageKey -> CImportSpec -> CImportSpec
patchCImportSpec packageKey spec
= case spec of
CFunction callTarget -> CFunction $ patchCCallTarget packageKey callTarget
_ -> spec
patchCCallTarget :: PackageKey -> CCallTarget -> CCallTarget
patchCCallTarget packageKey callTarget =
case callTarget of
StaticTarget label Nothing isFun -> StaticTarget label (Just packageKey) isFun
_ -> callTarget
rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
= do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
= do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
rnSrcInstDecl (ClsInstD { cid_inst = cid })
= do { (cid', fvs) <- rnClsInstDecl cid
; return (ClsInstD { cid_inst = cid' }, fvs) }
rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
, cid_sigs = uprags, cid_tyfam_insts = ats
, cid_overlap_mode = oflag
, cid_datafam_insts = adts })
= do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
; case splitLHsInstDeclTy_maybe inst_ty' of {
Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
, cid_sigs = [], cid_tyfam_insts = []
, cid_overlap_mode = oflag
, cid_datafam_insts = [] }
, inst_fvs) ;
Just (inst_tyvars, _, L _ cls,_) ->
do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
ktv_names = hsLKiTyVarNames inst_tyvars
; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
; ((ats', adts', other_sigs'), more_fvs)
<- extendTyVarEnvFVRn ktv_names $
do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts
; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
; return ( (ats', adts', other_sigs')
, at_fvs `plusFV` adt_fvs `plusFV` sig_fvs) }
; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $
rnMethodBinds cls (mkSigTvFn other_sigs')
mbinds
; (spec_inst_prags', spec_inst_fvs)
<- renameSigs (InstDeclCtxt cls) spec_inst_prags
; let uprags' = spec_inst_prags' ++ other_sigs'
all_fvs = meth_fvs `plusFV` more_fvs
`plusFV` spec_inst_fvs
`plusFV` inst_fvs
; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
, cid_sigs = uprags', cid_tyfam_insts = ats'
, cid_overlap_mode = oflag
, cid_datafam_insts = adts' },
all_fvs) } } }
rnFamInstDecl :: HsDocContext
-> Maybe (Name, [Name])
-> Located RdrName
-> [LHsType RdrName]
-> rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (Located Name, HsWithBndrs Name [LHsType Name], rhs',
FreeVars)
rnFamInstDecl doc mb_cls tycon pats payload rnPayload
= do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
; let loc = case pats of
[] -> pprPanic "rnFamInstDecl" (ppr tycon)
(L loc _ : []) -> loc
(L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
(kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
; rdr_env <- getLocalRdrEnv
; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
; ((pats', payload'), fvs)
<- bindLocalNamesFV kv_names $
bindLocalNamesFV tv_names $
do { (pats', pat_fvs) <- rnLHsTypes doc pats
; (payload', rhs_fvs) <- rnPayload doc payload
; let lhs_names = mkNameSet kv_names `unionNameSet` mkNameSet tv_names
bad_tvs = case mb_cls of
Nothing -> []
Just (_,cls_tkvs) -> filter is_bad cls_tkvs
is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
&& not (cls_tkv `elemNameSet` lhs_names)
; unless (null bad_tvs) (badAssocRhs bad_tvs)
; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
; let all_fvs = fvs `addOneFV` unLoc tycon'
; return (tycon',
HsWB { hswb_cts = pats', hswb_kvs = kv_names,
hswb_tvs = tv_names, hswb_wcs = [] },
payload',
all_fvs) }
rnTyFamInstDecl :: Maybe (Name, [Name])
-> TyFamInstDecl RdrName
-> RnM (TyFamInstDecl Name, FreeVars)
rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
= do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
; return (TyFamInstDecl { tfid_eqn = L loc eqn'
, tfid_fvs = fvs }, fvs) }
rnTyFamInstEqn :: Maybe (Name, [Name])
-> TyFamInstEqn RdrName
-> RnM (TyFamInstEqn Name, FreeVars)
rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
, tfe_pats = HsWB { hswb_cts = pats }
, tfe_rhs = rhs })
= do { (tycon', pats', rhs', fvs) <-
rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
; return (TyFamEqn { tfe_tycon = tycon'
, tfe_pats = pats'
, tfe_rhs = rhs' }, fvs) }
rnTyFamDefltEqn :: Name
-> TyFamDefltEqn RdrName
-> RnM (TyFamDefltEqn Name, FreeVars)
rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
, tfe_pats = tyvars
, tfe_rhs = rhs })
= bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
do { tycon' <- lookupFamInstName (Just cls) tycon
; (rhs', fvs) <- rnLHsType ctx rhs
; return (TyFamEqn { tfe_tycon = tycon'
, tfe_pats = tyvars'
, tfe_rhs = rhs' }, fvs) }
where
ctx = TyFamilyCtx tycon
rnDataFamInstDecl :: Maybe (Name, [Name])
-> DataFamInstDecl RdrName
-> RnM (DataFamInstDecl Name, FreeVars)
rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
, dfid_pats = HsWB { hswb_cts = pats }
, dfid_defn = defn })
= do { (tycon', pats', defn', fvs) <-
rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
; return (DataFamInstDecl { dfid_tycon = tycon'
, dfid_pats = pats'
, dfid_defn = defn'
, dfid_fvs = fvs }, fvs) }
rnATDecls :: Name
-> [LFamilyDecl RdrName]
-> RnM ([LFamilyDecl Name], FreeVars)
rnATDecls cls at_decls
= rnList (rnFamDecl (Just cls)) at_decls
rnATInstDecls :: (Maybe (Name, [Name]) ->
decl RdrName ->
RnM (decl Name, FreeVars))
-> Name
-> LHsTyVarBndrs Name
-> [Located (decl RdrName)]
-> RnM ([Located (decl Name)], FreeVars)
rnATInstDecls rnFun cls hs_tvs at_insts
= rnList (rnFun (Just (cls, tv_ns))) at_insts
where
tv_ns = hsLKiTyVarNames hs_tvs
extendTyVarEnvForMethodBinds :: [Name]
-> RnM (LHsBinds Name, FreeVars)
-> RnM (LHsBinds Name, FreeVars)
extendTyVarEnvForMethodBinds ktv_names thing_inside
= do { scoped_tvs <- xoptM Opt_ScopedTypeVariables
; if scoped_tvs then
extendTyVarEnvFVRn ktv_names thing_inside
else
thing_inside }
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
rnSrcDerivDecl (DerivDecl ty overlap)
= do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
; unless standalone_deriv_ok (addErr standaloneDerivErr)
; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
; return (DerivDecl ty' overlap, fvs) }
standaloneDerivErr :: SDoc
standaloneDerivErr
= hang (ptext (sLit "Illegal standalone deriving declaration"))
2 (ptext (sLit "Use StandaloneDeriving to enable this extension"))
rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars)
rnHsRuleDecls (HsRules src rules)
= do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
; return (HsRules src rn_rules,fvs) }
rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
= do { let rdr_names_w_loc = map get_var vars
; checkDupRdrNames rdr_names_w_loc
; checkShadowedRdrNames rdr_names_w_loc
; names <- newLocalBndrsRn rdr_names_w_loc
; bindHsRuleVars (unLoc rule_name) vars names $ \ vars' ->
do { (lhs', fv_lhs') <- rnLExpr lhs
; (rhs', fv_rhs') <- rnLExpr rhs
; checkValidRule (unLoc rule_name) names lhs' fv_lhs'
; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
fv_lhs' `plusFV` fv_rhs') } }
where
get_var (L _ (RuleBndrSig v _)) = v
get_var (L _ (RuleBndr v)) = v
bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name]
-> ([LRuleBndr Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsRuleVars rule_name vars names thing_inside
= go vars names $ \ vars' ->
bindLocalNamesFV names (thing_inside vars')
where
doc = RuleCtx rule_name
go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
= go vars ns $ \ vars' ->
thing_inside (L l (RuleBndr (L loc n)) : vars')
go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
= rnHsBndrSig doc bsig $ \ bsig' ->
go vars ns $ \ vars' ->
thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
go [] [] thing_inside = thing_inside []
go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
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
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")]
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")
rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))
= do { var' <- lookupLocatedOccRn var
; (rhs', fv_rhs) <- rnLExpr rhs
; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')
}
rnHsVectDecl (HsVect _ _var _rhs)
= failWith $ vcat
[ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma")
, ptext (sLit "must be an identifier")
]
rnHsVectDecl (HsNoVect s var)
= do { var' <- lookupLocatedTopBndrRn var
; return (HsNoVect s var', unitFV (unLoc var'))
}
rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)
= do { tycon' <- lookupLocatedOccRn tycon
; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))
}
rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))
= do { tycon' <- lookupLocatedOccRn tycon
; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')
, mkFVs [unLoc tycon', unLoc rhs_tycon'])
}
rnHsVectDecl (HsVectTypeOut _ _ _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
rnHsVectDecl (HsVectClassIn s cls)
= do { cls' <- lookupLocatedOccRn cls
; return (HsVectClassIn s cls', unitFV (unLoc cls'))
}
rnHsVectDecl (HsVectClassOut _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
rnHsVectDecl (HsVectInstIn instTy)
= do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy
; return (HsVectInstIn instTy', fvs)
}
rnHsVectDecl (HsVectInstOut _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
isInPackage :: PackageKey -> Name -> Bool
isInPackage pkgId nm = case nameModule_maybe nm of
Nothing -> False
Just m -> pkgId == modulePackageKey m
rnTyClDecls :: [Name] -> [TyClGroup RdrName]
-> RnM ([TyClGroup Name], FreeVars)
rnTyClDecls extra_deps tycl_ds
= do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
; let decl_names = mkNameSet (map (tcdName . unLoc . fst) ds_w_fvs)
; role_annot_env <- rnRoleAnnots decl_names (concatMap group_roles tycl_ds)
; thisPkg <- fmap thisPackage getDynFlags
; let add_boot_deps :: FreeVars -> FreeVars
add_boot_deps fvs | any (isInPackage thisPkg) (nameSetElems fvs)
= fvs `plusFV` mkFVs extra_deps
| otherwise
= fvs
ds_w_fvs' = mapSnd add_boot_deps ds_w_fvs
sccs :: [SCC (LTyClDecl Name)]
sccs = depAnalTyClDecls ds_w_fvs'
all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
raw_groups = map flattenSCC sccs
(groups, orphan_roles)
= foldr (\group (groups_acc, orphans_acc) ->
let names = map (tcdName . unLoc) group
roles = mapMaybe (lookupNameEnv orphans_acc) names
orphans' = delListFromNameEnv orphans_acc names
in ( TyClGroup { group_tyclds = group
, group_roles = roles } : groups_acc
, orphans' )
)
([], role_annot_env)
raw_groups
; mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
; traceRn (text "rnTycl" <+> (ppr ds_w_fvs $$ ppr sccs))
; return (groups, all_fvs) }
rnTyClDecl :: TyClDecl RdrName
-> RnM (TyClDecl Name, FreeVars)
rnTyClDecl (FamDecl { tcdFam = decl })
= do { (decl', fvs) <- rnFamDecl Nothing decl
; return (FamDecl decl', fvs) }
rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
= do { tycon' <- lookupLocatedTopBndrRn tycon
; let kvs = fst (extractHsTyRdrTyVars rhs)
doc = TySynCtx tycon
; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
; ((tyvars', rhs'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $
\ tyvars' ->
do { (rhs', fvs) <- rnTySyn doc rhs
; return ((tyvars', rhs'), fvs) }
; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
, tcdRhs = rhs', tcdFVs = fvs }, fvs) }
rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn })
= do { tycon' <- lookupLocatedTopBndrRn tycon
; let kvs = extractDataDefnKindVars defn
doc = TyDataCtx tycon
; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
; ((tyvars', defn'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $ \ tyvars' ->
do { (defn', fvs) <- rnDataDefn doc defn
; return ((tyvars', defn'), fvs) }
; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
, tcdDataDefn = defn', tcdFVs = fvs }, fvs) }
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
tcdDocs = docs})
= do { lcls' <- lookupLocatedTopBndrRn lcls
; let cls' = unLoc lcls'
kvs = []
; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
<- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
{ (context', cxt_fvs) <- rnContext cls_doc context
; fds' <- rnFds fds
; (ats', fv_ats) <- rnATDecls cls' ats
; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
; let fvs = cxt_fvs `plusFV`
sig_fvs `plusFV`
fv_ats
; return ((tyvars', context', fds', ats', sigs'), fvs) }
; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _ _) <- sigs, op <- ops]
; checkDupRdrNames sig_rdr_names_w_locs
; (mbinds', meth_fvs)
<- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $
rnMethodBinds cls' (mkSigTvFn sigs') mbinds
; docs' <- mapM (wrapLocM rnDocDecl) docs
; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
tcdDocs = docs', tcdFVs = all_fvs },
all_fvs ) }
where
cls_doc = ClassDeclCtx lcls
rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnTySyn doc rhs = rnLHsType doc rhs
rnRoleAnnots :: NameSet
-> [LRoleAnnotDecl RdrName]
-> RnM (NameEnv (LRoleAnnotDecl Name))
rnRoleAnnots decl_names role_annots
= do {
let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
role_annots_cmp (L _ annot1) (L _ annot2)
= roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
; mapM_ dupRoleAnnotErr dup_annots
; role_annots' <- mapM (wrapLocM rn_role_annot1) no_dups
; return $ mkNameEnv [ (name, ra)
| ra <- role_annots'
, let name = roleAnnotDeclName (unLoc ra)
, not (isUnboundName name) ] }
where
rn_role_annot1 (RoleAnnotDecl tycon roles)
= do {
tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt decl_names)
(text "role annotation")
tycon
; return $ RoleAnnotDecl tycon' roles }
dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
dupRoleAnnotErr list
= addErrAt loc $
hang (text "Duplicate role annotations for" <+>
quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
2 (vcat $ map pp_role_annot sorted_list)
where
sorted_list = sortBy cmp_annot list
(L loc first_decl : _) = sorted_list
pp_role_annot (L loc decl) = hang (ppr decl)
4 (text "-- written at" <+> ppr loc)
cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()
orphanRoleAnnotErr (L loc decl)
= addErrAt loc $
hang (text "Role annotation for a type previously declared:")
2 (ppr decl) $$
parens (text "The role annotation must be given where" <+>
quotes (ppr $ roleAnnotDeclName decl) <+>
text "is declared.")
rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = context, dd_cons = condecls
, dd_kindSig = sig, dd_derivs = derivs })
= do { checkTc (h98_style || null (unLoc context))
(badGadtStupidTheta doc)
; (sig', sig_fvs) <- rnLHsMaybeKind doc sig
; (context', fvs1) <- rnContext doc context
; (derivs', fvs3) <- rn_derivs derivs
; let { zap_lcl_env | h98_style = \ thing -> thing
| otherwise = setLocalRdrEnv emptyLocalRdrEnv }
; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
con_fvs `plusFV` sig_fvs
; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = context', dd_kindSig = sig'
, dd_cons = condecls'
, dd_derivs = derivs' }
, all_fvs )
}
where
h98_style = case condecls of
L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False
_ -> True
rn_derivs Nothing = return (Nothing, emptyFVs)
rn_derivs (Just (L ld ds)) = do { (ds', fvs) <- rnLHsTypes doc ds
; return (Just (L ld ds'), fvs) }
badGadtStupidTheta :: HsDocContext -> 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.)")]
rnFamDecl :: Maybe Name
-> FamilyDecl RdrName
-> RnM (FamilyDecl Name, FreeVars)
rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
, fdInfo = info, fdKindSig = kind })
= do { ((tycon', tyvars', kind'), fv1) <-
bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' ->
do { tycon' <- lookupLocatedTopBndrRn tycon
; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
; return ((tycon', tyvars', kind'), fv_kind) }
; (info', fv2) <- rn_info info
; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
, fdInfo = info', fdKindSig = kind' }
, fv1 `plusFV` fv2) }
where
fmly_doc = TyFamilyCtx tycon
kvs = extractRdrKindSigVars kind
rn_info (ClosedTypeFamily eqns)
= do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
; return (ClosedTypeFamily eqns', fvs) }
rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
rn_info DataFamily = return (DataFamily, emptyFVs)
depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
depAnalTyClDecls ds_w_fvs
= stronglyConnCompFromEdgedVertices edges
where
edges = [ (d, tcdName (unLoc d), map get_parent (nameSetElems fvs))
| (d, fvs) <- ds_w_fvs ]
get_parent n = lookupNameEnv assoc_env n `orElse` n
assoc_env :: NameEnv Name
assoc_env = mkNameEnv $ concat assoc_env_list
assoc_env_list = do
(L _ d, _) <- ds_w_fvs
case d of
ClassDecl { tcdLName = L _ cls_name
, tcdATs = ats }
-> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats
return [(fam_name, cls_name)]
DataDecl { tcdLName = L _ data_name
, tcdDataDefn = HsDataDefn { dd_cons = cons } }
-> do L _ dc <- cons
return $ zip (map unLoc $ con_names dc) (repeat data_name)
_ -> []
badAssocRhs :: [Name] -> RnM ()
badAssocRhs ns
= addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions")
<+> pprWithCommas (quotes . ppr) ns)
2 (ptext (sLit "All such variables must be bound on the LHS")))
rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs
, con_cxt = lcxt@(L loc cxt), con_details = details
, con_res = res_ty, con_doc = mb_doc
, con_old_rec = old_rec, con_explicit = expl })
= do { mapM_ (addLocM checkConName) names
; when old_rec (addWarn (deprecRecSyntax decl))
; new_names <- mapM lookupLocatedTopBndrRn names
; rdr_env <- getLocalRdrEnv
; let arg_tys = hsConDeclArgTys details
(free_kvs, free_tvs) = case res_ty of
ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys)
ResTyGADT _ ty -> get_rdr_tvs (ty : arg_tys)
; new_tvs <- case expl of
Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs))
Qualified -> do { warnContextQuantification (docOfHsDocContext doc)
(userHsTyVarBndrs loc free_tvs)
; return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) }
Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs
; return tvs }
; mb_doc' <- rnMbLHsDoc mb_doc
; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
{ (new_context, fvs1) <- rnContext doc lcxt
; (new_details, fvs2) <- rnConDeclDetails doc details
; (new_details', new_res_ty, fvs3)
<- rnConResult doc (map unLoc new_names) new_details res_ty
; return (decl { con_names = new_names, con_qvars = new_tyvars
, con_cxt = new_context, con_details = new_details'
, con_res = new_res_ty, con_doc = mb_doc' },
fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
where
doc = ConDeclCtx names
get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
rnConResult :: HsDocContext -> [Name]
-> HsConDetails (LHsType Name) (Located [LConDeclField Name])
-> ResType (LHsType RdrName)
-> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
ResType (LHsType Name), FreeVars)
rnConResult _ _ details ResTyH98 = return (details, ResTyH98, emptyFVs)
rnConResult doc _con details (ResTyGADT ls ty)
= do { (ty', fvs) <- rnLHsType doc ty
; let (arg_tys, res_ty) = splitHsFunType ty'
; case details of
InfixCon {} -> pprPanic "rnConResult" (ppr ty)
RecCon {} -> do { unless (null arg_tys)
(addErr (badRecResTy (docOfHsDocContext doc)))
; return (details, ResTyGADT ls res_ty, fvs) }
PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT ls res_ty, fvs)}
rnConDeclDetails
:: HsDocContext
-> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName])
-> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars)
rnConDeclDetails doc (PrefixCon tys)
= do { (new_tys, fvs) <- rnLHsTypes doc tys
; return (PrefixCon new_tys, fvs) }
rnConDeclDetails doc (InfixCon ty1 ty2)
= do { (new_ty1, fvs1) <- rnLHsType doc ty1
; (new_ty2, fvs2) <- rnLHsType doc ty2
; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
rnConDeclDetails doc (RecCon (L l fields))
= do { (new_fields, fvs) <- rnConDeclFields doc fields
; return (RecCon (L l new_fields), fvs) }
deprecRecSyntax :: ConDecl RdrName -> SDoc
deprecRecSyntax decl
= vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_names 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
extendRecordFieldEnv :: [TyClGroup 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 | HsDataDefn { dd_cons = cons } <- all_ty_defs
, L _ con <- cons ]
all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn })
<- tyClGroupConcat tycl_decls ]
++ map dfid_defn (instDeclDataFamInsts inst_decls)
get_con (ConDecl { con_names = cons, con_details = RecCon flds })
(RecFields env fld_set)
= do { cons' <- mapM lookup cons
; flds' <- mapM lookup (concatMap (cd_fld_names . unLoc)
(unLoc flds))
; let env' = foldl (\e c -> extendNameEnv e c flds') env cons'
fld_set' = extendNameSetList fld_set flds'
; return $ (RecFields env' fld_set') }
get_con _ env = return env
rnFds :: [Located (FunDep (Located RdrName))]
-> RnM [Located (FunDep (Located Name))]
rnFds fds
= mapM (wrapLocM rn_fds) fds
where
rn_fds (tys1, tys2)
= do { tys1' <- rnHsTyVars tys1
; tys2' <- rnHsTyVars tys2
; return (tys1', tys2') }
rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
rnHsTyVars tvs = mapM rnHsTyVar tvs
rnHsTyVar :: Located RdrName -> RnM (Located Name)
rnHsTyVar (L l tyvar) = do
tyvar' <- lookupOccRn tyvar
return (L l tyvar')
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
ExplicitSplice -> return ()
ImplicitSplice -> 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")
$$ ptext (sLit "Perhaps you intended to use TemplateHaskell")
add gp _ (QuasiQuoteD qq) ds
= do { ds' <- runQuasiQuoteDecl qq
; addl gp (ds' ++ ds) }
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 = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
| otherwise
= addl (gp { hs_tyclds = add_tycld (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_tyclds = ts}) l (RoleAnnotD d) ds
= addl (gp { hs_tyclds = add_role_annot (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@(HsGroup {hs_vects = ts}) l (VectD d) ds
= addl (gp { hs_vects = L l d : ts }) ds
add gp l (DocD d) ds
= addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
add_tycld d [] = [TyClGroup { group_tyclds = [d], group_roles = [] }]
add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
= ds { group_tyclds = d : tyclds } : dss
add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
add_role_annot d [] = [TyClGroup { group_tyclds = [], group_roles = [d] }]
add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
= tycls { group_roles = d : roles } : rest
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"