X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=041a34c022eb5bb0f53c2883d00609521f090397;hb=732f30c21c984cf2a03afca3df91fa539c354559;hp=a9d6c5d720a9b7926eccf542354236e47423c60f;hpb=e3dd39bf230380f02d73efc287226117bb2eb47f;p=ghc-hetmet.git diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index a9d6c5d..041a34c 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -6,7 +6,7 @@ \begin{code} module RnSource ( rnSrcDecls, addTcgDUs, - rnTyClDecls, checkModDeprec, + rnTyClDecls, rnSplice, checkTH ) where @@ -23,7 +23,7 @@ import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn ) import RnEnv ( lookupLocalDataTcNames, lookupLocatedTopBndrRn, lookupLocatedOccRn, - lookupOccRn, lookupTopBndrRn, newLocalsRn, + lookupOccRn, newLocalsRn, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalNames, checkDupNames, mapFvRn @@ -31,8 +31,7 @@ import RnEnv ( lookupLocalDataTcNames, import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad -import HscTypes ( FixityEnv, FixItem(..), - Deprecations, Deprecs(..), DeprecTxt, plusDeprecs ) +import HscTypes ( FixityEnv, FixItem(..), Deprecations, Deprecs(..), plusDeprecs ) import Class ( FunDep ) import Name ( Name, nameOccName ) import NameSet @@ -42,7 +41,7 @@ import Outputable import SrcLoc ( Located(..), unLoc, noLoc ) import DynFlags ( DynFlag(..) ) import Maybes ( seqMaybe ) -import Maybe ( isNothing, isJust ) +import Maybe ( isNothing ) import Monad ( liftM, when ) import BasicTypes ( Boxity(..) ) \end{code} @@ -75,7 +74,7 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, hs_fords = foreign_decls, hs_defds = default_decls, hs_ruleds = rule_decls, - hs_docs = docs }) + hs_docs = docs }) = do { -- Deal with deprecations (returns only the extra deprecations) deprecs <- rnSrcDeprecDecls deprec_decls ; @@ -102,21 +101,15 @@ rnSrcDecls (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) - <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ; - traceRn (text "finish rnTyClDecls") ; - (rn_inst_decls, src_fvs2) - <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ; - (rn_deriv_decls, src_fvs_deriv) - <- mapFvRn (wrapLocFstM rnSrcDerivDecl) deriv_decls ; - (rn_rule_decls, src_fvs3) - <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ; - (rn_foreign_decls, src_fvs4) - <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ; - (rn_default_decls, src_fvs5) - <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ; - - rn_docs <- rnDocEntities docs ; + (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ; + (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; + (rn_rule_decls, src_fvs3) <- rnList rnHsRuleDecl rule_decls ; + (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 ; + + -- Haddock docs; no free vars + rn_docs <- mapM (wrapLocM rnDocDecl) docs ; let { rn_group = HsGroup { hs_valds = rn_val_decls, @@ -128,9 +121,9 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, hs_fords = rn_foreign_decls, hs_defds = rn_default_decls, hs_ruleds = rn_rule_decls, - hs_docs = rn_docs } ; + hs_docs = rn_docs } ; - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3, + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3, src_fvs4, src_fvs5] ; src_dus = bind_dus `plusDU` usesOnly other_fvs -- Note: src_dus will contain *uses* for locally-defined types @@ -146,12 +139,15 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, }}} rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name] -rnTyClDecls tycl_decls = do - (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls - return decls' +-- Used for external core +rnTyClDecls tycl_decls = do (decls', fvs) <- rnList rnTyClDecl tycl_decls + return decls' addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 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) +rnList f xs = mapFvRn (wrapLocFstM f) xs \end{code} @@ -162,21 +158,6 @@ addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } %********************************************************* \begin{code} -rnDocEntities :: [DocEntity RdrName] -> RnM [DocEntity Name] -rnDocEntities ents - = ifErrsM (return []) $ - -- Yuk: stop if we have found errors. Otherwise - -- the rnDocEntity stuff reports the errors again. - mapM rnDocEntity ents - -rnDocEntity :: DocEntity RdrName -> RnM (DocEntity Name) -rnDocEntity (DocEntity docdecl) = do - rn_docdecl <- rnDocDecl docdecl - return (DocEntity rn_docdecl) -rnDocEntity (DeclEntity name) = do - rn_name <- lookupTopBndrRn name - return (DeclEntity rn_name) - rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name) rnDocDecl (DocCommentNext doc) = do rn_doc <- rnHsDoc doc @@ -268,11 +249,6 @@ rnSrcDeprecDecls decls rn_deprec (Deprecation rdr_name txt) = lookupLocalDataTcNames rdr_name `thenM` \ names -> returnM [(name, (nameOccName name, txt)) | name <- names] - -checkModDeprec :: Maybe DeprecTxt -> Deprecations --- Check for a module deprecation; done once at top level -checkModDeprec Nothing = NoDeprecs -checkModDeprec (Just txt) = DeprecAll txt \end{code} %********************************************************* @@ -304,7 +280,7 @@ rnHsForeignDecl (ForeignImport name ty spec) rnHsForeignDecl (ForeignExport name ty spec) = lookupLocatedOccRn name `thenM` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - returnM (ForeignExport name' ty' spec, fvs ) + returnM (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 @@ -382,8 +358,7 @@ Renaming of the associated types in instances. \begin{code} rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) -rnATInsts atDecls = - mapFvRn (wrapLocFstM rnATInst) atDecls +rnATInsts atDecls = rnList rnATInst atDecls where rnATInst tydecl@TyData {} = rnTyClDecl tydecl rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl @@ -690,10 +665,8 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds } - -- Sigh. Check the Haddock docs after the methods, to avoid duplicate errors - -- Example: class { op :: a->a; op2 x = x } - -- Don't want a duplicate complait about op2 - ; docs' <- bindLocalNames (map hsLTyVarName tyvars') $ rnDocEntities docs + -- Haddock docs + ; docs' <- mapM (wrapLocM rnDocDecl) docs ; return (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', @@ -824,8 +797,8 @@ rnFamily (tydecl@TyFamily {tcdFlavour = flavour, emptyFVs) } } where - isDataFlavour (DataFamily _) = True - isDataFlavour _ = False + 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"