import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
-import HscTypes ( Deprecations(..), plusDeprecs )
+import HscTypes ( Warnings(..), plusWarns )
import Class ( FunDep )
import Name ( Name, nameOccName )
import NameSet
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}
\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)
+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_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 ;
+ tc_envs <- extendGlobalRdrEnvRn avails local_fix_env ;
setEnvs tc_envs $ do {
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
let { lhs_binders = map unLoc $ collectHsValBinders new_lhs;
lhs_avails = map Avail lhs_binders
} ;
- (tcg_env, tcl_env) <- extendGlobalRdrEnvRn shadowP lhs_avails local_fix_env ;
+ (tcg_env, tcl_env) <- extendGlobalRdrEnvRn lhs_avails local_fix_env ;
setEnvs (tcg_env, tcl_env) $ do {
-- Now everything is in scope, as the remaining renaming assumes.
-- 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 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 ;
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_defds = rn_default_decls,
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) ;
\begin{code}
-- checks that the deprecations are defined locally, and that there are no duplicates
-rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
-rnSrcDeprecDecls []
- = returnM NoDeprecs
+rnSrcWarnDecls :: [LWarnDecl RdrName] -> RnM Warnings
+rnSrcWarnDecls []
+ = returnM NoWarnings
-rnSrcDeprecDecls decls
+rnSrcWarnDecls decls
= do { -- check for duplicates
- ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupDeprecDecl lrdr')) deprec_rdr_dups
+ ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups
; mappM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
- returnM (DeprecSome ((concat pairs_s))) }
+ returnM (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]
-- 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}
-- But the (unqualified) method names are in scope
let
binders = collectHsBindBinders mbinds'
- ok_sig = okInstDclSig (mkNameSet binders)
+ bndr_set = mkNameSet binders
in
- bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' ->
+ bindLocalNames binders
+ (renameSigs (Just bndr_set) okInstDclSig uprags) `thenM` \ uprags' ->
returnM (InstDecl inst_ty' mbinds' uprags' ats',
meth_fvs `plusFV` at_fvs
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
check_e is commented out.
\begin{code}
-checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM [()]
+checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
checkValidRule rule_name ids lhs' fv_lhs'
= do { -- Check for the form of the LHS
case (validRuleLhs ids lhs') of
-- Check that LHS vars are all bound
; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
- ; mappM (addErr . badRuleVar rule_name) bad_vars }
+ ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
-- Nothing => OK
| 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
(if isFamInstDecl tydecl
then unitFV (unLoc tycon') -- type instance => use
else emptyFVs))
- }
+ } }
| otherwise -- GADT
= ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now
returnM (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
(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)
{ context' <- rnContext cls_doc context
; fds' <- rnFds cls_doc fds
; (ats', ats_fvs) <- rnATs ats
- ; sigs' <- renameSigs okClsDclSig sigs
+ ; sigs' <- renameSigs Nothing okClsDclSig sigs
; return (tyvars', context', fds', ats', ats_fvs, sigs') }
-- No need to check for duplicate associated type decls
%*********************************************************
\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)
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',