X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=2ce2170f9b132df54471791d72143c7864f8a62e;hp=86873b0223cfabb6aacffc2b790b0aabb788b3f6;hb=6ea06bbf08517d9805feb82df65cc56ecbaf23a4;hpb=1fede4bc9501744bf2269ce2a4cb9fb735969caa diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 86873b0..2ce2170 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -5,12 +5,15 @@ \begin{code} module RnSource ( - rnSrcDecls, addTcgDUs, rnTyClDecls + rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice ) where #include "HsVersions.h" import {-# SOURCE #-} RnExpr( rnLExpr ) +#ifdef GHCI +import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) +#endif /* GHCI */ import HsSyn import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc ) @@ -21,17 +24,18 @@ import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSig makeMiniFixityEnv) import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, lookupTopBndrRn, lookupLocatedTopBndrRn, - lookupOccRn, newLocalsRn, + lookupOccRn, newLocalBndrsRn, bindLocalNamesFV, bindLocatedLocalsFV, bindPatSigTyVarsFV, - bindTyVarsRn, extendTyVarEnvFVRn, - bindLocalNames, checkDupRdrNames, mapFvRn, - checkM + bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn, + bindLocalNames, checkDupRdrNames, mapFvRn ) import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) import HscTypes ( GenAvailInfo(..), availsToNameSet ) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad +import ForeignCall ( CCallTarget(..) ) +import Module import HscTypes ( Warnings(..), plusWarns ) import Class ( FunDep ) import Name ( Name, nameOccName ) @@ -40,13 +44,16 @@ import NameEnv import Outputable import Bag import FastString +import Util ( filterOut ) import SrcLoc -import DynFlags ( DynFlag(..) ) +import DynFlags +import HscTypes ( HscEnv, hsc_dflags ) import BasicTypes ( Boxity(..) ) - -import ListSetOps (findDupsEq) +import ListSetOps ( findDupsEq ) +import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) import Control.Monad +import Maybes( orElse ) import Data.Maybe \end{code} @@ -80,17 +87,17 @@ Checks the @(..)@ etc constraints in the export list. -- does NOT assume that anything is in scope already rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) -- Rename a HsGroup; used for normal source files *and* hs-boot files -rnSrcDecls group@(HsGroup {hs_valds = val_decls, - hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_derivds = deriv_decls, - hs_fixds = fix_decls, - hs_warnds = warn_decls, - hs_annds = ann_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_docs = docs }) +rnSrcDecls group@(HsGroup { hs_valds = val_decls, + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = warn_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_docs = docs }) = do { -- (A) Process the fixity declarations, creating a mapping from -- FastStrings to FixItems. @@ -119,7 +126,7 @@ rnSrcDecls 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 { val_binders = map unLoc $ collectHsValBinders new_lhs ; + let { val_binders = 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 @@ -140,11 +147,11 @@ rnSrcDecls group@(HsGroup {hs_valds = val_decls, -- 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 ; + (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; -- (F) Rename Value declarations right-hand sides traceRn (text "Start rnmono") ; - (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ; + (rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ; traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; -- (G) Rename Fixity and deprecations @@ -172,35 +179,38 @@ rnSrcDecls group@(HsGroup {hs_valds = val_decls, 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, + 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_warnds = [], -- warns are returned in the tcg_env + hs_fixds = rn_fix_decls, + 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_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_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 - -- returns only the uses.) This is a little - -- surprising but it doesn't actually matter at all. - - 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_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; + tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ; + ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ; + other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ; + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, + src_fvs5, src_fvs6, src_fvs7] ; + -- It is tiresome to gather the binders from type and class decls + + src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ; + -- Instance decls may have occurrences of things bound in bind_dus + -- so we must put other_fvs last + + 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_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; } ; traceRn (text "finish rnSrc" <+> ppr rn_group) ; traceRn (text "finish Dus" <+> ppr src_dus ) ; - return (final_tcg_env , rn_group) + return (final_tcg_env, rn_group) }}}} -- some utils because we do this a bunch above @@ -209,11 +219,6 @@ inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a inNewEnv env cont = do e <- env setGblEnv e $ cont e -rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name] --- Used for external core -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. @@ -231,7 +236,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) @@ -300,9 +305,11 @@ rnSrcWarnDecls _bound_names [] rnSrcWarnDecls bound_names decls = do { -- check for duplicates - ; mapM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups - ; mapM (addLocM rn_deprec) decls `thenM` \ pairs_s -> - return (WarnSome ((concat pairs_s))) } + ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups + in addErrAt loc (dupWarnDecl lrdr' rdr)) + warn_rdr_dups + ; pairs_s <- mapM (addLocM rn_deprec) decls + ; return (WarnSome ((concat pairs_s))) } where rn_deprec (Warning rdr_name txt) -- ensures that the names are defined locally @@ -368,9 +375,15 @@ 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) -> - return (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' -> @@ -382,6 +395,32 @@ rnHsForeignDecl (ForeignExport name ty spec) 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} @@ -401,11 +440,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 + meth_names = collectMethodBinders 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 = ... @@ -425,10 +463,9 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- 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 + at_names = map (head . hsTyClDeclBinders) 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) -> @@ -441,7 +478,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- -- But the (unqualified) method names are in scope let - binders = collectHsBindBinders mbinds' + binders = collectHsBindsBinders mbinds' bndr_set = mkNameSet binders in bindLocalNames binders @@ -484,7 +521,7 @@ extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name] -> RnM (Bag (LHsBind Name), FreeVars) -> RnM (Bag (LHsBind Name), FreeVars) extendTyVarEnvForMethodBinds tyvars thing_inside - = do { scoped_tvs <- doptM Opt_ScopedTypeVariables + = do { scoped_tvs <- xoptM Opt_ScopedTypeVariables ; if scoped_tvs then extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside else @@ -500,9 +537,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 <- xoptM 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} %********************************************************* @@ -515,7 +559,7 @@ rnSrcDerivDecl (DerivDecl ty) rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) = bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ - bindLocatedLocalsFV doc (map get_var vars) $ \ ids -> + 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 @@ -633,6 +677,18 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} +rnTyClDecls :: [[LTyClDecl RdrName]] -> RnM ([[LTyClDecl Name]], FreeVars) +-- Renamed the declarations and do depedency analysis on them +rnTyClDecls tycl_ds + = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds) + + ; let sccs :: [SCC (LTyClDecl Name)] + sccs = depAnalTyClDecls ds_w_fvs + + all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs + + ; return (map flattenSCC sccs, all_fvs) } + rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars) rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name}) = lookupLocatedTopBndrRn name `thenM` \ name' -> @@ -641,75 +697,51 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name}) -- all flavours of type family declarations ("type family", "newtype fanily", -- and "data family") -rnTyClDecl (tydecl@TyFamily {}) = - rnFamily tydecl bindTyVarsRn +rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV -- "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, + tcdTyPats = typats, 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 - 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 - ; condecls' <- rnConDecls (unLoc tycon') condecls - -- No need to check for duplicate constructor decls - -- since that is done by RnNames.extendGlobalRdrEnvRn - ; (derivs', deriv_fvs) <- rn_derivs derivs - ; return (TyData {tcdND = new_or_data, tcdCtxt = context', - tcdLName = tycon', tcdTyVars = tyvars', - tcdTyPats = typats', tcdKindSig = Nothing, - tcdCons = condecls', tcdDerivs = derivs'}, - delFVs (map hsLTyVarName tyvars') $ - extractHsCtxtTyNames context' `plusFV` - plusFVs (map conDeclFVs condecls') `plusFV` - deriv_fvs `plusFV` - (if isFamInstDecl tydecl - then unitFV (unLoc tycon') -- type instance => use - else emptyFVs)) - } } - - | otherwise -- GADT = do { tycon' <- if isFamInstDecl tydecl then lookupLocatedOccRn tycon -- may be imported family else lookupLocatedTopBndrRn tycon - ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon) - ; (tyvars', typats') - <- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do - { typats' <- rnTyPats data_doc typatsMaybe - ; return (tyvars', typats') } - -- For GADTs, the type variables in the declaration - -- do not scope over the constructor signatures - -- data T a where { T1 :: forall b. b-> b } - - ; condecls' <- rnConDecls (unLoc tycon') condecls + ; checkTc (h98_style || null (unLoc context)) + (badGadtStupidTheta tycon) + ; ((tyvars', context', typats', derivs'), stuff_fvs) + <- bindTyVarsFV tyvars $ \ tyvars' -> do + -- Checks for distinct tyvars + { context' <- rnContext data_doc context + ; (typats', fvs1) <- rnTyPats data_doc tycon' typats + ; (derivs', fvs2) <- rn_derivs derivs + ; let fvs = fvs1 `plusFV` fvs2 `plusFV` + extractHsCtxtTyNames context' + ; return ((tyvars', context', typats', derivs'), fvs) } + + -- For the constructor declarations, bring into scope the tyvars + -- bound by the header, but *only* in the H98 case + -- Reason: for GADTs, the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars' + | otherwise = [] + ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $ + rnConDecls condecls -- No need to check for duplicate constructor decls -- since that is done by RnNames.extendGlobalRdrEnvRn - ; (derivs', deriv_fvs) <- rn_derivs derivs - ; return (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], + ; return (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = sig, tcdCons = condecls', tcdDerivs = derivs'}, - plusFVs (map conDeclFVs condecls') `plusFV` - deriv_fvs `plusFV` - (if isFamInstDecl tydecl - then unitFV (unLoc tycon') -- type instance => use - else emptyFVs)) + con_fvs `plusFV` stuff_fvs) } where - is_vanilla = case condecls of -- Yuk - [] -> True - L _ (ConDecl { con_res = ResTyH98 }) : _ -> True - _ -> False - + h98_style = case condecls of -- Note [Stupid theta] + L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False + _ -> True + data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) rn_derivs Nothing = return (Nothing, emptyFVs) @@ -718,22 +750,17 @@ rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, -- "type" and "type instance" declarations rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, - tcdTyPats = typatsMaybe, tcdSynRhs = ty}) - = ASSERT( distinctTyVarBndrs tyvars ) -- Tyvars should be distinct - do { bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do - { name' <- if isFamInstDecl tydecl - then lookupLocatedOccRn name -- may be imported family - else lookupLocatedTopBndrRn name - ; typats' <- rnTyPats syn_doc typatsMaybe - ; (ty', fvs) <- rnHsTypeFVs syn_doc ty - ; 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)) - } } + tcdTyPats = typats, tcdSynRhs = ty}) + = bindTyVarsFV tyvars $ \ tyvars' -> do + { -- Checks for distinct tyvars + name' <- if isFamInstDecl tydecl + then lookupLocatedOccRn name -- may be imported family + else lookupLocatedTopBndrRn name + ; (typats',fvs1) <- rnTyPats syn_doc name' typats + ; (ty', fvs2) <- rnHsTypeFVs syn_doc ty + ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' + , tcdTyPats = typats', tcdSynRhs = ty'}, + fvs1 `plusFV` fvs2) } where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) @@ -743,13 +770,18 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, = do { cname' <- lookupLocatedTopBndrRn cname -- Tyvars scope over superclass context and method signatures - ; (tyvars', context', fds', ats', ats_fvs, sigs') - <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do + ; ((tyvars', context', fds', ats', sigs'), stuff_fvs) + <- bindTyVarsFV tyvars $ \ tyvars' -> do + -- Checks for distinct tyvars { context' <- rnContext cls_doc context ; fds' <- rnFds cls_doc fds - ; (ats', ats_fvs) <- rnATs ats + ; (ats', at_fvs) <- rnATs ats ; sigs' <- renameSigs Nothing okClsDclSig sigs - ; return (tyvars', context', fds', ats', ats_fvs, sigs') } + ; let fvs = at_fvs `plusFV` + extractHsCtxtTyNames context' `plusFV` + hsSigsFVs sigs' + -- The fundeps have no free variables + ; return ((tyvars', context', fds', ats', sigs'), fvs) } -- No need to check for duplicate associated type decls -- since that is done by RnNames.extendGlobalRdrEnvRn @@ -757,7 +789,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 @@ -779,7 +811,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- 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 @@ -788,23 +820,9 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ; 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) } + meth_fvs `plusFV` stuff_fvs) } where 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 _ @@ -812,6 +830,44 @@ badGadtStupidTheta _ ptext (sLit "(You can put a context on each contructor, though.)")] \end{code} +Note [Stupid theta] +~~~~~~~~~~~~~~~~~~~ +Trac #3850 complains about a regression wrt 6.10 for + data Show a => T a +There is no reason not to allow the stupid theta if there are no data +constructors. It's still stupid, but does no harm, and I don't want +to cause programs to break unnecessarily (notably HList). So if there +are no data constructors we allow h98_style = True + + +\begin{code} +depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)] +-- See Note [Dependency analysis of type and class decls] +depAnalTyClDecls ds_w_fvs + = stronglyConnCompFromEdgedVertices edges + where + edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs)) + | (d, fvs) <- ds_w_fvs ] + get_assoc n = lookupNameEnv assoc_env n `orElse` n + assoc_env = mkNameEnv [ (tcdName assoc_decl, cls_name) + | (L _ (ClassDecl { tcdLName = L _ cls_name + , tcdATs = ats }) ,_) <- ds_w_fvs + , L _ assoc_decl <- ats ] +\end{code} + +Note [Dependency analysis of type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to do dependency analysis on type and class declarations +else we get bad error messages. Consider + + data T f a = MkT f a + data S f a = MkS f (T f a) + +This has a kind error, but the error message is better if you +check T first, (fixing its kind) and *then* S. If you do kind +inference together, you might get an error reported in S, which +is jolly confusing. See Trac #4875 + %********************************************************* %* * @@ -820,45 +876,48 @@ badGadtStupidTheta _ %********************************************************* \begin{code} +rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars) -- Although, we are processing type patterns here, all type variables will -- already be in scope (they are the same as in the 'tcdTyVars' field of the -- type declaration to which these patterns belong) --- -rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name]) -rnTyPats _ Nothing = return Nothing -rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats - -rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name] -rnConDecls _tycon condecls - = mapM (wrapLocM rnConDecl) condecls +rnTyPats _ _ Nothing + = return (Nothing, emptyFVs) +rnTyPats doc tc (Just typats) + = do { typats' <- rnLHsTypes doc typats + ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc) + -- type instance => use, hence addOneFV + ; return (Just typats', fvs) } + +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 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 }) + , 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) + + -- For H98 syntax, the tvs are the existential ones + -- For GADT syntax, the tvs are all the quantified tyvars + -- Hence the 'filter' in the ResTyH98 case only + ; rdr_env <- getLocalRdrEnv + ; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc + arg_tys = hsConDeclArgTys details + implicit_tvs = case res_ty of + ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys) + ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) new_tvs = case expl of Explicit -> tvs Implicit -> userHsTyVarBndrs implicit_tvs ; mb_doc' <- rnMbLHsDoc mb_doc - ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do + ; bindTyVarsRn new_tvs $ \new_tyvars -> do { new_context <- rnContext doc cxt ; new_details <- rnConDeclDetails doc details ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty @@ -916,7 +975,7 @@ rnConDeclDetails doc (RecCon fields) -- 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) @@ -924,7 +983,7 @@ rnFamily :: TyClDecl RdrName rnFamily (tydecl@TyFamily {tcdFlavour = flavour, tcdLName = tycon, tcdTyVars = tyvars}) bindIdxVars = - do { bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do { + do { bindIdxVars tyvars $ \tyvars' -> do { ; tycon' <- lookupLocatedTopBndrRn tycon ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon', tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, @@ -932,9 +991,6 @@ rnFamily (tydecl@TyFamily {tcdFlavour = flavour, } } rnFamily d _ = pprPanic "rnFamily" (ppr d) -family_doc :: Located RdrName -> SDoc -family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon) - -- Rename associated type declarations (in classes) -- -- * This can be family declarations and (default) type instances @@ -945,12 +1001,12 @@ 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 = - do { checkForDups tyvars; + lookupIdxVars tyvars cont = + do { checkForDups tyvars ; tyvars' <- mapM lookupIdxVar tyvars ; cont tyvars' } @@ -1022,7 +1078,7 @@ 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] -> [LInstDecl RdrName] -> TcM TcGblEnv +extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv extendRecordFieldEnv tycl_decls inst_decls = do { tcg_env <- getGblEnv ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons @@ -1040,9 +1096,8 @@ extendRecordFieldEnv tycl_decls inst_decls 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! + all_tycl_decls = at_tycl_decls ++ concat tycl_decls + at_tycl_decls = instDeclATs inst_decls -- Do not forget associated types! get_con (ConDecl { con_name = con, con_details = RecCon flds }) (RecFields env fld_set) @@ -1079,3 +1134,98 @@ rnHsTyVar _doc tyvar = lookupOccRn tyvar \end{code} +%********************************************************* +%* * + findSplice +%* * +%********************************************************* + +This code marches down the declarations, looking for the first +Template Haskell splice. As it does so it + a) groups the declarations into a HsGroup + b) runs any top-level quasi-quotes + +\begin{code} +findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +findSplice ds = addl emptyRdrGroup ds + +addl :: HsGroup RdrName -> [LHsDecl RdrName] + -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +-- This stuff reverses the declarations (again) but it doesn't matter +addl gp [] = return (gp, Nothing) +addl gp (L l d : ds) = add gp l d ds + + +add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName] + -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) + +add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds + = do { -- We've found a top-level splice. If it is an *implicit* one + -- (i.e. a naked top level expression) + case flag of + Explicit -> return () + Implicit -> do { th_on <- xoptM Opt_TemplateHaskell + ; unless th_on $ setSrcSpan loc $ + failWith badImplicitSplice } + + ; return (gp, Just (splice, ds)) } + where + badImplicitSplice = ptext (sLit "Parse error: naked expression at top level") + +#ifndef GHCI +add _ _ (QuasiQuoteD qq) _ + = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq) +#else +add gp _ (QuasiQuoteD qq) ds -- Expand quasiquotes + = do { ds' <- runQuasiQuoteDecl qq + ; addl gp (ds' ++ ds) } +#endif + +-- Class declarations: pull out the fixity signatures to the top +add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds + | isClassDecl d + = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in + addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds + | otherwise + = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds + +-- Signatures: fixity sigs go a different place than all others +add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds + = addl (gp {hs_fixds = L l f : ts}) ds +add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds + +-- Value declarations: use add_bind +add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds + +-- The rest are routine +add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds + = addl (gp { hs_instds = L l d : ts }) ds +add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds + = addl (gp { hs_derivds = L l d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds + = addl (gp { hs_defds = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds + = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds + = addl (gp { hs_warnds = L l d : ts }) ds +add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds + = addl (gp { hs_annds = L l d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds + = addl (gp { hs_ruleds = L l d : ts }) ds +add gp l (DocD d) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds + +add_tycld :: LTyClDecl a -> [[LTyClDecl a]] -> [[LTyClDecl a]] +add_tycld d [] = [[d]] +add_tycld d (ds:dss) = (d:ds) : dss + +add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a +add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs +add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" + +add_sig :: LSig a -> HsValBinds a -> HsValBinds a +add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) +add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" +\end{code} \ No newline at end of file