X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=bfecfd631fe71aa60edd37e99f780acf9eee9375;hp=8a2d0f418e9a7dccd878d3384d5d3ea9677724ef;hb=6e9c0431a7cf2bf1a48f01db48c6a1d41fe15a09;hpb=459870b70715b066aadd6a9defc87fb1ffb45bf4 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 8a2d0f4..bfecfd6 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -4,17 +4,8 @@ \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, - rnSplice, checkTH + rnSrcDecls, addTcgDUs, rnTyClDecls ) where #include "HsVersions.h" @@ -22,42 +13,44 @@ module RnSource ( 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, - lookupOccRn, newLocalsRn, +import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, + lookupTopBndrRn, lookupLocatedTopBndrRn, + lookupOccRn, newLocalBndrsRn, bindLocalNamesFV, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, - bindLocalNames, checkDupRdrNames, mapFvRn, lookupGreLocalRn, + bindLocalNames, checkDupRdrNames, mapFvRn ) import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) -import HscTypes ( GenAvailInfo(..) ) +import HscTypes ( GenAvailInfo(..), availsToNameSet ) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad -import HscTypes ( FixityEnv, FixItem(..), Deprecations(..), plusDeprecs ) +import ForeignCall ( CCallTarget(..) ) +import Module +import HscTypes ( Warnings(..), plusWarns ) import Class ( FunDep ) import Name ( Name, nameOccName ) import NameSet import NameEnv -import LazyUniqFM -import OccName import Outputable +import Bag import FastString -import SrcLoc ( Located(..), unLoc, noLoc ) -import DynFlags ( DynFlag(..) ) -import Maybe ( isNothing ) +import Util ( filterOut ) +import SrcLoc +import DynFlags ( DynFlag(..), DynFlags, thisPackage ) +import HscTypes ( HscEnv, hsc_dflags ) import BasicTypes ( Boxity(..) ) +import ListSetOps ( findDupsEq ) -import ListSetOps (findDupsEq, mkLookupFun) import Control.Monad +import Data.Maybe \end{code} \begin{code} @@ -67,18 +60,6 @@ thenM = (>>=) 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. @@ -100,18 +81,15 @@ Checks the @(..)@ etc constraints in the export list. \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_depds = deprec_decls, + hs_warnds = warn_decls, + hs_annds = ann_decls, hs_fords = foreign_decls, hs_defds = default_decls, hs_ruleds = rule_decls, @@ -124,8 +102,10 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_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 @@ -134,7 +114,7 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, -- 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, @@ -142,10 +122,12 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, -- 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. @@ -165,26 +147,30 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, -- (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_deprecs <- rnSrcDeprecDecls deprec_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 ; @@ -194,15 +180,16 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, hs_instds = rn_inst_decls, hs_derivds = rn_deriv_decls, hs_fixds = rn_fix_decls, - hs_depds = [], -- deprecs are returned in the tcg_env + hs_warnds = [], -- warns are returned in the tcg_env -- (see below) not in the HsGroup hs_fords = rn_foreign_decls, + hs_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 @@ -211,7 +198,7 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus) in -- we return the deprecs in the env, not in the HsGroup above - tcg_env' { tcg_deprecs = tcg_deprecs tcg_env' `plusDeprecs` rn_deprecs }; + tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; } ; traceRn (text "finish rnSrc" <+> ppr rn_group) ; @@ -227,10 +214,12 @@ inNewEnv env cont = do e <- env rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name] -- Used for external core -rnTyClDecls tycl_decls = do (decls', fvs) <- rnList rnTyClDecl tycl_decls +rnTyClDecls tycl_decls = do (decls', _fvs) <- rnList rnTyClDecl tycl_decls 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) @@ -245,7 +234,7 @@ rnList f xs = mapFvRn (wrapLocFstM f) xs %********************************************************* \begin{code} -rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name) +rnDocDecl :: DocDecl -> RnM DocDecl rnDocDecl (DocCommentNext doc) = do rn_doc <- rnHsDoc doc return (DocCommentNext rn_doc) @@ -268,14 +257,14 @@ rnDocDecl (DocGroup lev doc) = do %********************************************************* \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 @@ -287,9 +276,10 @@ rnSrcFixityDecls fix_decls 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} @@ -307,43 +297,68 @@ 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 +rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings +rnSrcWarnDecls _bound_names [] + = return NoWarnings -rnSrcDeprecDecls decls +rnSrcWarnDecls bound_names 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))) } + ; mapM_ (\ (L loc rdr:lrdr':_) -> addErrAt loc (dupWarnDecl lrdr' rdr)) + warn_rdr_dups + ; pairs_s <- mapM (addLocM rn_deprec) decls + ; return (WarnSome ((concat pairs_s))) } where - rn_deprec (Deprecation rdr_name txt) + rn_deprec (Warning rdr_name txt) -- ensures that the names are defined locally - = lookupLocalDataTcNames rdr_name `thenM` \ names -> - returnM [(nameOccName name, txt) | name <- names] + = 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 - deprec_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) - (map (\ (L loc (Deprecation rdr_name _)) -> L loc rdr_name) decls) + warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) + (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls) -dupDeprecDecl (L loc _) rdr_name - = vcat [ptext SLIT("Multiple deprecation declarations for") <+> quotes (ppr rdr_name), - ptext SLIT("also at ") <+> ppr loc] +dupWarnDecl :: Located RdrName -> RdrName -> SDoc +-- Located RdrName -> DeprecDecl RdrName -> SDoc +dupWarnDecl (L loc _) rdr_name + = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name), + ptext (sLit "also at ") <+> ppr loc] \end{code} %********************************************************* %* * -\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} %* * %********************************************************* \begin{code} +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} @@ -355,20 +370,54 @@ rnDefaultDecl (DefaultDecl tys) %********************************************************* \begin{code} +rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) rnHsForeignDecl (ForeignImport name ty spec) - = lookupLocatedTopBndrRn name `thenM` \ name' -> + = getTopEnv `thenM` \ (topEnv :: HscEnv) -> + lookupLocatedTopBndrRn name `thenM` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - returnM (ForeignImport name' ty' spec, fvs) + + -- Mark any PackageTarget style imports as coming from the current package + let packageId = thisPackage $ hsc_dflags topEnv + spec' = patchForeignImport packageId spec + + in 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 -fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name +fo_decl_msg :: Located RdrName -> SDoc +fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name + + +-- | For Windows DLLs we need to know what packages imported symbols are from +-- to generate correct calls. Imported symbols are tagged with the current +-- package, so if they get inlined across a package boundry we'll still +-- know where they're from. +-- +patchForeignImport :: PackageId -> ForeignImport -> ForeignImport +patchForeignImport packageId (CImport cconv safety fs spec) + = CImport cconv safety fs (patchCImportSpec packageId spec) + +patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec +patchCImportSpec packageId spec + = case spec of + CFunction callTarget -> CFunction $ patchCCallTarget packageId callTarget + _ -> spec + +patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget +patchCCallTarget packageId callTarget + = case callTarget of + StaticTarget label Nothing + -> StaticTarget label (Just packageId) + + _ -> callTarget + + \end{code} @@ -379,6 +428,7 @@ fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name %********************************************************* \begin{code} +rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) 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' -> @@ -387,11 +437,10 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- The typechecker (not the renamer) checks that all -- the bindings are for the right class let - meth_doc = text "In the bindings in an instance declaration" meth_names = collectHsBindLocatedBinders mbinds (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') in - checkDupRdrNames meth_doc meth_names `thenM_` + checkDupRdrNames meth_names `thenM_` -- Check that the same method is not given twice in the -- same instance decl instance C T where -- f x = ... @@ -404,17 +453,16 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) extendTyVarEnvForMethodBinds inst_tyvars ( -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too - rnMethodBinds cls (\n->[]) -- No scoped tyvars + rnMethodBinds cls (\_ -> []) -- No scoped tyvars [] mbinds ) `thenM` \ (mbinds', meth_fvs) -> -- 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 - checkDupRdrNames at_doc at_names `thenM_` + checkDupRdrNames at_names `thenM_` -- See notes with checkDupRdrNames for methods, above rnATInsts ats `thenM` \ (ats', at_fvs) -> @@ -428,11 +476,12 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- But the (unqualified) method names are in scope let binders = collectHsBindBinders mbinds' - ok_sig = okInstDclSig (mkNameSet binders) + bndr_set = mkNameSet binders in - bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' -> + bindLocalNames binders + (renameSigs (Just bndr_set) okInstDclSig uprags) `thenM` \ uprags' -> - returnM (InstDecl inst_ty' mbinds' uprags' ats', + return (InstDecl inst_ty' mbinds' uprags' ats', meth_fvs `plusFV` at_fvs `plusFV` hsSigsFVs uprags' `plusFV` extractHsTyNames inst_ty') @@ -465,6 +514,9 @@ For the method bindings in class and instance decls, we extend the type variable environment iff -fglasgow-exts \begin{code} +extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name] + -> RnM (Bag (LHsBind Name), FreeVars) + -> RnM (Bag (LHsBind Name), FreeVars) extendTyVarEnvForMethodBinds tyvars thing_inside = do { scoped_tvs <- doptM Opt_ScopedTypeVariables ; if scoped_tvs then @@ -482,9 +534,16 @@ extendTyVarEnvForMethodBinds tyvars thing_inside \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} %********************************************************* @@ -494,35 +553,38 @@ rnSrcDerivDecl (DerivDecl ty) %********************************************************* \begin{code} -rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs) +rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) +rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) = bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ + bindLocatedLocalsFV (map get_var vars) $ \ ids -> + do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids) + -- NB: The binders in a rule are always Ids + -- We don't (yet) support type variables - bindLocatedLocalsFV doc (map get_var vars) $ \ ids -> - mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) -> - - rnLExpr lhs `thenM` \ (lhs', fv_lhs') -> - rnLExpr rhs `thenM` \ (rhs', fv_rhs') -> + ; (lhs', fv_lhs') <- rnLExpr lhs + ; (rhs', fv_rhs') <- rnLExpr rhs - checkValidRule rule_name ids lhs' fv_lhs' `thenM_` + ; checkValidRule rule_name ids lhs' fv_lhs' - returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', - fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') + ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', + fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') } where doc = text "In the transformation rule" <+> ftext rule_name get_var (RuleBndr v) = v get_var (RuleBndrSig v _) = v - rn_var (RuleBndr (L loc v), id) - = returnM (RuleBndr (L loc id), emptyFVs) - rn_var (RuleBndrSig (L loc v) t, id) + rn_var (RuleBndr (L loc _), id) + = 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 - = 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")] + = 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} Note [Rule LHS validity checking] @@ -540,6 +602,7 @@ lambdas. So it seems simmpler not to check at all, and that is why check_e is commented out. \begin{code} +checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM () checkValidRule rule_name ids lhs' fv_lhs' = do { -- Check for the form of the LHS case (validRuleLhs ids lhs') of @@ -548,7 +611,7 @@ checkValidRule rule_name ids lhs' fv_lhs' -- Check that LHS vars are all bound ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] - ; mappM (addErr . badRuleVar rule_name) bad_vars } + ; mapM_ (addErr . badRuleVar rule_name) bad_vars } validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name) -- Nothing => OK @@ -556,7 +619,7 @@ validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name) validRuleLhs foralls lhs = checkl lhs where - checkl (L loc e) = check e + checkl (L _ e) = check e check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2 @@ -564,7 +627,7 @@ validRuleLhs foralls lhs check other = Just other -- Failure -- Check an argument - checkl_e (L loc e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking] + checkl_e (L _ _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 @@ -576,18 +639,18 @@ validRuleLhs foralls lhs 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 -} +badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc 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])] + = 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") + ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd") \end{code} @@ -611,9 +674,10 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name}) +rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars) +rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name}) = lookupLocatedTopBndrRn name `thenM` \ name' -> - returnM (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", @@ -622,97 +686,73 @@ rnTyClDecl (tydecl@TyFamily {}) = 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 - bindTyVarsRn data_doc tyvars $ \ tyvars' -> - do { tycon' <- if isFamInstDecl tydecl + tcdKindSig = sig, tcdDerivs = derivs} + = 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', - 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 - = 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') + ; checkTc (h98_style || null (unLoc context)) + (badGadtStupidTheta tycon) + ; (tyvars', context', typats', derivs', deriv_fvs) + <- bindTyVarsRn tyvars $ \ tyvars' -> do + -- Checks for distinct tyvars + { typats' <- rnTyPats data_doc typatsMaybe + ; 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 } - ; (derivs', deriv_fvs) <- rn_derivs derivs - ; 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 - ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], + + ; return (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', tcdTyVars = tyvars', - tcdTyPats = Nothing, tcdKindSig = sig, + 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 - other -> False - - none Nothing = True - none (Just []) = True - none _ = False - + _ -> False data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) - con_names = map con_names_helper condecls - - con_names_helper (L _ c) = con_name c - 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 - 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)) - } + = bindTyVarsRn tyvars $ \ tyvars' -> do + { -- Checks for distinct tyvars + 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 + ; 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) @@ -723,11 +763,12 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- Tyvars scope over superclass context and method signatures ; (tyvars', context', fds', ats', ats_fvs, sigs') - <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do + <- bindTyVarsRn tyvars $ \ tyvars' -> do + -- Checks for distinct tyvars { context' <- rnContext cls_doc context ; fds' <- rnFds cls_doc fds ; (ats', ats_fvs) <- rnATs ats - ; sigs' <- renameSigs okClsDclSig sigs + ; sigs' <- renameSigs Nothing okClsDclSig sigs ; return (tyvars', context', fds', ats', ats_fvs, sigs') } -- No need to check for duplicate associated type decls @@ -736,7 +777,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- 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] - ; checkDupRdrNames sig_doc sig_rdr_names_w_locs + ; checkDupRdrNames 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 @@ -753,13 +794,12 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ; (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, + ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds, not (unLoc tv `elemLocalRdrEnv` name_env) ] -- 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 @@ -776,16 +816,15 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 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"), - ptext SLIT("(You can put a context on each contructor, though.)")] +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} @@ -793,81 +832,93 @@ badGadtStupidTheta tycon %********************************************************* \begin{code} +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 - = mappM (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 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)) +rnConResult :: SDoc + -> HsConDetails (LHsType Name) [ConDeclField Name] + -> ResType RdrName + -> 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 fields -> 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 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 @@ -875,7 +926,7 @@ rnField doc (ConDeclField name ty haddock_doc) -- are usage occurences for associated types. -- rnFamily :: TyClDecl RdrName - -> (SDoc -> [LHsTyVarBndr RdrName] -> + -> ([LHsTyVarBndr RdrName] -> ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) -> RnM (TyClDecl Name, FreeVars)) -> RnM (TyClDecl Name, FreeVars) @@ -883,20 +934,13 @@ rnFamily :: TyClDecl RdrName 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 { + do { bindIdxVars tyvars $ \tyvars' -> do { ; tycon' <- lookupLocatedTopBndrRn tycon - ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon', + ; return (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" +rnFamily d _ = pprPanic "rnFamily" (ppr d) -- Rename associated type declarations (in classes) -- @@ -908,13 +952,13 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats 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" - lookupIdxVars _ tyvars cont = + 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 @@ -934,15 +978,27 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats ; checkForDups ltvs } - rdrName `ltvElem` [] = False + _ `ltvElem` [] = False rdrName `ltvElem` (L _ tv:ltvs) | 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" -repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+> +repeatedTyVar :: HsTyVarBndr RdrName -> SDoc +repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+> quotes (ppr tv) -- This data decl will parse OK @@ -955,10 +1011,12 @@ repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+> -- data T = :% Int Int -- from interface files, which always print in prefix form +checkConName :: RdrName -> TcRn () checkConName name = checkErr (isRdrDataCon name) (badDataCon name) +badDataCon :: RdrName -> SDoc badDataCon name - = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] + = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)] \end{code} @@ -971,10 +1029,10 @@ badDataCon name 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: @@ -986,15 +1044,21 @@ extendRecordFieldEnv decls 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 + 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 other 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} %********************************************************* @@ -1007,66 +1071,18 @@ extendRecordFieldEnv decls 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') - -rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs -rnHsTyvar doc tyvar = lookupOccRn tyvar -\end{code} + return (tys1', tys2') +rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name] +rnHsTyVars doc tvs = mapM (rnHsTyVar doc) tvs -%********************************************************* -%* * - Splices -%* * -%********************************************************* +rnHsTyVar :: SDoc -> RdrName -> RnM Name +rnHsTyVar _doc tyvar = lookupOccRn tyvar +\end{code} -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) } - -#ifdef GHCI -checkTH e what = 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}