X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=670cfc809296801b31629e8afc7cbdc091d7517f;hp=8f4c1d337e3efef48d0b837d541331a838512820;hb=190f24892156953d73b55401d0467a6f1a88ce5d;hpb=a1899edb87b3192f192980f392680df05f50f104 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 8f4c1d3..670cfc8 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 ; @@ -103,24 +105,30 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ; (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 <- mapM rnDocEntity docs ; + 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 +143,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 +396,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} %********************************************************* %* * @@ -594,7 +638,7 @@ rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, 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 @@ -603,8 +647,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 @@ -646,7 +691,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` @@ -684,7 +729,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 @@ -703,12 +748,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)) @@ -737,12 +784,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)