\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 RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
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 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_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_warns <- rnSrcWarnDecls warn_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_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
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
-rnSrcWarnDecls :: [LWarnDecl RdrName] -> RnM Warnings
-rnSrcWarnDecls []
- = returnM NoWarnings
+rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
+rnSrcWarnDecls _bound_names []
+ = return NoWarnings
-rnSrcWarnDecls decls
+rnSrcWarnDecls bound_names decls
= do { -- check for duplicates
- ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups
- ; mappM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
- returnM (WarnSome ((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 (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
%*********************************************************
%* *
-\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')
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",
rnFamily tydecl bindTyVarsRn
-- "data", "newtype", "data instance, and "newtype instance" declarations
-rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
+rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
tcdLName = tycon, tcdTyVars = tyvars,
tcdTyPats = typatsMaybe, tcdCons = condecls,
- tcdKindSig = sig, tcdDerivs = derivs})
+ tcdKindSig = sig, tcdDerivs = derivs}
| 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
+ -- data type is syntactically illegal
+ ASSERT( distinctTyVarBndrs tyvars ) -- Tyvars should be distinct
+ do { 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,
tcdTyPats = typatsMaybe, tcdSynRhs = ty})
- = bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- do { name' <- if isFamInstDecl tydecl
+ = ASSERT( distinctTyVarBndrs tyvars ) -- Tyvars should be distinct
+ do { 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)
cls_doc = text "In the declaration for class" <+> ppr cname
sig_doc = text "In the signatures for class" <+> ppr cname
+distinctTyVarBndrs :: [LHsTyVarBndr RdrName] -> Bool
+-- The tyvar binders should have distinct names
+distinctTyVarBndrs tvs
+ = null (findDupsEq eq tvs)
+ where
+ eq (L _ v1) (L _ v2) = hsTyVarName v1 == hsTyVarName v2
+
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}
+
%*********************************************************
%* *
\subsection{Support code for type/data declarations}
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)
+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
; name_env <- getLocalRdrEnv
; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc
arg_tys = hsConDeclArgTys details
implicit_tvs = case res_ty of
- ResTyH98 -> filter not_in_scope $
+ ResTyH98 -> filter not_in_scope $
get_rdr_tvs arg_tys
ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
- tvs' = case expl of
- Explicit -> tvs
- Implicit -> userHsTyVarBndrs implicit_tvs
+ new_tvs = case expl of
+ Explicit -> tvs
+ Implicit -> userHsTyVarBndrs implicit_tvs
- ; mb_doc' <- rnMbLHsDoc mb_doc
+ ; mb_doc' <- rnMbLHsDoc mb_doc
- ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
+ ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
{ new_context <- rnContext doc cxt
- ; new_details <- rnConDeclDetails doc details
+ ; new_details <- rnConDeclDetails doc details
; (new_details', new_res_ty) <- rnConResult doc new_details res_ty
- ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }}
+ ; 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))
-> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
ResType Name)
rnConResult _ details ResTyH98 = return (details, ResTyH98)
-
-rnConResult doc details (ResTyGADT ty) = do
- ty' <- rnHsSigType doc ty
- let (arg_tys, res_ty) = splitHsFunType ty'
- -- We can split it up, now the renamer has dealt with fixities
- case details of
- PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
- RecCon _ -> return (details, ResTyGADT ty')
- InfixCon {} -> panic "rnConResult"
+rnConResult doc details (ResTyGADT ty)
+ = do { ty' <- rnLHsType doc ty
+ ; let (arg_tys, res_ty) = splitHsFunType ty'
+ -- We can finally split it up,
+ -- now the renamer has dealt with fixities
+ -- See Note [Sorting out the result type] in RdrHsSyn
+
+ details' = case details of
+ RecCon {} -> details
+ PrefixCon {} -> PrefixCon arg_tys
+ InfixCon {} -> pprPanic "rnConResult" (ppr ty)
+ -- See Note [Sorting out the result type] in RdrHsSyn
+
+ ; 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)
- = 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 <- rnConDeclFields doc fields
-- No need to check for duplicate fields
-- since that is done by RnNames.extendGlobalRdrEnvRn
; return (RecCon new_fields) }
-rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name)
-rnField doc (ConDeclField name ty haddock_doc)
- = 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)
-
-- Rename family declarations
--
-- * This function is parametrised by the routine handling the index
|| 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
| 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) ] -- Pretty printer uses new form
+
+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"
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}
projects / ghc-hetmet.git / blobdiff