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, lookupLocatedOccRn,
lookupTopBndrRn, lookupLocatedTopBndrRn,
- lookupOccRn, newLocalsRn,
+ lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
- bindLocalNames, checkDupRdrNames, mapFvRn,
- checkM
+ bindLocalNames, checkDupRdrNames, mapFvRn
)
import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn )
import HscTypes ( GenAvailInfo(..), availsToNameSet )
import Outputable
import Bag
import FastString
+import Util ( filterOut )
import SrcLoc
-import DynFlags ( DynFlag(..) )
-import Maybe ( isNothing )
+import DynFlags ( DynFlag(..) )
import BasicTypes ( Boxity(..) )
-
-import ListSetOps (findDupsEq)
-import List
+import ListSetOps ( findDupsEq )
import Control.Monad
+import Data.Maybe
\end{code}
\begin{code}
%*********************************************************
\begin{code}
-rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
+rnDocDecl :: DocDecl -> RnM DocDecl
rnDocDecl (DocCommentNext doc) = do
rn_doc <- rnHsDoc doc
return (DocCommentNext rn_doc)
\begin{code}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
rnSrcDerivDecl (DerivDecl ty)
- = do ty' <- rnLHsType (text "a deriving decl") ty
- let fvs = extractHsTyNames ty'
- return (DerivDecl ty', fvs)
+ = do { standalone_deriv_ok <- doptM Opt_StandaloneDeriving
+ ; unless standalone_deriv_ok (addErr standaloneDerivErr)
+ ; ty' <- rnLHsType (text "a deriving decl") ty
+ ; let fvs = extractHsTyNames ty'
+ ; return (DerivDecl ty', fvs) }
+
+standaloneDerivErr :: SDoc
+standaloneDerivErr
+ = hang (ptext (sLit "Illegal standalone deriving declaration"))
+ 2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
\end{code}
%*********************************************************
check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2
check_e (NegApp e _) = checkl_e e
check_e (ExplicitList _ es) = checkl_es es
- check_e (ExplicitTuple es _) = checkl_es es
check_e other = Just other -- Fails
checkl_es es = foldr (mplus . checkl_e) Nothing es
\begin{code}
rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
-rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
+rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
= lookupLocatedTopBndrRn name `thenM` \ name' ->
- return (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
+ return (ForeignType {tcdLName = name', 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})
- | is_vanilla -- Normal Haskell data type decl
- = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the
- -- data type is syntactically illegal
- 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
- ; condecls' <- rnConDecls (unLoc tycon') condecls
- -- No need to check for duplicate constructor decls
- -- since that is done by RnNames.extendGlobalRdrEnvRn
- ; (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'},
- delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context' `plusFV`
- plusFVs (map conDeclFVs condecls') `plusFV`
- deriv_fvs `plusFV`
- (if isFamInstDecl tydecl
- then unitFV (unLoc tycon') -- type instance => use
- else emptyFVs))
- } }
-
- | otherwise -- GADT
+ tcdKindSig = sig, tcdDerivs = derivs}
= do { tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
- ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
- ; (tyvars', typats')
+ ; checkTc (h98_style || null (unLoc context))
+ (badGadtStupidTheta tycon)
+ ; (tyvars', context', typats', derivs', deriv_fvs)
<- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
+ -- Checks for distinct tyvars
{ typats' <- rnTyPats data_doc typatsMaybe
- ; return (tyvars', typats') }
+ ; context' <- rnContext data_doc context
+ ; (derivs', deriv_fvs) <- rn_derivs derivs
+ ; return (tyvars', context', typats', derivs', deriv_fvs) }
-- For GADTs, the type variables in the declaration
-- do not scope over the constructor signatures
-- data T a where { T1 :: forall b. b-> b }
- ; condecls' <- rnConDecls (unLoc tycon') condecls
+ -- For the constructor declarations, bring into scope the tyvars
+ -- bound by the header, but *only* in the H98 case
+ ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
+ | otherwise = []
+ ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
+ rnConDecls condecls
-- No need to check for duplicate constructor decls
-- since that is done by RnNames.extendGlobalRdrEnvRn
- ; (derivs', deriv_fvs) <- rn_derivs derivs
- ; return (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
+ ; return (TyData {tcdND = new_or_data, tcdCtxt = context',
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = typats', tcdKindSig = sig,
tcdCons = condecls', tcdDerivs = derivs'},
- plusFVs (map conDeclFVs condecls') `plusFV`
- deriv_fvs `plusFV`
+ con_fvs `plusFV`
+ deriv_fvs `plusFV`
(if isFamInstDecl tydecl
then unitFV (unLoc tycon') -- type instance => use
else emptyFVs))
}
where
- is_vanilla = case condecls of -- Yuk
- [] -> True
+ h98_style = case condecls of
L _ (ConDecl { con_res = ResTyH98 }) : _ -> True
- _ -> False
-
+ _ -> False
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
rn_derivs Nothing = return (Nothing, emptyFVs)
return (Just ds', extractHsTyNames_s ds')
-- "type" and "type instance" declarations
-rnTyClDecl tydecl@(TySynonym {tcdLName = name,
+rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
tcdTyPats = typatsMaybe, tcdSynRhs = ty})
- = do { tyvars <- pruneTyVars tydecl
- ; bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do
+ = do { bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do
+ -- Checks for distinct tyvars
{ name' <- if isFamInstDecl tydecl
then lookupLocatedOccRn name -- may be imported family
else lookupLocatedTopBndrRn name
-- Tyvars scope over superclass context and method signatures
; (tyvars', context', fds', ats', ats_fvs, sigs')
<- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
+ -- Checks for distinct tyvars
{ context' <- rnContext cls_doc context
; fds' <- rnFds cls_doc fds
; (ats', ats_fvs) <- rnATs ats
-- No need to check for duplicate method signatures
-- since that is done by RnNames.extendGlobalRdrEnvRn
-- and the methods are already in scope
- ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
+ ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
-- Haddock docs
%*********************************************************
\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
-
+rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
-- 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)
---
-rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
rnTyPats _ Nothing = return Nothing
rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
-rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
-rnConDecls _tycon condecls
- = mapM (wrapLocM rnConDecl) condecls
+rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
+rnConDecls condecls
+ = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
+ ; return (condecls', plusFVs (map conDeclFVs condecls')) }
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
-rnConDecl (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
-
- -- For H98 syntax, the tvs are the existential ones
- -- For GADT syntax, the tvs are all the quantified tyvars
- -- Hence the 'filter' in the ResTyH98 case only
- ; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc
- arg_tys = hsConDeclArgTys details
- implicit_tvs = case res_ty of
- 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
-
- ; mb_doc' <- rnMbLHsDoc mb_doc
-
- ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
+
+ -- For H98 syntax, the tvs are the existential ones
+ -- For GADT syntax, the tvs are all the quantified tyvars
+ -- Hence the 'filter' in the ResTyH98 case only
+ ; rdr_env <- getLocalRdrEnv
+ ; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc
+ arg_tys = hsConDeclArgTys details
+ implicit_tvs = case res_ty of
+ ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
+ ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
+ new_tvs = case expl of
+ Explicit -> tvs
+ Implicit -> userHsTyVarBndrs implicit_tvs
+
+ ; mb_doc' <- rnMbLHsDoc mb_doc
+
+ ; bindTyVarsRn 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]
return (InfixCon new_ty1 new_ty2)
rnConDeclDetails doc (RecCon fields)
- = do { new_fields <- mapM (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 ->
- return (ConDeclField new_name new_ty new_haddock_doc)
-
-- Rename family declarations
--
-- * This function is parametrised by the routine handling the index
rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
tcdLName = tycon, tcdTyVars = tyvars})
bindIdxVars =
- do { checkM (isDataFlavour flavour -- for synonyms,
- || not (null tyvars)) $ addErr needOneIdx -- no. of indexes >= 1
- ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
+ do { bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
; tycon' <- lookupLocatedTopBndrRn tycon
; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
emptyFVs)
} }
- where
- isDataFlavour DataFamily = True
- isDataFlavour _ = False
rnFamily d _ = pprPanic "rnFamily" (ppr d)
family_doc :: Located RdrName -> SDoc
family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
-needOneIdx :: SDoc
-needOneIdx = text "Type family declarations requires at least one type index"
-
-- Rename associated type declarations (in classes)
--
-- * This can be family declarations and (default) type instances
rn_at (tydecl@TyFamily {}) = rnFamily tydecl lookupIdxVars
rn_at (tydecl@TySynonym {}) =
do
- checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
+ unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
rnTyClDecl tydecl
rn_at _ = panic "RnSource.rnATs: invalid TyClDecl"
| 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"