\begin{code}
module RnSource (
- rnSrcDecls, addTcgDUs,
- rnTyClDecls,
- rnSplice, checkTH
+ rnSrcDecls, addTcgDUs, rnTyClDecls
) where
#include "HsVersions.h"
import {-# SOURCE #-} RnExpr( rnLExpr )
import HsSyn
-import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv,
- globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE, rdrNameOcc )
+import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
makeMiniFixityEnv)
-import RnEnv ( lookupLocalDataTcNames,
- lookupLocatedTopBndrRn, lookupLocatedOccRn,
+import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
+ lookupTopBndrRn, lookupLocatedTopBndrRn,
lookupOccRn, newLocalsRn,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
bindLocalNames, checkDupRdrNames, mapFvRn,
+ checkM
)
import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn )
-import HscTypes ( GenAvailInfo(..) )
+import HscTypes ( GenAvailInfo(..), availsToNameSet )
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
-import HscTypes ( Deprecations(..), plusDeprecs )
+import HscTypes ( Warnings(..), plusWarns )
import Class ( FunDep )
import Name ( Name, nameOccName )
import NameSet
import NameEnv
-import OccName
import Outputable
import Bag
import FastString
-import SrcLoc ( Located(..), unLoc, noLoc )
+import SrcLoc
import DynFlags ( DynFlag(..) )
import Maybe ( isNothing )
import BasicTypes ( Boxity(..) )
import ListSetOps (findDupsEq)
+import List
import Control.Monad
\end{code}
thenM_ :: Monad a => a b -> a c -> a c
thenM_ = (>>)
-
-returnM :: Monad m => a -> m a
-returnM = return
-
-mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
-mappM = mapM
-
-mappM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
-mappM_ = mapM_
-
-checkM :: Monad m => Bool -> m () -> m ()
-checkM = unless
\end{code}
@rnSourceDecl@ `renames' declarations.
\begin{code}
-- Brings the binders of the group into scope in the appropriate places;
-- does NOT assume that anything is in scope already
---
--- The Bool determines whether (True) names in the group shadow existing
--- Unquals in the global environment (used in Template Haskell) or
--- (False) whether duplicates are reported as an error
-rnSrcDecls :: Bool -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
-
-rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls,
+rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
+-- Rename a HsGroup; used for normal source files *and* hs-boot files
+rnSrcDecls group@(HsGroup {hs_valds = val_decls,
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_derivds = deriv_decls,
hs_fixds = fix_decls,
- hs_depds = deprec_decls,
+ hs_warnds = warn_decls,
+ hs_annds = ann_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_decls,
-- (B) Bring top level binders (and their fixities) into scope,
-- *except* for the value bindings, which get brought in below.
- avails <- getLocalNonValBinders group ;
- tc_envs <- extendGlobalRdrEnvRn shadowP avails local_fix_env ;
+ -- However *do* include class ops, data constructors
+ -- And for hs-boot files *do* include the value signatures
+ tc_avails <- getLocalNonValBinders group ;
+ tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ;
setEnvs tc_envs $ do {
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-- extend the record field env.
-- This depends on the data constructors and field names being in
-- scope from (B) above
- inNewEnv (extendRecordFieldEnv tycl_decls) $ \ _ -> do {
+ inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
-- (D) Rename the left-hand sides of the value bindings.
-- This depends on everything from (B) being in scope,
-- It uses the fixity env from (A) to bind fixities for view patterns.
new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
-- bind the LHSes (and their fixities) in the global rdr environment
- let { lhs_binders = map unLoc $ collectHsValBinders new_lhs;
- lhs_avails = map Avail lhs_binders
+ let { val_binders = map unLoc $ 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 shadowP lhs_avails local_fix_env ;
+ (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
setEnvs (tcg_env, tcl_env) $ do {
-- Now everything is in scope, as the remaining renaming assumes.
-- (F) Rename Value declarations right-hand sides
traceRn (text "Start rnmono") ;
- (rn_val_decls, bind_dus) <- rnTopBindsRHS lhs_binders new_lhs ;
+ (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ;
traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
-- (G) Rename Fixity and deprecations
- -- rename fixity declarations and error if we try to
+ -- Rename fixity declarations and error if we try to
-- fix something from another module (duplicates were checked in (A))
- rn_fix_decls <- rnSrcFixityDecls fix_decls ;
- -- rename deprec decls;
+ rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
+
+ -- Rename deprec decls;
-- check for duplicates and ensure that deprecated things are defined locally
-- at the moment, we don't keep these around past renaming
- rn_deprecs <- rnSrcDeprecDecls deprec_decls ;
+ rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
-- (H) Rename Everything else
(rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ;
- (rn_rule_decls, src_fvs3) <- rnList rnHsRuleDecl rule_decls ;
+ (rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $
+ rnList rnHsRuleDecl rule_decls ;
+ -- Inside RULES, scoped type variables are on
(rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
- (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ;
- (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_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 ;
-- Haddock docs; no free vars
rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
hs_instds = rn_inst_decls,
hs_derivds = rn_deriv_decls,
hs_fixds = rn_fix_decls,
- hs_depds = [], -- deprecs are returned in the tcg_env
+ hs_warnds = [], -- warns are returned in the tcg_env
-- (see below) not in the HsGroup
hs_fords = rn_foreign_decls,
+ hs_annds = rn_ann_decls,
hs_defds = rn_default_decls,
hs_ruleds = rn_rule_decls,
hs_docs = rn_docs } ;
- other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3,
- src_fvs4, src_fvs5] ;
+ other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
+ src_fvs5, src_fvs6, src_fvs7] ;
src_dus = bind_dus `plusDU` usesOnly other_fvs;
-- Note: src_dus will contain *uses* for locally-defined types
-- and classes, but no *defs* for them. (Because rnTyClDecl
final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
in -- we return the deprecs in the env, not in the HsGroup above
- tcg_env' { tcg_deprecs = tcg_deprecs tcg_env' `plusDeprecs` rn_deprecs };
+ tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
} ;
traceRn (text "finish rnSrc" <+> ppr rn_group) ;
return decls'
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
+-- This function could be defined lower down in the module hierarchy,
+-- but there doesn't seem anywhere very logical to put it.
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)
%*********************************************************
\begin{code}
-rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name]
+rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
-- Rename the fixity decls, so we can put
-- the renamed decls in the renamed syntax tree
-- Errors if the thing being fixed is not defined locally.
--
-- The returned FixitySigs are not actually used for anything,
-- except perhaps the GHCi API
-rnSrcFixityDecls fix_decls
+rnSrcFixityDecls bound_names fix_decls
= do fix_decls <- mapM rn_decl fix_decls
return (concat fix_decls)
where
rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
= setSrcSpan name_loc $
-- this lookup will fail if the definition isn't local
- do names <- lookupLocalDataTcNames rdr_name
+ do names <- lookupLocalDataTcNames bound_names what rdr_name
return [ L loc (FixitySig (L name_loc name) fixity)
- | name <- names ]
+ | name <- names ]
+ what = ptext (sLit "fixity signature")
\end{code}
\begin{code}
-- checks that the deprecations are defined locally, and that there are no duplicates
-rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
-rnSrcDeprecDecls []
- = returnM NoDeprecs
+rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
+rnSrcWarnDecls _bound_names []
+ = return NoWarnings
-rnSrcDeprecDecls decls
+rnSrcWarnDecls bound_names decls
= do { -- check for duplicates
- ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupDeprecDecl lrdr')) deprec_rdr_dups
- ; mappM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
- returnM (DeprecSome ((concat pairs_s))) }
+ ; mapM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups
+ ; mapM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
+ return (WarnSome ((concat pairs_s))) }
where
- rn_deprec (Deprecation rdr_name txt)
+ rn_deprec (Warning rdr_name txt)
-- ensures that the names are defined locally
- = lookupLocalDataTcNames rdr_name `thenM` \ names ->
- returnM [(nameOccName name, txt) | name <- names]
+ = lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names ->
+ return [(nameOccName name, txt) | name <- names]
+ what = ptext (sLit "deprecation")
+
-- look for duplicates among the OccNames;
-- we check that the names are defined above
-- invt: the lists returned by findDupsEq always have at least two elements
- deprec_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
- (map (\ (L loc (Deprecation rdr_name _)) -> L loc rdr_name) decls)
+ warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
+ (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
-dupDeprecDecl :: Located RdrName -> RdrName -> SDoc
+dupWarnDecl :: Located RdrName -> RdrName -> SDoc
-- Located RdrName -> DeprecDecl RdrName -> SDoc
-dupDeprecDecl (L loc _) rdr_name
- = vcat [ptext (sLit "Multiple deprecation declarations for") <+> quotes (ppr rdr_name),
+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{Source code declarations}
+\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}
%* *
%*********************************************************
rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
rnDefaultDecl (DefaultDecl tys)
= mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) ->
- returnM (DefaultDecl tys', fvs)
+ return (DefaultDecl tys', fvs)
where
doc_str = text "In a `default' declaration"
\end{code}
rnHsForeignDecl (ForeignImport name ty spec)
= lookupLocatedTopBndrRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
- returnM (ForeignImport name' ty' spec, fvs)
+ return (ForeignImport name' ty' spec, fvs)
rnHsForeignDecl (ForeignExport name ty spec)
= lookupLocatedOccRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
- returnM (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name')
+ return (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name')
-- NB: a foreign export is an *occurrence site* for name, so
-- we add it to the free-variable list. It might, for example,
-- be imported from another module
bindLocalNames binders
(renameSigs (Just bndr_set) okInstDclSig uprags) `thenM` \ uprags' ->
- returnM (InstDecl inst_ty' mbinds' uprags' ats',
+ return (InstDecl inst_ty' mbinds' uprags' ats',
meth_fvs `plusFV` at_fvs
`plusFV` hsSigsFVs uprags'
`plusFV` extractHsTyNames inst_ty')
rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
= bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $
-
bindLocatedLocalsFV doc (map get_var vars) $ \ ids ->
- mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) ->
+ do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
+ -- NB: The binders in a rule are always Ids
+ -- We don't (yet) support type variables
- rnLExpr lhs `thenM` \ (lhs', fv_lhs') ->
- rnLExpr rhs `thenM` \ (rhs', fv_rhs') ->
+ ; (lhs', fv_lhs') <- rnLExpr lhs
+ ; (rhs', fv_rhs') <- rnLExpr rhs
- checkValidRule rule_name ids lhs' fv_lhs' `thenM_`
+ ; checkValidRule rule_name ids lhs' fv_lhs'
- returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
- fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
+ ; 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 (RuleBndrSig v _) = v
rn_var (RuleBndr (L loc _), id)
- = returnM (RuleBndr (L loc id), emptyFVs)
+ = return (RuleBndr (L loc id), emptyFVs)
rn_var (RuleBndrSig (L loc _) t, id)
= rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
- returnM (RuleBndrSig (L loc id) t', fvs)
+ return (RuleBndrSig (L loc id) t', fvs)
badRuleVar :: FastString -> Name -> SDoc
badRuleVar name var
rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
= lookupLocatedTopBndrRn name `thenM` \ name' ->
- returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
+ return (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
emptyFVs)
-- all flavours of type family declarations ("type family", "newtype fanily",
| is_vanilla -- Normal Haskell data type decl
= ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the
-- data type is syntactically illegal
- bindTyVarsRn data_doc tyvars $ \ tyvars' ->
- do { tycon' <- if isFamInstDecl tydecl
+ do { tyvars <- pruneTyVars tydecl
+ ; bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
+ { tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
; context' <- rnContext data_doc context
; typats' <- rnTyPats data_doc typatsMaybe
- ; (derivs', deriv_fvs) <- rn_derivs derivs
; condecls' <- rnConDecls (unLoc tycon') condecls
-- No need to check for duplicate constructor decls
-- since that is done by RnNames.extendGlobalRdrEnvRn
- ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context',
+ ; (derivs', deriv_fvs) <- rn_derivs derivs
+ ; return (TyData {tcdND = new_or_data, tcdCtxt = context',
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = typats', tcdKindSig = Nothing,
tcdCons = condecls', tcdDerivs = derivs'},
(if isFamInstDecl tydecl
then unitFV (unLoc tycon') -- type instance => use
else emptyFVs))
- }
+ } }
| otherwise -- GADT
- = ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now
- do { tycon' <- if isFamInstDecl tydecl
+ = do { tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
- ; tyvars' <- bindTyVarsRn data_doc tyvars
- (\ tyvars' -> return tyvars')
+ ; (tyvars', typats')
+ <- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
+ { typats' <- rnTyPats data_doc typatsMaybe
+ ; return (tyvars', typats') }
-- For GADTs, the type variables in the declaration
-- do not scope over the constructor signatures
-- data T a where { T1 :: forall b. b-> b }
- ; (derivs', deriv_fvs) <- rn_derivs derivs
+
; condecls' <- rnConDecls (unLoc tycon') condecls
-- No need to check for duplicate constructor decls
-- since that is done by RnNames.extendGlobalRdrEnvRn
- ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
+
+ ; (derivs', deriv_fvs) <- rn_derivs derivs
+ ; return (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
tcdLName = tycon', tcdTyVars = tyvars',
- tcdTyPats = Nothing, tcdKindSig = sig,
+ tcdTyPats = typats', tcdKindSig = sig,
tcdCons = condecls', tcdDerivs = derivs'},
plusFVs (map conDeclFVs condecls') `plusFV`
deriv_fvs `plusFV`
L _ (ConDecl { con_res = ResTyH98 }) : _ -> True
_ -> False
- none Nothing = True
- none (Just []) = True
- none _ = False
-
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
- rn_derivs Nothing = returnM (Nothing, emptyFVs)
+ rn_derivs Nothing = return (Nothing, emptyFVs)
rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
- returnM (Just ds', extractHsTyNames_s ds')
+ return (Just ds', extractHsTyNames_s ds')
-- "type" and "type instance" declarations
-rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
+rnTyClDecl tydecl@(TySynonym {tcdLName = name,
tcdTyPats = typatsMaybe, tcdSynRhs = ty})
- = bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- do { name' <- if isFamInstDecl tydecl
+ = do { tyvars <- pruneTyVars tydecl
+ ; bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do
+ { name' <- if isFamInstDecl tydecl
then lookupLocatedOccRn name -- may be imported family
else lookupLocatedTopBndrRn name
; typats' <- rnTyPats syn_doc typatsMaybe
; (ty', fvs) <- rnHsTypeFVs syn_doc ty
- ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
+ ; return (TySynonym {tcdLName = name', tcdTyVars = tyvars',
tcdTyPats = typats', tcdSynRhs = ty'},
delFVs (map hsLTyVarName tyvars') $
fvs `plusFV`
(if isFamInstDecl tydecl
then unitFV (unLoc name') -- type instance => use
else emptyFVs))
- }
+ } }
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
ptext (sLit "(You can put a context on each contructor, though.)")]
\end{code}
+
%*********************************************************
%* *
\subsection{Support code for type/data declarations}
%*********************************************************
\begin{code}
+-- Remove any duplicate type variables in family instances may have non-linear
+-- left-hand sides. Complain if any, but the first occurence of a type
+-- variable has a user-supplied kind signature.
+--
+pruneTyVars :: TyClDecl RdrName -> RnM [LHsTyVarBndr RdrName]
+pruneTyVars tydecl
+ | isFamInstDecl tydecl
+ = do { let pruned_tyvars = nubBy eqLTyVar tyvars
+ ; assertNoSigsInRepeats tyvars
+ ; return pruned_tyvars
+ }
+ | otherwise
+ = return tyvars
+ where
+ tyvars = tcdTyVars tydecl
+
+ assertNoSigsInRepeats [] = return ()
+ assertNoSigsInRepeats (tv:tvs)
+ = do { let offending_tvs = [ tv' | tv'@(L _ (KindedTyVar _ _)) <- tvs
+ , tv' `eqLTyVar` tv]
+ ; checkErr (null offending_tvs) $
+ illegalKindSig (head offending_tvs)
+ ; assertNoSigsInRepeats tvs
+ }
+
+ illegalKindSig tv
+ = hsep [ptext (sLit "Repeat variable occurrence may not have a"),
+ ptext (sLit "kind signature:"), quotes (ppr tv)]
+
+ tv1 `eqLTyVar` tv2 = hsLTyVarLocName tv1 `eqLocated` hsLTyVarLocName tv2
+
-- Although, we are processing type patterns here, all type variables will
-- already be in scope (they are the same as in the 'tcdTyVars' field of the
-- type declaration to which these patterns belong)
rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
rnConDecls _tycon condecls
- = mappM (wrapLocM rnConDecl) condecls
+ = mapM (wrapLocM rnConDecl) condecls
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc)
-> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
-> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
rnConDeclDetails doc (PrefixCon tys)
- = mappM (rnLHsType doc) tys `thenM` \ new_tys ->
- returnM (PrefixCon new_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 ->
- returnM (InfixCon new_ty1 new_ty2)
+ return (InfixCon new_ty1 new_ty2)
rnConDeclDetails doc (RecCon fields)
- = do { new_fields <- mappM (rnField doc) fields
+ = do { new_fields <- mapM (rnField doc) fields
-- No need to check for duplicate fields
-- since that is done by RnNames.extendGlobalRdrEnvRn
; return (RecCon new_fields) }
= lookupLocatedTopBndrRn name `thenM` \ new_name ->
rnLHsType doc ty `thenM` \ new_ty ->
rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc ->
- returnM (ConDeclField new_name new_ty new_haddock_doc)
+ return (ConDeclField new_name new_ty new_haddock_doc)
-- Rename family declarations
--
tcdLName = tycon, tcdTyVars = tyvars})
bindIdxVars =
do { checkM (isDataFlavour flavour -- for synonyms,
- || not (null tyvars)) $ addErr needOneIdx -- #indexes >= 1
+ || not (null tyvars)) $ addErr needOneIdx -- no. of indexes >= 1
; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
; tycon' <- lookupLocatedTopBndrRn tycon
- ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
+ ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
emptyFVs)
} }
lookupIdxVars _ tyvars cont =
do { checkForDups tyvars;
- ; tyvars' <- mappM lookupIdxVar tyvars
+ ; tyvars' <- mapM lookupIdxVar tyvars
; cont tyvars'
}
-- Type index variables must be class parameters, which are the only
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] -> TcM TcGblEnv
-extendRecordFieldEnv decls
+extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
+extendRecordFieldEnv tycl_decls inst_decls
= do { tcg_env <- getGblEnv
- ; field_env' <- foldrM get (tcg_field_env tcg_env) decls
+ ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
; return (tcg_env { tcg_field_env = field_env' }) }
where
-- we want to lookup:
lookup x = do { x' <- lookupLocatedTopBndrRn x
; return $ unLoc x'}
- get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons
- get _ env = return env
+ 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 = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
+ -- Do not forget associated types!
- get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env
+ get_con (ConDecl { con_name = con, con_details = RecCon flds })
+ (RecFields env fld_set)
= do { con' <- lookup con
- ; flds' <- mappM lookup (map cd_fld_name flds)
- ; return $ extendNameEnv env con' flds' }
- get_con _ env
- = return env
+ ; 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}
%*********************************************************
rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
rnFds doc fds
- = mappM (wrapLocM rn_fds) fds
+ = mapM (wrapLocM rn_fds) fds
where
rn_fds (tys1, tys2)
= rnHsTyVars doc tys1 `thenM` \ tys1' ->
rnHsTyVars doc tys2 `thenM` \ tys2' ->
- returnM (tys1', tys2')
+ return (tys1', tys2')
rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
-rnHsTyVars doc tvs = mappM (rnHsTyVar doc) tvs
+rnHsTyVars doc tvs = mapM (rnHsTyVar doc) tvs
rnHsTyVar :: SDoc -> RdrName -> RnM Name
rnHsTyVar _doc tyvar = lookupOccRn tyvar
\end{code}
-%*********************************************************
-%* *
- Splices
-%* *
-%*********************************************************
-
-Note [Splices]
-~~~~~~~~~~~~~~
-Consider
- f = ...
- h = ...$(thing "f")...
-
-The splice can expand into literally anything, so when we do dependency
-analysis we must assume that it might mention 'f'. So we simply treat
-all locally-defined names as mentioned by any splice. This is terribly
-brutal, but I don't see what else to do. For example, it'll mean
-that every locally-defined thing will appear to be used, so no unused-binding
-warnings. But if we miss the dependency, then we might typecheck 'h' before 'f',
-and that will crash the type checker because 'f' isn't in scope.
-
-Currently, I'm not treating a splice as also mentioning every import,
-which is a bit inconsistent -- but there are a lot of them. We might
-thereby get some bogus unused-import warnings, but we won't crash the
-type checker. Not very satisfactory really.
-
-\begin{code}
-rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
-rnSplice (HsSplice n expr)
- = do { checkTH expr "splice"
- ; loc <- getSrcSpanM
- ; [n'] <- newLocalsRn [L loc n]
- ; (expr', fvs) <- rnLExpr expr
-
- -- Ugh! See Note [Splices] above
- ; lcl_rdr <- getLocalRdrEnv
- ; gbl_rdr <- getGlobalRdrEnv
- ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
- isLocalGRE gre]
- lcl_names = mkNameSet (occEnvElts lcl_rdr)
-
- ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
-
-checkTH :: Outputable a => a -> String -> RnM ()
-#ifdef GHCI
-checkTH _ _ = returnM () -- OK
-#else
-checkTH e what -- Raise an error in a stage-1 compiler
- = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>
- ptext (sLit "illegal in a stage-1 compiler"),
- nest 2 (ppr e)])
-#endif
-\end{code}