X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=2ce2170f9b132df54471791d72143c7864f8a62e;hp=a152a18a07f3e522a05e41fb0383cbb3c60f8338;hb=6ea06bbf08517d9805feb82df65cc56ecbaf23a4;hpb=b2d9ef8482638a91e68acdd19ecfe24db0458049 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index a152a18..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} @@ -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 @@ -209,7 +210,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, 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 @@ -218,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. @@ -309,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))) } @@ -466,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 @@ -524,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 @@ -540,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' @@ -680,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' -> @@ -831,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} @@ -1040,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 @@ -1058,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) @@ -1127,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 } @@ -1148,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 @@ -1180,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"