\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, lookupLocatedOccRn,
import Name ( Name, nameOccName )
import NameSet
import NameEnv
-import OccName
import Outputable
import Bag
import FastString
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)
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
- do { tyvars <- pruneTyVars tydecl
- ; bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
+ -- 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
+ ; (derivs', deriv_fvs) <- rn_derivs derivs
; return (TyData {tcdND = new_or_data, tcdCtxt = context',
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = typats', tcdKindSig = Nothing,
-- 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
+ ; (derivs', deriv_fvs) <- rn_derivs derivs
; return (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = typats', tcdKindSig = sig,
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
+ = 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
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}
%*********************************************************
\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)
= 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]
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
| 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"
\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 _ _ = return () -- 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