\section[RnSource]{Main pass of renamer}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module RnSource (
rnSrcDecls, addTcgDUs,
- rnTyClDecls, checkModDeprec,
+ rnTyClDecls,
rnSplice, checkTH
) where
import {-# SOURCE #-} RnExpr( rnLExpr )
import HsSyn
-import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts,
- GlobalRdrElt(..), isLocalGRE )
+import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv,
+ globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE, rdrNameOcc )
import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
-import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
+import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
+ makeMiniFixityEnv)
import RnEnv ( lookupLocalDataTcNames,
lookupLocatedTopBndrRn, lookupLocatedOccRn,
lookupOccRn, newLocalsRn,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
- bindLocalNames, checkDupNames, mapFvRn
+ bindLocalNames, checkDupNames, mapFvRn, lookupGreLocalRn,
)
+import RnNames (importsFromLocalDecls, extendRdrEnvRn)
+import HscTypes (GenAvailInfo(..))
+import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
-import HscTypes ( FixityEnv, FixItem(..),
- Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
+import HscTypes ( FixityEnv, FixItem(..), Deprecations(..), plusDeprecs )
import Class ( FunDep )
import Name ( Name, nameOccName )
import NameSet
import NameEnv
-import OccName ( occEnvElts )
+import UniqFM
+import OccName
import Outputable
-import SrcLoc ( Located(..), unLoc, getLoc, noLoc )
+import SrcLoc ( Located(..), unLoc, noLoc )
import DynFlags ( DynFlag(..) )
import Maybes ( seqMaybe )
import Maybe ( isNothing )
+import Monad ( liftM, when )
import BasicTypes ( Boxity(..) )
+
+import ListSetOps (findDupsEq, mkLookupFun)
\end{code}
@rnSourceDecl@ `renames' declarations.
\begin{code}
-rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
-
-rnSrcDecls (HsGroup { hs_valds = val_decls,
- hs_tyclds = tycl_decls,
- hs_instds = inst_decls,
- hs_fixds = fix_decls,
- hs_depds = deprec_decls,
- hs_fords = foreign_decls,
- hs_defds = default_decls,
- hs_ruleds = rule_decls })
-
- = do { -- Deal with deprecations (returns only the extra deprecations)
- deprecs <- rnSrcDeprecDecls deprec_decls ;
- updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
- $ do {
-
- -- Deal with top-level fixity decls
- -- (returns the total new fixity env)
- rn_fix_decls <- rnSrcFixityDecls fix_decls ;
- fix_env <- rnSrcFixityDeclsEnv rn_fix_decls ;
- updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
- $ do {
-
- -- Rename other declarations
- traceRn (text "Start rnmono") ;
- (rn_val_decls, bind_dus) <- rnTopBinds val_decls ;
- traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
-
- -- You might think that we could build proper def/use information
- -- for type and class declarations, but they can be involved
- -- in mutual recursion across modules, and we only do the SCC
- -- analysis for them in the type checker.
- -- So we content ourselves with gathering uses only; that
- -- means we'll only report a declaration as unused if it isn't
- -- mentioned at all. Ah well.
- (rn_tycl_decls, src_fvs1)
- <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
- (rn_inst_decls, src_fvs2)
- <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
- (rn_rule_decls, src_fvs3)
- <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
- (rn_foreign_decls, src_fvs4)
- <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
- (rn_default_decls, src_fvs5)
- <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
-
- let {
- rn_group = HsGroup { hs_valds = rn_val_decls,
+-- 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,
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
+ hs_fixds = fix_decls,
+ hs_depds = deprec_decls,
+ hs_fords = foreign_decls,
+ hs_defds = default_decls,
+ hs_ruleds = rule_decls,
+ hs_docs = docs })
+ = do {
+ -- (A) Process the fixity declarations, creating a mapping from
+ -- FastStrings to FixItems.
+ -- Also checks for duplcates.
+ local_fix_env <- makeMiniFixityEnv fix_decls;
+
+ -- (B) Bring top level binders (and their fixities) into scope,
+ -- except for the value bindings, which get brought in below.
+ inNewEnv (importsFromLocalDecls shadowP group local_fix_env) $ \ tcg_env -> do {
+
+ failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
+
+ -- (C) Extract the mapping from data constructors to field names and
+ -- extend the record field env.
+ -- This depends on the data constructors and field names being in
+ -- scope from (B) above
+ inNewEnv (extendRecordFieldEnv tycl_decls) $ \ tcg_env -> do {
+
+ -- (D) Rename the left-hand sides of the value bindings.
+ -- This depends on everything from (B) being in scope,
+ -- and on (C) for resolving record wild cards.
+ -- 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
+ } ;
+ inNewEnv (extendRdrEnvRn shadowP (tcg_rdr_env tcg_env, tcg_fix_env tcg_env)
+ lhs_avails local_fix_env
+ >>= \ (new_rdr_env, new_fix_env) ->
+ return (tcg_env { tcg_rdr_env = new_rdr_env,
+ tcg_fix_env = new_fix_env
+ })) $ \tcg_env -> do {
+
+ -- Now everything is in scope, as the remaining renaming assumes.
+
+ -- (E) Rename type and class decls
+ -- (note that value LHSes need to be in scope for default methods)
+ --
+ -- You might think that we could build proper def/use information
+ -- for type and class declarations, but they can be involved
+ -- in mutual recursion across modules, and we only do the SCC
+ -- analysis for them in the type checker.
+ -- So we content ourselves with gathering uses only; that
+ -- means we'll only report a declaration as unused if it isn't
+ -- mentioned at all. Ah well.
+ traceRn (text "Start rnTyClDecls") ;
+ (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
+
+ -- (F) Rename Value declarations right-hand sides
+ traceRn (text "Start rnmono") ;
+ (rn_val_decls, bind_dus) <- rnTopBindsRHS lhs_binders new_lhs ;
+ traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
+
+ -- (G) Rename Fixity and deprecations
+
+ -- 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;
+ -- 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 ;
+
+ -- (H) Rename Everything else
+
+ (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ;
+ (rn_rule_decls, src_fvs3) <- rnList rnHsRuleDecl rule_decls ;
+ (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 ;
+ -- Haddock docs; no free vars
+ rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
+
+ -- (I) Compute the results and return
+ let {rn_group = HsGroup { hs_valds = rn_val_decls,
hs_tyclds = rn_tycl_decls,
hs_instds = rn_inst_decls,
+ hs_derivds = rn_deriv_decls,
hs_fixds = rn_fix_decls,
- hs_depds = [],
+ hs_depds = [], -- deprecs are returned in the tcg_env (see below)
+ -- not in the HsGroup
hs_fords = rn_foreign_decls,
hs_defds = rn_default_decls,
- hs_ruleds = rn_rule_decls } ;
+ hs_ruleds = rn_rule_decls,
+ hs_docs = rn_docs } ;
- other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3,
- src_fvs4, src_fvs5] ;
- src_dus = bind_dus `plusDU` usesOnly other_fvs
+ other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3,
+ src_fvs4, src_fvs5] ;
+ 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
-- returns only the uses.) This is a little
-- surprising but it doesn't actually matter at all.
- } ;
- traceRn (text "finish rnSrc" <+> ppr rn_group) ;
- traceRn (text "finish Dus" <+> ppr src_dus ) ;
- tcg_env <- getGblEnv ;
- return (tcg_env `addTcgDUs` src_dus, rn_group)
- }}}
+ 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 };
+ } ;
+
+ traceRn (text "finish rnSrc" <+> ppr rn_group) ;
+ traceRn (text "finish Dus" <+> ppr src_dus ) ;
+ return (final_tcg_env , rn_group)
+ }}}}
+
+-- some utils because we do this a bunch above
+-- compute and install the new env
+inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
+inNewEnv env cont = do e <- env
+ setGblEnv e $ cont e
rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
-rnTyClDecls tycl_decls = do
- (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
- return decls'
+-- Used for external core
+rnTyClDecls tycl_decls = do (decls', fvs) <- rnList rnTyClDecl tycl_decls
+ return decls'
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
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)
+rnList f xs = mapFvRn (wrapLocFstM f) xs
+\end{code}
+
+
+%*********************************************************
+%* *
+ HsDoc stuff
+%* *
+%*********************************************************
+
+\begin{code}
+rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
+rnDocDecl (DocCommentNext doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocCommentNext rn_doc)
+rnDocDecl (DocCommentPrev doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocCommentPrev rn_doc)
+rnDocDecl (DocCommentNamed str doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocCommentNamed str rn_doc)
+rnDocDecl (DocGroup lev doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocGroup lev rn_doc)
\end{code}
\begin{code}
rnSrcFixityDecls :: [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.
rnSrcFixityDecls fix_decls
- = do fix_decls <- mapM rnFixityDecl fix_decls
- return (concat fix_decls)
-
-rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name]
-rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity))
- = setSrcSpan nameLoc $
+ = do fix_decls <- mapM rn_decl fix_decls
+ return (concat fix_decls)
+ where
+ rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
-- GHC extension: look up both the tycon and data con
- -- for con-like things
+ -- for con-like things; hence returning a list
-- If neither are in scope, report an error; otherwise
-- add both to the fixity env
- do names <- lookupLocalDataTcNames rdr_name
- return [ L loc (FixitySig (L nameLoc name) fixity)
- | name <- names ]
-
-rnSrcFixityDeclsEnv :: [LFixitySig Name] -> RnM FixityEnv
-rnSrcFixityDeclsEnv fix_decls
- = getGblEnv `thenM` \ gbl_env ->
- foldlM rnFixityDeclEnv (tcg_fix_env gbl_env)
- fix_decls `thenM` \ fix_env ->
- traceRn (text "fixity env" <+> pprFixEnv fix_env) `thenM_`
- returnM fix_env
-
-rnFixityDeclEnv :: FixityEnv -> LFixitySig Name -> RnM FixityEnv
-rnFixityDeclEnv fix_env (L loc (FixitySig (L nameLoc name) fixity))
- = case lookupNameEnv fix_env name of
- Just (FixItem _ _ loc')
- -> do addLocErr (L nameLoc name) (dupFixityDecl loc')
- return fix_env
- Nothing
- -> return (extendNameEnv fix_env name fix_item)
- where fix_item = FixItem (nameOccName name) fixity nameLoc
-
-pprFixEnv :: FixityEnv -> SDoc
-pprFixEnv env
- = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n)
- (nameEnvElts env)
-
-dupFixityDecl loc rdr_name
- = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
- ptext SLIT("also at ") <+> ppr loc
- ]
+ 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
+ return [ L loc (FixitySig (L name_loc name) fixity)
+ | name <- names ]
\end{code}
%* *
%*********************************************************
-For deprecations, all we do is check that the names are in scope.
+Check that the deprecated names are defined, are defined locally, and
+that there are no duplicate deprecations.
+
It's only imported deprecations, dealt with in RnIfaces, that we
gather them together.
\begin{code}
+-- checks that the deprecations are defined locally, and that there are no duplicates
rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
rnSrcDeprecDecls []
= returnM NoDeprecs
-rnSrcDeprecDecls decls
- = mappM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
- returnM (DeprecSome (mkNameEnv (concat pairs_s)))
+rnSrcDeprecDecls 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))) }
where
rn_deprec (Deprecation rdr_name txt)
+ -- ensures that the names are defined locally
= lookupLocalDataTcNames rdr_name `thenM` \ names ->
- returnM [(name, (nameOccName name, txt)) | name <- 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)
+
+dupDeprecDecl (L loc _) rdr_name
+ = vcat [ptext SLIT("Multiple deprecation declarations for") <+> quotes (ppr rdr_name),
+ ptext SLIT("also at ") <+> ppr loc]
-checkModDeprec :: Maybe DeprecTxt -> Deprecations
--- Check for a module deprecation; done once at top level
-checkModDeprec Nothing = NoDeprecs
-checkModDeprec (Just txt) = DeprecAll txt
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
-rnHsForeignDecl (ForeignImport name ty spec isDeprec)
+rnHsForeignDecl (ForeignImport name ty spec)
= lookupLocatedTopBndrRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
- returnM (ForeignImport name' ty' spec isDeprec, fvs)
+ returnM (ForeignImport name' ty' spec, fvs)
-rnHsForeignDecl (ForeignExport name ty spec isDeprec)
+rnHsForeignDecl (ForeignExport name ty spec)
= lookupLocatedOccRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
- returnM (ForeignExport name' ty' spec isDeprec, fvs )
+ returnM (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
%*********************************************************
\begin{code}
-rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
+rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
-- Used for both source and interface file decls
= rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' ->
+ -- Rename the associated types
+ -- The typechecker (not the renamer) checks that all
+ -- the declarations are for the right class
+ let
+ at_doc = text "In the associated types of an instance declaration"
+ at_names = map (head . tyClDeclNames . unLoc) ats
+ in
+ checkDupNames at_doc at_names `thenM_`
+ rnATInsts ats `thenM` \ (ats', at_fvs) ->
+
-- Rename the bindings
-- The typechecker (not the renamer) checks that all
-- the bindings are for the right class
extendTyVarEnvForMethodBinds inst_tyvars (
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
- rnMethodBinds cls [] mbinds
+ rnMethodBinds cls (\n->[]) -- No scoped tyvars
+ [] mbinds
) `thenM` \ (mbinds', meth_fvs) ->
-- Rename the prags and signatures.
-- Note that the type variables are not in scope here,
in
bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' ->
- returnM (InstDecl inst_ty' mbinds' uprags',
- meth_fvs `plusFV` hsSigsFVs uprags'
+ returnM (InstDecl inst_ty' mbinds' uprags' ats',
+ meth_fvs `plusFV` at_fvs
+ `plusFV` hsSigsFVs uprags'
`plusFV` extractHsTyNames inst_ty')
+ -- We return the renamed associated data type declarations so
+ -- that they can be entered into the list of type declarations
+ -- for the binding group, but we also keep a copy in the instance.
+ -- The latter is needed for well-formedness checks in the type
+ -- checker (eg, to ensure that all ATs of the instance actually
+ -- receive a declaration).
+ -- NB: Even the copies in the instance declaration carry copies of
+ -- the instance context after renaming. This is a bit
+ -- strange, but should not matter (and it would be more work
+ -- to remove the context).
+\end{code}
+
+Renaming of the associated types in instances.
+
+\begin{code}
+rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
+rnATInsts atDecls = rnList rnATInst atDecls
+ where
+ rnATInst tydecl@TyData {} = rnTyClDecl tydecl
+ rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl
+ rnATInst tydecl =
+ pprPanic "RnSource.rnATInsts: invalid AT instance"
+ (ppr (tcdName tydecl))
\end{code}
For the method bindings in class and instance decls, we extend the
\begin{code}
extendTyVarEnvForMethodBinds tyvars thing_inside
- = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
- if opt_GlasgowExts then
- extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
- else
- thing_inside
+ = do { scoped_tvs <- doptM Opt_ScopedTypeVariables
+ ; if scoped_tvs then
+ extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
+ else
+ thing_inside }
\end{code}
+%*********************************************************
+%* *
+\subsection{Stand-alone deriving declarations}
+%* *
+%*********************************************************
+
+\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)
+\end{code}
%*********************************************************
%* *
rnLExpr lhs `thenM` \ (lhs', fv_lhs') ->
rnLExpr rhs `thenM` \ (rhs', fv_rhs') ->
- let
- mb_bad = validRuleLhs ids lhs'
- in
- checkErr (isNothing mb_bad)
- (badRuleLhsErr rule_name lhs' mb_bad) `thenM_`
- let
- bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
- in
- mappM (addErr . badRuleVar rule_name) bad_vars `thenM_`
+
+ checkValidRule rule_name ids lhs' fv_lhs' `thenM_`
+
returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
where
rn_var (RuleBndrSig (L loc v) t, id)
= rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
returnM (RuleBndrSig (L loc id) t', fvs)
+
+badRuleVar name var
+ = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
+ ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
+ ptext SLIT("does not appear on left hand side")]
\end{code}
-Check the shape of a transformation rule LHS. Currently
-we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
-not one of the @forall@'d variables. We also restrict the form of the LHS so
-that it may be plausibly matched. Basically you only get to write ordinary
-applications. (E.g. a case expression is not allowed: too elaborate.)
+Note [Rule LHS validity checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Check the shape of a transformation rule LHS. Currently we only allow
+LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
+@forall@'d variables.
-NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
+We used restrict the form of the 'ei' to prevent you writing rules
+with LHSs with a complicated desugaring (and hence unlikely to match);
+(e.g. a case expression is not allowed: too elaborate.)
+But there are legitimate non-trivial args ei, like sections and
+lambdas. So it seems simmpler not to check at all, and that is why
+check_e is commented out.
+
\begin{code}
+checkValidRule rule_name ids lhs' fv_lhs'
+ = do { -- Check for the form of the LHS
+ case (validRuleLhs ids lhs') of
+ Nothing -> return ()
+ Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
+
+ -- 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 }
+
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
-- Nothing => OK
-- Just e => Not ok, and e is the offending expression
check (HsVar v) | v `notElem` foralls = Nothing
check other = Just other -- Failure
- checkl_e (L loc e) = check_e e
+ -- Check an argument
+ checkl_e (L loc e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
+{- Commented out; see Note [Rule LHS validity checking] above
check_e (HsVar v) = Nothing
check_e (HsPar e) = checkl_e e
check_e (HsLit e) = Nothing
check_e other = Just other -- Fails
checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
+-}
-badRuleLhsErr name lhs (Just bad_e)
+badRuleLhsErr name lhs bad_e
= sep [ptext SLIT("Rule") <+> ftext name <> colon,
nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
ptext SLIT("in left-hand side:") <+> ppr lhs])]
$$
ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
-
-badRuleVar name var
- = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
- ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
- ptext SLIT("does not appear on left hand side")]
\end{code}
returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
emptyFVs)
-rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
- tcdTyVars = tyvars, tcdCons = condecls,
- tcdKindSig = sig, tcdDerivs = derivs})
- | is_vanilla -- Normal Haskell data type decl
+-- all flavours of type family declarations ("type family", "newtype fanily",
+-- and "data family")
+rnTyClDecl (tydecl@TyFamily {}) =
+ rnFamily tydecl bindTyVarsRn
+
+-- "data", "newtype", "data instance, and "newtype instance" declarations
+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
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
- do { tycon' <- lookupLocatedTopBndrRn tycon
+ 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
; checkDupNames data_doc con_names
; condecls' <- rnConDecls (unLoc tycon') condecls
- ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
- tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls',
- tcdDerivs = derivs'},
+ ; returnM (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) }
-
- | otherwise -- GADT
- = do { tycon' <- lookupLocatedTopBndrRn tycon
+ plusFVs (map conDeclFVs condecls') `plusFV`
+ deriv_fvs `plusFV`
+ (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
+ then lookupLocatedOccRn tycon -- may be imported family
+ else lookupLocatedTopBndrRn tycon
; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
; tyvars' <- bindTyVarsRn data_doc tyvars
(\ tyvars' -> return tyvars')
; (derivs', deriv_fvs) <- rn_derivs derivs
; checkDupNames data_doc con_names
; condecls' <- rnConDecls (unLoc tycon') condecls
- ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
- tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
- tcdDerivs = derivs'},
- plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
-
+ ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
+ tcdLName = tycon', tcdTyVars = tyvars',
+ tcdTyPats = Nothing, tcdKindSig = sig,
+ tcdCons = condecls', tcdDerivs = derivs'},
+ plusFVs (map conDeclFVs condecls') `plusFV`
+ deriv_fvs `plusFV`
+ (if isFamInstDecl tydecl
+ then unitFV (unLoc tycon') -- type instance => use
+ else emptyFVs))
+ }
where
is_vanilla = case condecls of -- Yuk
[] -> True
L _ (ConDecl { con_res = ResTyH98 }) : _ -> True
other -> False
+ none Nothing = True
+ none (Just []) = True
+ none _ = False
+
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
con_names = map con_names_helper condecls
rn_derivs Nothing = returnM (Nothing, emptyFVs)
rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
returnM (Just ds', extractHsTyNames_s ds')
-
-rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
- = lookupLocatedTopBndrRn name `thenM` \ name' ->
- bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- rnHsTypeFVs syn_doc ty `thenM` \ (ty', fvs) ->
- returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
- tcdSynRhs = ty'},
- delFVs (map hsLTyVarName tyvars') fvs)
+
+-- "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
+ 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',
+ 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)
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
- tcdMeths = mbinds})
- = lookupLocatedTopBndrRn cname `thenM` \ cname' ->
+ tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
+ = do { cname' <- lookupLocatedTopBndrRn cname
-- Tyvars scope over superclass context and method signatures
- bindTyVarsRn cls_doc tyvars ( \ tyvars' ->
- rnContext cls_doc context `thenM` \ context' ->
- rnFds cls_doc fds `thenM` \ fds' ->
- renameSigs okClsDclSig sigs `thenM` \ sigs' ->
- returnM (tyvars', context', fds', sigs')
- ) `thenM` \ (tyvars', context', fds', sigs') ->
+ ; (tyvars', context', fds', ats', ats_fvs, sigs')
+ <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
+ { context' <- rnContext cls_doc context
+ ; fds' <- rnFds cls_doc fds
+ ; (ats', ats_fvs) <- rnATs ats
+ ; sigs' <- renameSigs okClsDclSig sigs
+ ; return (tyvars', context', fds', ats', ats_fvs, sigs') }
+
+ -- Check for duplicates among the associated types
+ ; let at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats]
+ ; checkDupNames at_doc at_rdr_names_w_locs
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
- let
- sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
- in
- checkDupNames sig_doc sig_rdr_names_w_locs `thenM_`
- -- Typechecker is responsible for checking that we only
- -- give default-method bindings for things in this class.
- -- The renamer *could* check this for class decls, but can't
- -- for instance decls.
+ ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
+ ; checkDupNames sig_doc sig_rdr_names_w_locs
+ -- Typechecker is responsible for checking that we only
+ -- give default-method bindings for things in this class.
+ -- The renamer *could* check this for class decls, but can't
+ -- for instance decls.
-- The newLocals call is tiresome: given a generic class decl
-- class C a where
-- op {| a*b |} (a*b) = ...
-- we want to name both "x" tyvars with the same unique, so that they are
-- easy to group together in the typechecker.
- extendTyVarEnvForMethodBinds tyvars' (
- getLocalRdrEnv `thenM` \ name_env ->
- let
- meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
- gen_rdr_tyvars_w_locs =
- [ tv | tv <- extractGenericPatTyVars mbinds,
- not (unLoc tv `elemLocalRdrEnv` name_env) ]
- in
- checkDupNames meth_doc meth_rdr_names_w_locs `thenM_`
- newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars ->
- rnMethodBinds (unLoc cname') gen_tyvars mbinds
- ) `thenM` \ (mbinds', meth_fvs) ->
-
- returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
- tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
- delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context' `plusFV`
- plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
- hsSigsFVs sigs' `plusFV`
- meth_fvs)
+ ; (mbinds', meth_fvs)
+ <- extendTyVarEnvForMethodBinds tyvars' $ do
+ { name_env <- getLocalRdrEnv
+ ; let meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
+ gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
+ not (unLoc tv `elemLocalRdrEnv` name_env) ]
+ ; checkDupNames meth_doc meth_rdr_names_w_locs
+ ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
+ ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
+
+ -- Haddock docs
+ ; docs' <- mapM (wrapLocM rnDocDecl) docs
+
+ ; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
+ tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
+ tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
+
+ delFVs (map hsLTyVarName tyvars') $
+ extractHsCtxtTyNames context' `plusFV`
+ plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
+ hsSigsFVs sigs' `plusFV`
+ meth_fvs `plusFV`
+ ats_fvs) }
where
meth_doc = text "In the default-methods for class" <+> ppr cname
cls_doc = text "In the declaration for class" <+> ppr cname
sig_doc = text "In the signatures for class" <+> ppr cname
+ at_doc = text "In the associated types for class" <+> ppr cname
badGadtStupidTheta tycon
= vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
%*********************************************************
\begin{code}
+-- 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
= mappM (wrapLocM rnConDecl) condecls
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
-rnConDecl (ConDecl name expl tvs cxt details res_ty)
+rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc)
= do { addLocM checkConName name
; new_name <- lookupLocatedTopBndrRn name
-- 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 = hsConArgs details
+ arg_tys = hsConDeclArgTys details
implicit_tvs = case res_ty of
ResTyH98 -> filter not_in_scope $
get_rdr_tvs arg_tys
Explicit -> tvs
Implicit -> userHsTyVarBndrs implicit_tvs
+ ; mb_doc' <- rnMbLHsDoc mb_doc
+
; bindTyVarsRn doc tvs' $ \new_tyvars -> do
{ new_context <- rnContext doc cxt
- ; new_details <- rnConDetails doc details
- ; new_res_ty <- rnConResult doc res_ty
- ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty
- ; traceRn (text "****** - autrijus" <> ppr rv)
- ; return rv } }
- where
+ ; 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') }}
+ where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
-rnConResult _ ResTyH98 = return ResTyH98
-rnConResult doc (ResTyGADT ty) = do
- ty' <- rnHsSigType doc ty
- return $ ResTyGADT ty'
+rnConResult _ details ResTyH98 = return (details, ResTyH98)
-rnConDetails doc (PrefixCon tys)
+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 fields -> return (details, ResTyGADT ty')
+ InfixCon {} -> panic "rnConResult"
+
+rnConDeclDetails doc (PrefixCon tys)
= mappM (rnLHsType doc) tys `thenM` \ new_tys ->
returnM (PrefixCon new_tys)
-rnConDetails doc (InfixCon ty1 ty2)
+rnConDeclDetails doc (InfixCon ty1 ty2)
= rnLHsType doc ty1 `thenM` \ new_ty1 ->
rnLHsType doc ty2 `thenM` \ new_ty2 ->
returnM (InfixCon new_ty1 new_ty2)
-rnConDetails doc (RecCon fields)
- = checkDupNames doc field_names `thenM_`
- mappM (rnField doc) fields `thenM` \ new_fields ->
- returnM (RecCon new_fields)
- where
- field_names = [fld | (fld, _) <- fields]
+rnConDeclDetails doc (RecCon fields)
+ = do { checkDupNames doc (map cd_fld_name fields)
+ ; new_fields <- mappM (rnField doc) fields
+ ; return (RecCon new_fields) }
-rnField doc (name, ty)
+rnField doc (ConDeclField name ty haddock_doc)
= lookupLocatedTopBndrRn name `thenM` \ new_name ->
rnLHsType doc ty `thenM` \ new_ty ->
- returnM (new_name, 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
+-- variables. On the toplevel, these are defining occurences, whereas they
+-- are usage occurences for associated types.
+--
+rnFamily :: TyClDecl RdrName
+ -> (SDoc -> [LHsTyVarBndr RdrName] ->
+ ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
+ RnM (TyClDecl Name, FreeVars))
+ -> RnM (TyClDecl Name, FreeVars)
+
+rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
+ tcdLName = tycon, tcdTyVars = tyvars})
+ bindIdxVars =
+ do { checkM (isDataFlavour flavour -- for synonyms,
+ || not (null tyvars)) $ addErr needOneIdx -- #indexes >= 1
+ ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
+ ; tycon' <- lookupLocatedTopBndrRn tycon
+ ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
+ tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
+ emptyFVs)
+ } }
+ where
+ isDataFlavour DataFamily = True
+ isDataFlavour _ = False
+
+family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
+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
+--
+rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
+rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
+ where
+ rn_at (tydecl@TyFamily {}) = rnFamily tydecl lookupIdxVars
+ rn_at (tydecl@TySynonym {}) =
+ do
+ checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
+ rnTyClDecl tydecl
+ rn_at _ = panic "RnSource.rnATs: invalid TyClDecl"
+
+ lookupIdxVars _ tyvars cont =
+ do { checkForDups tyvars;
+ ; tyvars' <- mappM lookupIdxVar tyvars
+ ; cont tyvars'
+ }
+ -- Type index variables must be class parameters, which are the only
+ -- type variables in scope at this point.
+ lookupIdxVar (L l tyvar) =
+ do
+ name' <- lookupOccRn (hsTyVarName tyvar)
+ return $ L l (replaceTyVarName tyvar name')
+
+ -- Type variable may only occur once.
+ --
+ checkForDups [] = return ()
+ checkForDups (L loc tv:ltvs) =
+ do { setSrcSpan loc $
+ when (hsTyVarName tv `ltvElem` ltvs) $
+ addErr (repeatedTyVar tv)
+ ; checkForDups ltvs
+ }
+
+ rdrName `ltvElem` [] = False
+ rdrName `ltvElem` (L _ tv:ltvs)
+ | rdrName == hsTyVarName tv = True
+ | otherwise = rdrName `ltvElem` ltvs
+
+noPatterns = text "Default definition for an associated synonym cannot have"
+ <+> text "type pattern"
+
+repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+>
+ quotes (ppr tv)
-- This data decl will parse OK
-- data T = a Int
%*********************************************************
%* *
+\subsection{Support code for type/data declarations}
+%* *
+%*********************************************************
+
+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
+ = do { tcg_env <- getGblEnv
+ ; field_env' <- foldrM get (tcg_field_env tcg_env) decls
+ ; return (tcg_env { tcg_field_env = field_env' }) }
+ where
+ -- we want to lookup:
+ -- (a) a datatype constructor
+ -- (b) a record field
+ -- knowing that they're from this module.
+ -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
+ -- which keeps only the local ones.
+ lookup x = do { x' <- lookupLocatedTopBndrRn x
+ ; return $ unLoc x'}
+
+ get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons
+ get other env = return env
+
+ get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env
+ = do { con' <- lookup con
+ ; flds' <- mappM lookup (map cd_fld_name flds)
+ ; return $ extendNameEnv env con' flds' }
+ get_con other env
+ = return env
+\end{code}
+
+%*********************************************************
+%* *
\subsection{Support code to rename types}
%* *
%*********************************************************
projects / ghc-hetmet.git / blobdiff