X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=2ce2170f9b132df54471791d72143c7864f8a62e;hp=5d23110e5fc9bdfa624d4cb761fd83c32a61468e;hb=6ea06bbf08517d9805feb82df65cc56ecbaf23a4;hpb=302e2e29f2e1074bfba561e077a484dc4e1d15f6 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 5d23110..2ce2170 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -46,13 +46,14 @@ import Bag import FastString import Util ( filterOut ) import SrcLoc -import DynFlags ( DynFlag(..), DynFlags, thisPackage ) +import DynFlags import HscTypes ( HscEnv, hsc_dflags ) import BasicTypes ( Boxity(..) ) import ListSetOps ( findDupsEq ) - +import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) import Control.Monad +import Maybes( orElse ) import Data.Maybe \end{code} @@ -86,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. @@ -146,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 @@ -178,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 @@ -215,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. @@ -306,7 +305,8 @@ rnSrcWarnDecls _bound_names [] rnSrcWarnDecls bound_names decls = do { -- check for duplicates - ; mapM_ (\ (L loc rdr:lrdr':_) -> addErrAt loc (dupWarnDecl lrdr' rdr)) + ; 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))) } @@ -463,7 +463,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- The typechecker (not the renamer) checks that all -- the declarations are for the right class let - at_names = map (head . tyClDeclNames . unLoc) ats + at_names = map (head . hsTyClDeclBinders) ats in checkDupRdrNames at_names `thenM_` -- See notes with checkDupRdrNames for methods, above @@ -521,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 @@ -537,7 +537,7 @@ extendTyVarEnvForMethodBinds tyvars thing_inside \begin{code} rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) rnSrcDerivDecl (DerivDecl ty) - = do { standalone_deriv_ok <- doptM Opt_StandaloneDeriving + = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving ; unless standalone_deriv_ok (addErr standaloneDerivErr) ; ty' <- rnLHsType (text "a deriving decl") ty ; let fvs = extractHsTyNames ty' @@ -677,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' -> @@ -828,6 +840,35 @@ 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 + + %********************************************************* %* * \subsection{Support code for type/data declarations} @@ -1037,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 @@ -1055,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) @@ -1124,7 +1164,7 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds -- (i.e. a naked top level expression) case flag of Explicit -> return () - Implicit -> do { th_on <- doptM Opt_TemplateHaskell + Implicit -> do { th_on <- xoptM Opt_TemplateHaskell ; unless th_on $ setSrcSpan loc $ failWith badImplicitSplice } @@ -1145,9 +1185,9 @@ add gp _ (QuasiQuoteD qq) ds -- Expand quasiquotes 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 = L l d : ts, hs_fixds = fsigs ++ fs}) ds + addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds | otherwise - = addl (gp { hs_tyclds = L l d : ts }) ds + = 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 @@ -1177,6 +1217,10 @@ add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) 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"