aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/HaddockHtml.hs17
-rw-r--r--src/HaddockTypes.hs13
-rw-r--r--src/HaddockUtil.hs26
-rw-r--r--src/Main.hs58
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?).
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-04 12:43:00 +0000