diff options
| -rw-r--r-- | src/HaddockHtml.hs | 71 | ||||
| -rw-r--r-- | src/HaddockRename.hs | 199 | ||||
| -rw-r--r-- | src/Main.hs | 199 |
3 files changed, 330 insertions, 139 deletions
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index ea6d3f73..277e45c4 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -11,7 +11,7 @@ import HaddockVersion import HaddockTypes import HsSyn -import Maybe ( fromJust, isNothing ) +import Maybe ( fromJust, isNothing, isJust ) import FiniteMap import List ( sortBy ) import Char ( toUpper, toLower ) @@ -283,24 +283,39 @@ ifaceToHtml mod iface | null exports = Html.emptyTable | otherwise = td << table ! [width "100%", cellpadding 0, cellspacing 15] << - (body1 </> body2) - where exports = iface_exports iface - doc_map = iface_name_docs iface + (description </> synopsis </> maybe_hr </> body) + where + exports = iface_exports iface + doc_map = iface_name_docs iface - body1 + has_doc (ExportDecl d) + | Just x <- declMainBinder d = isJust (lookupFM doc_map x) + has_doc _ = True + + no_doc_at_all = not (any has_doc exports) + + description | Just doc <- iface_doc iface = (tda [theclass "section1"] << toHtml "Description") </> docBox (markup htmlMarkup doc) | otherwise = Html.emptyTable - body2 = - (tda [theclass "section1"] << toHtml "Synopsis") </> - (tda [width "100%", theclass "synopsis"] << - table ! [width "100%", cellpadding 0, cellspacing 8, border 0] << - aboves (map (processExport doc_map True) exports)) </> - td << hr </> - aboves (map (processExport doc_map False) exports) + -- omit the synopsis if there are no documentation annotations at all + synopsis + | no_doc_at_all = Html.emptyTable + | otherwise + = (tda [theclass "section1"] << toHtml "Synopsis") </> + (tda [width "100%", theclass "synopsis"] << + table ! [width "100%", cellpadding 0, cellspacing 8, border 0] << + aboves (map (processExport doc_map True) exports)) + + maybe_hr + | not (no_doc_at_all), ExportGroup 1 _ <- head exports + = td << hr + | otherwise = Html.emptyTable + + body = aboves (map (processExport doc_map False) exports) processExport :: FiniteMap HsName Doc -> Bool -> ExportItem -> HtmlTable processExport doc_map summary (ExportGroup lev doc) @@ -349,11 +364,12 @@ doDecl doc_map summary decl = do_decl decl ++ map ppHsName args) <+> equals <+> ppHsType ty) do_decl (HsNewTypeDecl loc ctx nm args con drv) - = ppHsDataDecl doc_map summary (HsDataDecl loc ctx nm args [con] drv) + = ppHsDataDecl doc_map summary True{-is newtype-} + (HsDataDecl loc ctx nm args [con] drv) -- print it as a single-constructor datatype do_decl decl@(HsDataDecl loc ctx nm args cons drv) - = ppHsDataDecl doc_map summary decl + = ppHsDataDecl doc_map summary False{-not newtype-} decl do_decl decl@(HsClassDecl _ _ _) = ppHsClassDecl doc_map summary decl @@ -377,15 +393,17 @@ keepDecl _ = False -- ----------------------------------------------------------------------------- -- Data & newtype declarations -ppShortDataDecl doc_map summary (HsDataDecl loc ctx nm args [con] drv) = +ppShortDataDecl doc_map summary is_newty + (HsDataDecl loc ctx nm args [con] drv) = declBox ( -- single constructor special case - ppHsDataHeader summary nm args + ppHsDataHeader summary is_newty nm args <+> equals <+> ppShortConstr summary con ) -ppShortDataDecl doc_map summary (HsDataDecl loc ctx nm args cons drv) = +ppShortDataDecl doc_map summary is_newty + (HsDataDecl loc ctx nm args cons drv) = declBox << vanillaTable << ( aboves ( - (declBox (ppHsDataHeader summary nm args) : + (declBox (ppHsDataHeader summary is_newty nm args) : zipWith do_constr ('=':repeat '|') cons ) ) @@ -395,20 +413,20 @@ ppShortDataDecl doc_map summary (HsDataDecl loc ctx nm args cons drv) = -- First, the abstract case: -ppHsDataDecl doc_map summary (HsDataDecl loc ctx nm args [] drv) = +ppHsDataDecl doc_map summary is_newty (HsDataDecl loc ctx nm args [] drv) = declWithDoc summary (lookupFM doc_map nm) - (ppHsDataHeader summary nm args) + (ppHsDataHeader summary is_newty nm args) -- The rest of the cases: -ppHsDataDecl doc_map summary decl@(HsDataDecl loc ctx nm args cons drv) +ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv) | summary || (isNothing doc && all constr_has_no_doc cons) - = ppShortDataDecl doc_map summary decl + = ppShortDataDecl doc_map summary is_newty decl | otherwise = td << vanillaTable << (header </> datadoc </> constrs) where - header = declBox (ppHsDataHeader False nm args) + header = declBox (ppHsDataHeader False is_newty nm args) datadoc = docBox (markup htmlMarkup (fromJust doc)) constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors" @@ -428,6 +446,8 @@ ppHsDataDecl doc_map summary decl@(HsDataDecl loc ctx nm args cons drv) constr_has_no_doc (HsConDecl _ nm _ _) = isNothing (lookupFM doc_map nm) + constr_has_no_doc (HsRecDecl _ nm _ _) + = isNothing (lookupFM doc_map nm) ppShortConstr :: Bool -> HsConDecl -> Html @@ -475,8 +495,9 @@ ppFullField _ _ = error "ppFullField" expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] -ppHsDataHeader summary nm args = - keyword "data" <+> ppHsBinder summary nm <+> hsep (map ppHsName args) +ppHsDataHeader summary is_newty nm args = + (if is_newty then keyword "newtype" else keyword "data") <+> + ppHsBinder summary nm <+> hsep (map ppHsName args) ppHsBangType :: HsBangType -> Html ppHsBangType (HsBangedTy ty) = char '!' +++ ppHsAType ty diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs new file mode 100644 index 00000000..4c5a631b --- /dev/null +++ b/src/HaddockRename.hs @@ -0,0 +1,199 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2002 +-- + +module HaddockRename ( + RnM, runRn, runRnFM, -- the monad (instance of Monad) + + renameExportList, + renameDecl, + renameExportItems, + renameDoc, resolveDoc, + ) where + +import HaddockTypes +import HsSyn + +import FiniteMap +import Monad + +-- ----------------------------------------------------------------------------- +-- Monad for renaming + +-- The monad does two things for us: it passes around the environment for +-- renaming, and it returns a list of names which couldn't be found in +-- the environment. + +newtype GenRnM n a = RnM {unRn :: (n -> Maybe HsQName) -> (a,[n])} + +type RnM a = GenRnM HsQName a + +instance Monad (GenRnM n) where + (>>=) = thenRn + return = returnRn + +returnRn a = RnM (\lkp -> (a,[])) +m `thenRn` k = RnM (\lkp -> case unRn m lkp of + (a,out1) -> case unRn (k a) lkp of + (b,out2) -> (b,out1++out2)) + +getLookupRn = RnM (\lkp -> (lkp,[])) +outRn name = RnM (\lkp -> ((),[name])) + +lookupRn :: (HsQName -> a) -> HsQName -> RnM a +lookupRn and_then name = do + lkp <- getLookupRn + case lkp name of + Nothing -> do outRn name; return (and_then name) + Just maps_to -> return (and_then maps_to) + +runRnFM :: FiniteMap HsQName HsQName -> RnM a -> (a,[HsQName]) +runRnFM env rn = unRn rn (lookupFM env) + +runRn :: (n -> Maybe HsQName) -> GenRnM n a -> (a,[n]) +runRn lkp rn = unRn rn lkp + +-- ----------------------------------------------------------------------------- +-- Renaming source code & documentation + +renameExportList :: [HsExportSpec] -> RnM [HsExportSpec] +renameExportList spec = mapM renameExport spec + where + renameExport (HsEVar x) = lookupRn HsEVar x + renameExport (HsEAbs x) = lookupRn HsEAbs x + renameExport (HsEThingAll x) = lookupRn HsEThingAll x + renameExport (HsEThingWith x cs) + = do cs' <- mapM (lookupRn id) cs + lookupRn (\x' -> HsEThingWith x' cs') x + renameExport (HsEModuleContents m) = return (HsEModuleContents m) + renameExport (HsEGroup lev str) = return (HsEGroup lev str) + +renameDecl :: HsDecl -> RnM HsDecl +renameDecl decl + = case decl of + HsTypeDecl loc t args ty -> do + ty <- renameType ty + return (HsTypeDecl loc t args ty) + HsDataDecl loc ctx t args cons drv -> do + cons <- mapM renameConDecl cons + return (HsDataDecl loc ctx t args cons drv) + HsNewTypeDecl loc ctx t args con drv -> do + con <- renameConDecl con + return (HsNewTypeDecl loc ctx t args con drv) + HsClassDecl loc qt decls -> do + qt <- renameClassHead qt + decls <- mapM renameDecl decls + return (HsClassDecl loc qt decls) + HsTypeSig loc fs qt -> do + qt <- renameType qt + return (HsTypeSig loc fs qt) + HsForeignImport loc cc safe ent n ty -> do + ty <- renameType ty + return (HsForeignImport loc cc safe ent n ty) + _ -> + return decl + +renameClassHead (HsForAllType tvs ctx ty) = do + ctx <- mapM renamePred ctx + return (HsForAllType tvs ctx ty) +renameClassHead ty = do + return ty + +renameConDecl (HsConDecl loc nm tys maybe_doc) = do + tys <- mapM renameBangTy tys + return (HsConDecl loc nm tys maybe_doc) +renameConDecl (HsRecDecl loc nm fields maybe_doc) = do + fields <- mapM renameField fields + return (HsRecDecl loc nm fields maybe_doc) + +renameField (HsFieldDecl ns ty doc) = do + ty <- renameBangTy ty + return (HsFieldDecl ns ty doc) + +renameBangTy (HsBangedTy ty) = HsBangedTy `liftM` renameType ty +renameBangTy (HsUnBangedTy ty) = HsUnBangedTy `liftM` renameType ty + +renamePred (c,tys) = do + tys <- mapM renameType tys + lookupRn (\c' -> (c',tys)) c + +renameType (HsForAllType tvs ctx ty) = do + ctx <- mapM renamePred ctx + ty <- renameType ty + return (HsForAllType tvs ctx ty) +renameType (HsTyFun arg res) = do + arg <- renameType arg + res <- renameType res + return (HsTyFun arg res) +renameType (HsTyTuple b tys) = do + tys <- mapM renameType tys + return (HsTyTuple b tys) +renameType (HsTyApp ty arg) = do + ty <- renameType ty + arg <- renameType arg + return (HsTyApp ty arg) +renameType (HsTyVar nm) = + return (HsTyVar nm) +renameType (HsTyCon nm) = + lookupRn HsTyCon nm + +-- ----------------------------------------------------------------------------- +-- Renaming documentation + +-- Renaming documentation is done by "marking it up" from ordinary Doc +-- into (Rn Doc), which can then be renamed with runRn. +markupRename :: DocMarkup HsQName (RnM Doc) +markupRename = Markup { + markupEmpty = return DocEmpty, + markupString = return . DocString, + markupParagraph = liftM DocParagraph, + markupAppend = liftM2 DocAppend, + markupIdentifier = lookupRn DocIdentifier, + markupModule = return . DocModule, + markupEmphasis = liftM DocEmphasis, + markupMonospaced = liftM DocMonospaced, + markupUnorderedList = liftM DocUnorderedList . sequence, + markupOrderedList = liftM DocOrderedList . sequence, + markupCodeBlock = liftM DocCodeBlock, + markupURL = return . DocURL + } + +renameDoc = markup markupRename + +markupResolveDoc :: DocMarkup String (GenRnM String Doc) +markupResolveDoc = Markup { + markupEmpty = return DocEmpty, + markupString = return . DocString, + markupParagraph = liftM DocParagraph, + markupAppend = liftM2 DocAppend, + markupIdentifier = lookupIdString, + markupModule = return . DocModule, + markupEmphasis = liftM DocEmphasis, + markupMonospaced = liftM DocMonospaced, + markupUnorderedList = liftM DocUnorderedList . sequence, + markupOrderedList = liftM DocOrderedList . sequence, + markupCodeBlock = liftM DocCodeBlock, + markupURL = return . DocURL + } + +resolveDoc = markup markupResolveDoc + +lookupIdString :: String -> GenRnM String Doc +lookupIdString str = do + fn <- getLookupRn + case fn str of + Nothing -> return (DocString str) + Just n -> return (DocIdentifier n) + +-- ----------------------------------------------------------------------------- + +renameExportItems items = mapM rn items + where + rn (ExportGroup lev doc) + = do doc <- renameDoc doc + return (ExportGroup lev doc) + rn (ExportDecl decl) + = do decl <- renameDecl decl + return (ExportDecl decl) diff --git a/src/Main.hs b/src/Main.hs index 218528bc..f57d5dd6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,6 +6,7 @@ module Main (main) where +import HaddockRename import HaddockParse import HaddockLex import HaddockDB @@ -22,6 +23,7 @@ import FiniteMap --import Pretty +import List ( nub ) import Monad ( when ) import Char ( isSpace ) import IO @@ -72,7 +74,8 @@ run flags files = do let ifaces = [ mkInterface module_map file parsed | (file,parsed) <- zip files parsed_mods ] - module_map = listToFM ifaces + mod_ifaces = [ (m,i) | (m,i,_,_) <- ifaces ] + module_map = listToFM mod_ifaces let title = case [str | Flag_Heading str <- flags] of [] -> "" @@ -82,11 +85,14 @@ run flags files = do [] -> Nothing (t:ts) -> Just t + sequence [ reportMissingNames m ns_docs ns_decls + | (m, _, ns_docs, ns_decls) <- ifaces ] + when (Flag_DocBook `elem` flags) $ - putStr (ppDocBook ifaces) + putStr (ppDocBook mod_ifaces) when (Flag_Html `elem` flags) $ - ppHtml title source_url ifaces + ppHtml title source_url mod_ifaces parse_file file = do @@ -100,10 +106,23 @@ parse_file file = do exitWith (ExitFailure 1) ) +reportMissingNames m [] [] = return () +reportMissingNames (Module m) ns_docs ns_decls = do + hPutStrLn stderr ("Warning: in module " ++ m ++ + ", the following names could not be resolved:") + let name_strings = nub (map show ns_decls ++ ns_docs) + hPutStrLn stderr (" " ++ concat (map (' ':) name_strings)) + ----------------------------------------------------------------------------- -- Figuring out the definitions that are exported from a module -mkInterface :: ModuleMap -> FilePath -> HsModule -> (Module,Interface) +mkInterface :: ModuleMap -> FilePath -> HsModule + -> (Module, -- the module name + Interface, -- its "interface" + [String], -- a list of names we couldn't resolve in the docs + [HsQName] -- a list of names we couldn't resolve in the decls + ) + mkInterface mod_map filename (HsModule mod exps imps decls maybe_doc) = (mod, Interface { iface_filename = filename, @@ -115,10 +134,18 @@ mkInterface mod_map filename (HsModule mod exps imps decls maybe_doc) iface_maintainer = "libraries@haskell.org", iface_stability = "stable", iface_name_docs = doc_map, - iface_doc = fmap (formatDocString (lookupForDoc import_env)) - maybe_doc - } ) + iface_doc = module_doc + }, + missing_names_doc1 ++ missing_names_doc2, + missing_names1 ++ missing_names2 --ignore missing_names3 for now, + ) where + (module_doc, missing_names_doc1) = + case maybe_doc of + Nothing -> (Nothing, []) + Just doc -> (Just doc', ns) + where (doc',ns) = formatDocString (lookupForDoc import_env) doc + locally_defined_names = collectNames decls qual_local_names = map (Qual mod) locally_defined_names @@ -136,8 +163,11 @@ mkInterface mod_map filename (HsModule mod exps imps decls maybe_doc) import_env = foldr plusFM local_env ext_import_envs -- convert names in source code to original, fully qualified, names - orig_exports = fmap (renameExportList orig_env) exps - orig_decls = map (renameDecl orig_env) decls + (orig_exports, missing_names1) + = runRnFM orig_env (mapMaybeM renameExportList exps) + + (orig_decls, missing_names2) + = runRnFM orig_env (mapM renameDecl decls) orig_decl_map :: FiniteMap HsName HsDecl orig_decl_map = listToFM [ (n,d) | d <- orig_decls, n <- declBinders d ] @@ -150,15 +180,24 @@ mkInterface mod_map filename (HsModule mod exps imps decls maybe_doc) final_decls = concat (map expandDecl orig_decls) -- match documentation to names, and resolve identifiers in the documentation - local_docs :: [(HsName,Doc)] - local_docs = [ (n, formatDocString (lookupForDoc import_env) doc) - | (n, doc) <- collectDoc final_decls - ] + local_docstrings :: [(HsName,DocString)] + local_docstrings = collectDoc final_decls + + local_docs_formatted :: [(HsName,(Doc,[String]))] + local_docs_formatted = + [ (n, formatDocString (lookupForDoc orig_env) doc) + | (n, doc) <- local_docstrings ] + + local_docs :: [(HsName,Doc)] -- with *original* names + local_docs = [ (n,doc) | (n,(doc,_)) <- local_docs_formatted ] + + -- collect the list of names which we couldn't resolve in the documentation + missing_names_doc2 = concat [ ns | (n,(doc,ns)) <- local_docs_formatted ] -- get the documentation associated with entities exported from this module -- ToDo: we should really store the documentation in both orig and imported -- forms, like the export items. - doc_map :: FiniteMap HsName Doc + doc_map :: FiniteMap HsName Doc -- with *imported* names doc_map = listToFM [ (nameOfQName n, doc) | n <- exported_names, @@ -168,12 +207,13 @@ mkInterface mod_map filename (HsModule mod exps imps decls maybe_doc) decl_map = listToFM [ (n,d) | d <- final_decls, n <- declBinders d ] -- make the "export items", which will be converted into docs later - orig_export_list = mkExportItems mod_map mod import_env + orig_export_list = mkExportItems mod_map mod orig_env decl_map final_decls orig_exports -- rename names in the exported declarations to point to things that -- are closer, or maybe even exported by, the current module. - renamed_export_list = renameExportItems import_env orig_export_list + (renamed_export_list, missing_names3) + = runRnFM import_env (renameExportItems orig_export_list) name_env = listToFM [ (nameOfQName n, n) | n <- exported_names ] @@ -187,12 +227,16 @@ lookupDoc mod_map this_mod local_doc env name = case name of UnQual n -> Nothing Qual mod n - | mod == this_mod -> fmap (renameDoc env) (lookup n local_doc) + | mod == this_mod -> + fst (runRnFM env (mapMaybeM renameDoc (lookup n local_doc))) + -- ToDo: report missing names | otherwise -> case lookupFM mod_map mod of Nothing -> Nothing - Just iface -> fmap (renameDoc env) - (lookupFM (iface_name_docs iface) n) + Just iface -> + fst (runRnFM env (mapMaybeM renameDoc + (lookupFM (iface_name_docs iface) n))) + -- ToDo: report missing names -- ----------------------------------------------------------------------------- -- Build the list of items that will become the documentation, from the @@ -230,7 +274,9 @@ mkExportItems mod_map mod env decl_map decls (Just specs) = [ ExportDecl (restrictTo (map nameOfQName cs) decl) ] lookupExport (HsEModuleContents m) = fullContentsOf m lookupExport (HsEGroup lev str) - = [ ExportGroup lev (formatDocHeading (lookupForDoc env) str) ] + = [ ExportGroup lev doc ] + where (doc, _names) = formatDocHeading (lookupForDoc env) str + -- ToDo: report the unresolved names lookupExport _ = [] -- didn't find it? fullContentsOf m @@ -242,7 +288,7 @@ mkExportItems mod_map mod env decl_map decls (Just specs) findDecl :: HsQName -> Maybe HsDecl findDecl (UnQual n) - = trace ("Warning(mkExportItems): UnQual! " ++ show n) $ Nothing + = Nothing -- must be a name we couldn't resolve findDecl (Qual m n) | m == mod = lookupFM decl_map n | otherwise = @@ -251,18 +297,14 @@ mkExportItems mod_map mod env decl_map decls (Just specs) Nothing -> trace ("Warning: module not found: " ++ show m) Nothing -renameExportItems env items = map rn items - where - rn (ExportGroup lev doc) - = ExportGroup lev (renameDoc env doc) - rn (ExportDecl decl) - = ExportDecl (renameDecl env decl) - fullContentsOfThisModule decls env = [ mkExportItem decl | decl <- decls, keepDecl decl ] where mkExportItem (HsDocGroup lev str) = - ExportGroup lev (formatDocHeading (lookupForDoc env) str) - mkExportItem decl = ExportDecl (renameDecl env decl) + ExportGroup lev doc + where + (doc, _names) = formatDocHeading (lookupForDoc env) str + -- ToDo: report the unresolved names + mkExportItem decl = ExportDecl decl keepDecl HsTypeSig{} = True @@ -349,78 +391,6 @@ expandDecl (HsClassDecl loc ty decls) = [ HsClassDecl loc ty (concat (map expandDecl decls)) ] expandDecl d = [ d ] --- ----------------------------------------------------------------------------- --- Renaming source code - -renameExportList :: FiniteMap HsQName HsQName -> [HsExportSpec] - -> [HsExportSpec] -renameExportList env spec = map renameExport spec - where - renameExport (HsEVar x) = HsEVar (rnLookupName env x) - renameExport (HsEAbs x) = HsEAbs (rnLookupName env x) - renameExport (HsEThingAll x) = HsEThingAll (rnLookupName env x) - renameExport (HsEThingWith x cs) - = HsEThingWith (rnLookupName env x) (map (rnLookupName env) cs) - renameExport (HsEModuleContents m) = HsEModuleContents m - renameExport (HsEGroup lev str) = HsEGroup lev str - -renameDecl :: FiniteMap HsQName HsQName -> HsDecl -> HsDecl -renameDecl scope decl - = case decl of - HsTypeDecl loc t args ty -> - HsTypeDecl loc t args (renameType scope ty) - HsDataDecl loc ctx t args cons drv -> - HsDataDecl loc ctx t args (map (renameConDecl scope) cons) drv - HsNewTypeDecl loc ctx t args con drv -> - HsNewTypeDecl loc ctx t args (renameConDecl scope con) drv - HsClassDecl loc qt decls -> - HsClassDecl loc (renameClassHead scope qt) - (map (renameDecl scope) decls) - HsTypeSig loc fs qt -> - HsTypeSig loc fs (renameType scope qt) - HsForeignImport loc cc safe ent n ty -> - HsForeignImport loc cc safe ent n (renameType scope ty) - _ -> decl - -renameClassHead s (HsForAllType tvs ctx ty) - = HsForAllType tvs (map (renamePred s) ctx) ty -renameClassHead s ty - = ty - -renameConDecl s (HsConDecl loc nm tys maybe_doc) - = HsConDecl loc nm (map (renameBangTy s) tys) maybe_doc -renameConDecl s (HsRecDecl loc nm fields maybe_doc) - = HsRecDecl loc nm (map (renameField s) fields) maybe_doc - -renameField s (HsFieldDecl ns ty doc) = HsFieldDecl ns (renameBangTy s ty) doc - -renameBangTy s (HsBangedTy ty) = HsBangedTy (renameType s ty) -renameBangTy s (HsUnBangedTy ty) = HsUnBangedTy (renameType s ty) - -renamePred s (c,tys) = (rnLookupName s c, map (renameType s) tys) - -renameType s (HsForAllType tvs ctx ty) - = HsForAllType tvs (map (renamePred s) ctx) (renameType s ty) -renameType s (HsTyFun arg res) - = HsTyFun (renameType s arg) (renameType s res) -renameType s (HsTyTuple b tys) - = HsTyTuple b (map (renameType s) tys) -renameType s (HsTyApp ty arg) - = HsTyApp (renameType s ty) (renameType s arg) -renameType s (HsTyVar nm) - = HsTyVar nm -renameType s (HsTyCon nm) - = HsTyCon (rnLookupName s nm) - -rnLookupName :: FiniteMap HsQName HsQName -> HsQName -> HsQName -rnLookupName s nm - = case lookupFM s nm of - Just n -> n - Nothing -> trace ("Warning: unknown name: " ++ show nm) nm - -renameDoc env = markup (mapIdent ident) - where ident id = DocIdentifier (rnLookupName env id) - ----------------------------------------------------------------------------- -- Collecting documentation and associating it with declarations @@ -486,25 +456,21 @@ docsFromField (HsFieldDecl nms ty Nothing) rest -- description to this function to get the marked-up text. -- this one formats a heading -formatDocHeading :: (String -> Maybe HsQName) -> DocString -> Doc +formatDocHeading :: (String -> Maybe HsQName) -> DocString + -> (Doc,[String]) formatDocHeading lookup string = format parseString lookup string -- this one formats a sequence of paragraphs -formatDocString :: (String -> Maybe HsQName) -> DocString -> Doc +formatDocString :: (String -> Maybe HsQName) -> DocString + -> (Doc,[String]) formatDocString lookup string = format parseParas lookup string format :: ([Token] -> ParsedDoc) -> (String -> Maybe HsQName) -> DocString - -> Doc -format parse lookup string = markup (mapIdent ident) parsed_doc - where - --parsed_doc :: DocMarkup String a -> a - parsed_doc = parse (tokenise string) - - ident str = case lookup str of - Just n -> DocIdentifier n - Nothing -> DocString str + -> (Doc, [String]) +format parse lookup string + = runRn lookup $ resolveDoc $ parse $ tokenise $ string -- --------------------------------------------------------------------------- -- Looking up names in documentation @@ -513,7 +479,7 @@ lookupForDoc :: FiniteMap HsQName HsQName -> (String -> Maybe HsQName) lookupForDoc fm str = case [ n | Just n <- map (lookupFM fm) (strToHsQNames str) ] of (n:_) -> Just n - [] -> trace ("Warning: unknown name: " ++ str) Nothing + [] -> Nothing strToHsQNames :: String -> [ HsQName ] strToHsQNames str @@ -545,3 +511,8 @@ strToHsQNames str mapSnd f [] = [] mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs + +mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) +mapMaybeM f Nothing = return Nothing +mapMaybeM f (Just a) = f a >>= return . Just + |