From 995d3f9ed418352cb8e341630e7c7655080c1612 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 24 Apr 2002 15:14:12 +0000 Subject: [haddock @ 2002-04-24 15:14:11 by simonmar] Grok the kind of module headers we use in fptools/libraries, and pass the "portability", "stability", and "maintainer" strings through into the generated HTML. If the module header doesn't match the pattern, then we don't include the info in the HTML. --- src/HaddockHtml.hs | 17 ++++++++++------ src/HaddockTypes.hs | 13 +++++++----- src/HaddockUtil.hs | 26 ++++++++++++++++++++++-- src/Main.hs | 58 ++++++++++++++++++++++++++++++++--------------------- 4 files changed, 78 insertions(+), 36 deletions(-) diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 8e02e535..2b2c4f3e 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -108,23 +108,28 @@ pageHeader mod iface title source_url = tda [theclass "modulebar"] << (vanillaTable << ( (td << font ! [size "6"] << toHtml mod) <-> - (tda [align "right"] << + moduleInfo iface + ) + ) + +moduleInfo iface + | Nothing <- iface_info iface = Html.emptyTable + | Just info <- iface_info iface = + tda [align "right"] << (table ! [width "300", border 0, cellspacing 0, cellpadding 0] << ( (tda [width "50%"] << font ! [color "#ffffff"] << bold << toHtml "Portability") <-> (tda [width "50%"] << font ! [color "#ffffff"] << - toHtml (iface_portability iface)) + toHtml (portability info)) (tda [width "50%"] << font ! [color "#ffffff"] << bold << toHtml "Stability") <-> (tda [width "50%"] << font ! [color "#ffffff"] << - toHtml (iface_stability iface)) + toHtml (stability info)) (tda [width "50%"] << font ! [color "#ffffff"] << bold << toHtml "Maintainer") <-> (tda [width "50%"] << font ! [color "#ffffff"] << - toHtml (iface_maintainer iface)) + toHtml (maintainer info)) )) - )) - ) -- --------------------------------------------------------------------------- -- Generate the module contents diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs index c157a753..21ee513c 100644 --- a/src/HaddockTypes.hs +++ b/src/HaddockTypes.hs @@ -6,7 +6,7 @@ module HaddockTypes ( -- * Module interfaces - NameEnv, Interface(..), ExportItem(..), ModuleMap, + NameEnv, Interface(..), ModuleInfo(..), ExportItem(..), ModuleMap, -- * User documentation strings DocString, GenDoc(..), Doc, ParsedDoc, DocMarkup(..), @@ -49,15 +49,18 @@ data Interface -- Includes not just "main names" but names of constructors, -- record fields, etc. - iface_portability :: String, - iface_stability :: String, - iface_maintainer :: String, + iface_info :: Maybe ModuleInfo, -- ^ information from the module header - iface_doc :: Maybe Doc + iface_doc :: Maybe Doc -- ^ documentation from the module header } +data ModuleInfo = ModuleInfo + { portability :: String, + stability :: String, + maintainer :: String } + type DocString = String data ExportItem diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index 51c31438..8173cedf 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -13,12 +13,18 @@ module HaddockUtil ( -- * Filename utilities basename, dirname, splitFilename3, - isPathSeparator, pathSeparator + isPathSeparator, pathSeparator, + + -- * Miscellaneous utilities + die, dieMsg, mapSnd, mapMaybeM ) where import HsSyn -import List (intersect) + +import List ( intersect ) +import IO ( hPutStr, stderr ) +import System -- ----------------------------------------------------------------------------- -- Some Utilities @@ -136,3 +142,19 @@ isPathSeparator ch = #else ch == '/' #endif + +----------------------------------------------------------------------------- +-- misc. + +die :: String -> IO a +die s = hPutStr stderr s >> exitWith (ExitFailure 1) + +dieMsg :: String -> IO a +dieMsg s = getProgName >>= \prog -> die (prog ++ ": " ++ s) + +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 diff --git a/src/Main.hs b/src/Main.hs index 7be91b9a..ee6c0d3b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -24,6 +24,7 @@ import FiniteMap --import Pretty +import RegexString import List ( nub ) import Monad ( when ) import Char ( isSpace ) @@ -144,9 +145,7 @@ mkInterface mod_map filename (HsModule mod exps imps decls maybe_doc) iface_exports = renamed_export_list, iface_orig_exports = orig_export_list, iface_decls = decl_map, - iface_portability = "portable", - iface_maintainer = "libraries@haskell.org", - iface_stability = "stable", + iface_info = maybe_info, iface_name_docs = doc_map, iface_doc = module_doc }, @@ -154,11 +153,13 @@ mkInterface mod_map filename (HsModule mod exps imps decls maybe_doc) missing_names1 ++ missing_names2 --ignore missing_names3 for now, ) where - (module_doc, missing_names_doc1) = + (module_doc, maybe_info, missing_names_doc1) = case maybe_doc of - Nothing -> (Nothing, []) - Just doc -> (Just doc', ns) - where (doc',ns) = formatDocString (lookupForDoc import_env) doc + Nothing -> (Nothing, Nothing, []) + Just doc -> (Just doc2, maybe_info, ns) + where + (doc1, maybe_info) = parseModuleHeader doc + (doc2,ns) = formatDocString (lookupForDoc import_env) doc1 locally_defined_names = collectNames decls @@ -524,19 +525,30 @@ strToHsQNames str Qual (Module mod) (HsVarName (HsSymbol str)) ] other -> [] ------------------------------------------------------------------------------ --- misc. - -die :: String -> IO a -die s = hPutStr stderr s >> exitWith (ExitFailure 1) - -dieMsg :: String -> IO a -dieMsg s = getProgName >>= \prog -> die (prog ++ ": " ++ s) - -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 - +-- ----------------------------------------------------------------------------- +-- Parsing module headers + +parseModuleHeader :: String -> (String, Maybe ModuleInfo) +parseModuleHeader str = + case matchRegexAll moduleHeaderRE str of + Just (before, match, after, _, (_:_:_:s1:s2:s3:_)) -> + (after, Just (ModuleInfo { + portability = s3, + stability = s2, + maintainer = s1 })) + _other -> (str, Nothing) + +moduleHeaderRE = mkRegexWithOpts + "^([ \t\n]*Module[ \t]*:.*\n)?\ + \([ \t\n]*Copyright[ \t]*:.*\n)?\ + \([ \t\n]*License[ \t]*:.*\n)?\ + \[ \t\n]*Maintainer[ \t]*:(.*)\n\ + \[ \t\n]*Stability[ \t]*:(.*)\n\ + \[ \t\n]*Portability[ \t]*:([^\n]*)\n" + True -- match "\n" with "." + False -- not case sensitive + -- All fields except the last (Portability) may be multi-line. + -- This is so that the portability field doesn't swallow up the + -- rest of the module documentation - we might want to revist + -- this at some point (perhaps have a separator between the + -- portability field and the module documentation?). -- cgit v1.2.3