X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=1cb80587e489aff7a0524b58cb951d4d387f914b;hb=8b08c15b8ace5a76e341939081fbb6ad2736ddd1;hp=606139b116b62824e4ed3a05f2fb4532d9d252cb;hpb=202ac08f3e2afde0620e889cc81a95b2fd0ad9e1;p=ghc-hetmet.git diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 606139b..1cb8058 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -15,20 +15,20 @@ module RnSource ( import {-# SOURCE #-} RnExpr( rnLExpr ) import HsSyn -import RdrName ( RdrName, isRdrDataCon, isRdrTyVar, rdrNameOcc, - elemLocalRdrEnv, globalRdrEnvElts, GlobalRdrElt(..), - isLocalGRE ) +import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, + globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE ) import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) import RnHsSyn import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn ) import RnEnv ( lookupLocalDataTcNames, lookupLocatedTopBndrRn, lookupLocatedOccRn, - lookupOccRn, newLocalsRn, + lookupOccRn, lookupTopBndrRn, newLocalsRn, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalNames, checkDupNames, mapFvRn ) +import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad import HscTypes ( FixityEnv, FixItem(..), @@ -69,11 +69,13 @@ rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) rnSrcDecls (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_instds = inst_decls, + hs_derivds = deriv_decls, hs_fixds = fix_decls, hs_depds = deprec_decls, hs_fords = foreign_decls, hs_defds = default_decls, - hs_ruleds = rule_decls }) + hs_ruleds = rule_decls, + hs_docs = docs }) = do { -- Deal with deprecations (returns only the extra deprecations) deprecs <- rnSrcDeprecDecls deprec_decls ; @@ -99,28 +101,42 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, -- So we content ourselves with gathering uses only; that -- 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 ; - + + -- At this point, stop if we have found errors. Otherwise + -- the rnDocEntity stuff reports the errors again. + failIfErrsM ; + + traceRn (text "Start rnDocEntitys") ; + rn_docs <- mapM rnDocEntity docs ; + traceRn (text "finish rnDocEntitys") ; + 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_depds = [], hs_fords = rn_foreign_decls, hs_defds = rn_default_decls, - hs_ruleds = rn_rule_decls } ; + hs_ruleds = rn_rule_decls, + hs_docs = rn_docs } ; - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3, src_fvs4, src_fvs5] ; src_dus = bind_dus `plusDU` usesOnly other_fvs -- Note: src_dus will contain *uses* for locally-defined types @@ -135,6 +151,28 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, return (tcg_env `addTcgDUs` src_dus, rn_group) }}} +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 + return (DocCommentNext rn_doc) +rnDocDecl (DocCommentPrev doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentPrev rn_doc) +rnDocDecl (DocCommentNamed str doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentNamed str rn_doc) +rnDocDecl (DocGroup lev doc) = do + rn_doc <- rnHsDoc doc + return (DocGroup lev rn_doc) + rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name] rnTyClDecls tycl_decls = do (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls @@ -366,6 +404,20 @@ extendTyVarEnvForMethodBinds tyvars thing_inside thing_inside \end{code} +%********************************************************* +%* * +\subsection{Stand-alone deriving declarations} +%* * +%********************************************************* + +\begin{code} +rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) +rnSrcDerivDecl (DerivDecl ty n) + = do ty' <- rnLHsType (text "a deriving decl") ty + n' <- lookupLocatedOccRn n + let fvs = extractHsTyNames ty' `addOneFV` unLoc n' + return (DerivDecl ty' n', fvs) +\end{code} %********************************************************* %* * @@ -506,7 +558,9 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the -- data type is syntactically illegal bindTyVarsRn data_doc tyvars $ \ tyvars' -> - do { tycon' <- lookupLocatedTopBndrRn tycon + do { tycon' <- if isIdxTyDecl tydecl + then lookupLocatedOccRn tycon -- may be imported family + else lookupLocatedTopBndrRn tycon ; context' <- rnContext data_doc context ; typats' <- rnTyPats data_doc typatsMaybe ; (derivs', deriv_fvs) <- rn_derivs derivs @@ -519,11 +573,17 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, delFVs (map hsLTyVarName tyvars') $ extractHsCtxtTyNames context' `plusFV` plusFVs (map conDeclFVs condecls') `plusFV` - deriv_fvs) } + deriv_fvs `plusFV` + (if isIdxTyDecl tydecl + then unitFV (unLoc tycon') -- type instance => use + else emptyFVs)) + } | otherwise -- GADT = ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now - do { tycon' <- lookupLocatedTopBndrRn tycon + do { tycon' <- if isIdxTyDecl tydecl + then lookupLocatedOccRn tycon -- may be imported family + else lookupLocatedTopBndrRn tycon ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon) ; tyvars' <- bindTyVarsRn data_doc tyvars (\ tyvars' -> return tyvars') @@ -537,8 +597,12 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = Nothing, tcdKindSig = sig, tcdCons = condecls', tcdDerivs = derivs'}, - plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) } - + plusFVs (map conDeclFVs condecls') `plusFV` + deriv_fvs `plusFV` + (if isIdxTyDecl tydecl + then unitFV (unLoc tycon') -- type instance => use + else emptyFVs)) + } where is_vanilla = case condecls of -- Yuk [] -> True @@ -561,21 +625,28 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, rnTyClDecl (tydecl@TyFunction {}) = rnTySig tydecl bindTyVarsRn -rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, - tcdTyPats = typatsMaybe, tcdSynRhs = ty}) +rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, + tcdTyPats = typatsMaybe, tcdSynRhs = ty}) = bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - do { name' <- lookupLocatedTopBndrRn name + do { name' <- if isIdxTyDecl tydecl + then lookupLocatedOccRn name -- may be imported family + else lookupLocatedTopBndrRn name ; typats' <- rnTyPats syn_doc typatsMaybe ; (ty', fvs) <- rnHsTypeFVs syn_doc ty ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', tcdTyPats = typats', tcdSynRhs = ty'}, - delFVs (map hsLTyVarName tyvars') fvs) } + delFVs (map hsLTyVarName tyvars') $ + fvs `plusFV` + (if isIdxTyDecl tydecl + then unitFV (unLoc name') -- type instance => use + else emptyFVs)) + } where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds, tcdATs = ats}) + tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs}) = lookupLocatedTopBndrRn cname `thenM` \ cname' -> -- Tyvars scope over superclass context and method signatures @@ -584,8 +655,9 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, rnFds cls_doc fds `thenM` \ fds' -> rnATs ats `thenM` \ (ats', ats_fvs) -> renameSigs okClsDclSig sigs `thenM` \ sigs' -> - returnM (tyvars', context', fds', (ats', ats_fvs), sigs') - ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') -> + mapM rnDocEntity docs `thenM` \ docs' -> + returnM (tyvars', context', fds', (ats', ats_fvs), sigs', docs') + ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs', docs') -> -- Check for duplicates among the associated types let @@ -627,7 +699,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', - tcdMeths = mbinds', tcdATs = ats'}, + tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'}, delFVs (map hsLTyVarName tyvars') $ extractHsCtxtTyNames context' `plusFV` plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV` @@ -665,7 +737,7 @@ rnConDecls tycon condecls = mappM (wrapLocM rnConDecl) condecls rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) -rnConDecl (ConDecl name expl tvs cxt details res_ty) +rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc) = do { addLocM checkConName name ; new_name <- lookupLocatedTopBndrRn name @@ -684,12 +756,14 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty) Explicit -> tvs Implicit -> userHsTyVarBndrs implicit_tvs + ; mb_doc' <- rnMbLHsDoc mb_doc + ; bindTyVarsRn doc tvs' $ \new_tyvars -> do { new_context <- rnContext doc cxt ; new_details <- rnConDetails doc details ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty - ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }} - where + ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }} + where doc = text "In the definition of data constructor" <+> quotes (ppr name) get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys)) @@ -718,12 +792,14 @@ rnConDetails doc (RecCon fields) mappM (rnField doc) fields `thenM` \ new_fields -> returnM (RecCon new_fields) where - field_names = [fld | (fld, _) <- fields] + field_names = [ name | HsRecField name _ _ <- fields ] -rnField doc (name, ty) +-- Document comments are renamed to Nothing here +rnField doc (HsRecField name ty haddock_doc) = lookupLocatedTopBndrRn name `thenM` \ new_name -> rnLHsType doc ty `thenM` \ new_ty -> - returnM (new_name, new_ty) + rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc -> + returnM (HsRecField new_name new_ty new_haddock_doc) -- Rename kind signatures (signatures of indexed data types/newtypes and -- signatures of type functions) @@ -756,7 +832,8 @@ rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon, tcdTyPats = Nothing, tcdKindSig = sig, tcdCons = [], tcdDerivs = Nothing}, delFVs (map hsLTyVarName tyvars') $ - extractHsCtxtTyNames context') } } + extractHsCtxtTyNames context') + } } where rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars, @@ -767,7 +844,8 @@ rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars, ; tycon' <- lookupLocatedTopBndrRn tycon ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars', tcdIso = tcdIso tydecl, tcdKind = sig}, - emptyFVs) } } + emptyFVs) + } } ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon) needOneIdx = text "Kind signature requires at least one type index"