X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=3766e2148bea0b95d94d0da94bcebe64842b1b3a;hb=edc0bafd3fcd01b85a2e8894e5dfe149eb0e0857;hp=6dce0346ea49213ee7cbd9c643edd59c8f90feb4;hpb=b87e22d21055cd2bee40f0cc6873f1dcbe60fd01;p=ghc-hetmet.git diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 6dce034..3766e21 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -46,7 +46,7 @@ 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 ) @@ -86,17 +86,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. @@ -150,7 +150,7 @@ rnSrcDecls group@(HsGroup {hs_valds = val_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 +178,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 @@ -306,7 +309,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 +467,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 +525,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 +541,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' @@ -1056,8 +1060,7 @@ extendRecordFieldEnv tycl_decls inst_decls 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! + 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) @@ -1119,7 +1122,18 @@ 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 _ (SpliceD e) ds = return (gp, Just (e, ds)) +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) _