aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Binary.hs8
-rw-r--r--src/HaddockHH.hs4
-rw-r--r--src/HaddockHtml.hs47
-rw-r--r--src/HaddockModuleTree.hs31
-rw-r--r--src/HaddockTypes.hs2
-rw-r--r--src/HaddockUtil.hs232
-rw-r--r--src/HsParser.ly24
-rw-r--r--src/HsSyn.lhs24
-rw-r--r--src/Main.hs143
9 files changed, 384 insertions, 131 deletions
diff --git a/src/Binary.hs b/src/Binary.hs
index 092d29f2..eb7b9929 100644
--- a/src/Binary.hs
+++ b/src/Binary.hs
@@ -51,11 +51,11 @@ module Binary
-- putBinFileWithDict, -- :: Binary a => FilePath -> Module -> a -> IO ()
-- re-export for the benefit of other modules.
- openBinaryFile
+ openBinaryFile,
- FormatVersion,
- nullFormatVersion,
- mkFormatVersion,
+ FormatVersion,
+ nullFormatVersion,
+ mkFormatVersion,
) where
#include "MachDeps.h"
diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs
index e0e9a97a..8ad4dfe2 100644
--- a/src/HaddockHH.hs
+++ b/src/HaddockHH.hs
@@ -57,9 +57,9 @@ ppHHContents odir doctitle maybe_package tree = do
fn _ [] = error "HaddockHH.ppHHContents.fn: no module trees given"
ppNode :: [String] -> ModuleTree -> Doc
- ppNode ss (Node s leaf _pkg []) =
+ ppNode ss (Node s leaf _pkg _ []) =
ppLeaf s ss leaf
- ppNode ss (Node s leaf _pkg ts) =
+ ppNode ss (Node s leaf _pkg _ ts) =
ppLeaf s ss leaf $$
text "<UL>" $+$
nest 4 (fn (s:ss) ts) $+$
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 96d8d816..17cab01e 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -20,7 +20,7 @@ import HaddockHH2
import HaddockDevHelp
import HsSyn
-import Maybe ( fromJust, isJust )
+import Maybe ( fromJust, isJust, mapMaybe )
import List ( sortBy )
import Char ( isUpper, toUpper )
import Monad ( when, unless )
@@ -194,17 +194,26 @@ pageHeader mdl iface doctitle source_url maybe_contents_url maybe_index_url =
moduleInfo :: Interface -> HtmlTable
moduleInfo iface =
- case iface_info iface of
- Nothing -> Html.emptyTable
- Just info ->
- tda [align "right"] << narrowTable << (
- (tda [theclass "infohead"] << toHtml "Portability") <->
- (tda [theclass "infoval"] << toHtml (portability info)) </>
- (tda [theclass "infohead"] << toHtml "Stability") <->
- (tda [theclass "infoval"] << toHtml (stability info)) </>
- (tda [theclass "infohead"] << toHtml "Maintainer") <->
- (tda [theclass "infoval"] << toHtml (maintainer info))
- )
+ let
+ info = iface_info iface
+
+ doOneEntry :: (String,ModuleInfo -> Maybe String) -> Maybe HtmlTable
+ doOneEntry (fieldName,field) = case field info of
+ Nothing -> Nothing
+ Just fieldValue ->
+ Just ((tda [theclass "infohead"] << toHtml fieldName)
+ <-> (tda [theclass "infoval"]) << toHtml fieldValue)
+
+ entries :: [HtmlTable]
+ entries = mapMaybe doOneEntry [
+ ("Portability",portability),
+ ("Stability",stability),
+ ("Maintainer",maintainer)
+ ]
+ in
+ case entries of
+ [] -> Html.emptyTable
+ _ -> tda [align "right"] << narrowTable << (foldl1 (</>) entries)
-- ---------------------------------------------------------------------------
-- Generate the module contents
@@ -219,7 +228,8 @@ ppHtmlContents
-> IO ()
ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url
mdls prologue = do
- let tree = mkModuleTree [(mod,iface_package iface) | (mod,iface) <- mdls]
+ let tree = mkModuleTree
+ [(mod,iface_package iface,toDescription iface) | (mod,iface) <- mdls]
html =
header
(documentCharacterEncoding +++
@@ -262,13 +272,18 @@ ppModuleTree _ ts =
(htmlTable,_) = genTable emptyTable 0 ts
mkNode :: [String] -> ModuleTree -> Int -> (HtmlTable,Int)
-mkNode ss (Node s leaf pkg ts) id = htmlNode
+mkNode ss (Node s leaf pkg short ts) id = htmlNode
where
htmlNode = case ts of
- [] -> ( pad_td (Just 1.25) << htmlModule <-> htmlPkg,id)
- _ -> ((pad_td Nothing<< (collapsebutton id_s +++ htmlModule) <-> htmlPkg) </>
+ [] -> ( pad_td (Just 1.25) << htmlModule <-> shortDescr <-> htmlPkg,id)
+ _ -> ((pad_td Nothing<< (collapsebutton id_s +++ htmlModule) <-> shortDescr <-> htmlPkg) </>
(pad_td (Just 2) << sub_tree), id')
+ shortDescr :: HtmlTable
+ shortDescr = case short of
+ Nothing -> td empty
+ Just doc -> tda [theclass "rdoc"] (docToHtml doc)
+
htmlModule
| leaf = ppHsModule mdl
| otherwise = toHtml s
diff --git a/src/HaddockModuleTree.hs b/src/HaddockModuleTree.hs
index f052bd69..bd877bf4 100644
--- a/src/HaddockModuleTree.hs
+++ b/src/HaddockModuleTree.hs
@@ -2,28 +2,29 @@ module HaddockModuleTree(ModuleTree(..), mkModuleTree) where
import HsSyn
-data ModuleTree = Node String Bool (Maybe String) [ModuleTree]
+data ModuleTree = Node String Bool (Maybe String) (Maybe Doc) [ModuleTree]
-mkModuleTree :: [(Module,Maybe String)] -> [ModuleTree]
+mkModuleTree :: [(Module,Maybe String,Maybe Doc)] -> [ModuleTree]
mkModuleTree mods =
- foldr fn [] [ (splitModule mod, pkg) | (mod,pkg) <- mods ]
+ foldr fn [] [ (splitModule mod, pkg,short) | (mod,pkg,short) <- mods ]
where
- fn (mod,pkg) trees = addToTrees mod pkg trees
+ fn (mod,pkg,short) trees = addToTrees mod pkg short trees
-addToTrees :: [String] -> Maybe String -> [ModuleTree] -> [ModuleTree]
-addToTrees [] pkg ts = ts
-addToTrees ss pkg [] = mkSubTree ss pkg
-addToTrees (s1:ss) pkg (t@(Node s2 leaf node_pkg subs) : ts)
- | s1 > s2 = t : addToTrees (s1:ss) pkg ts
- | s1 == s2 = Node s2 (leaf || null ss) this_pkg (addToTrees ss pkg subs) : ts
- | otherwise = mkSubTree (s1:ss) pkg ++ t : ts
+addToTrees :: [String] -> Maybe String -> Maybe Doc -> [ModuleTree] -> [ModuleTree]
+addToTrees [] pkg short ts = ts
+addToTrees ss pkg short [] = mkSubTree ss pkg short
+addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts)
+ | s1 > s2 = t : addToTrees (s1:ss) pkg short ts
+ | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts
+ | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts
where
this_pkg = if null ss then pkg else node_pkg
+ this_short = if null ss then short else node_short
-mkSubTree :: [String] -> Maybe String -> [ModuleTree]
-mkSubTree [] pkg = []
-mkSubTree [s] pkg = [Node s True pkg []]
-mkSubTree (s:ss) pkg = [Node s (null ss) Nothing (mkSubTree ss pkg)]
+mkSubTree :: [String] -> Maybe String -> Maybe Doc -> [ModuleTree]
+mkSubTree [] pkg short = []
+mkSubTree [s] pkg short = [Node s True pkg short []]
+mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)]
splitModule :: Module -> [String]
splitModule (Module mdl) = split mdl
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index 4522f8c9..15c98f2d 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -64,7 +64,7 @@ data Interface
iface_insts :: [HsDecl],
-- ^ instances from this module
- iface_info :: Maybe ModuleInfo,
+ iface_info :: ModuleInfo,
-- ^ information from the module header
iface_doc :: Maybe Doc,
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index f081a5fb..bf326b82 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -10,7 +10,7 @@ module HaddockUtil (
-- * Misc utilities
nameOfQName, collectNames, declBinders, declMainBinder, declSubBinders,
splitTyConApp, restrictTo, declDoc, parseModuleHeader, freeTyCons, unbang,
- addFieldDoc, addFieldDocs, addConDoc, addConDocs,
+ addFieldDoc, addFieldDocs, addConDoc, addConDocs,toDescription,
-- * Filename utilities
basename, dirname, splitFilename3,
@@ -19,12 +19,16 @@ module HaddockUtil (
cssFile, iconFile, jsFile, plusFile, minusFile,
-- * Miscellaneous utilities
- getProgramName, bye, die, dieMsg, mapSnd, mapMaybeM, escapeStr,
+ getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
-- * HTML cross reference mapping
html_xrefs_ref,
) where
+import HaddockLex
+import HaddockParse
+import HaddockTypes
+
import HsSyn
import List ( intersect, isSuffixOf, intersperse )
@@ -33,15 +37,13 @@ import IO ( hPutStr, stderr )
import System
import Binary
import Monad
-import Char ( isAlpha, ord )
+import Char ( isAlpha, isSpace, toUpper, ord )
#if __GLASGOW_HASKELL__ < 503
-import RegexString
import FiniteMap
import IOExts
import URI ( escapeString, unreserved )
#else
-import Text.Regex
import Data.FiniteMap
import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
@@ -114,6 +116,10 @@ freeTyCons ty = go ty []
go (HsTyVar _) r = r
go (HsTyDoc t _) r = go t r
+-- | extract a module's short description.
+toDescription :: Interface -> Maybe Doc
+toDescription = description. iface_info
+
-- -----------------------------------------------------------------------------
-- Adding documentation to record fields (used in parsing).
@@ -189,42 +195,148 @@ declDoc _ = Nothing
-- -----------------------------------------------------------------------------
-- Parsing module headers
-parseModuleHeader :: String -> (String, Maybe ModuleInfo)
-parseModuleHeader str =
- case matchRegexAll moduleHeaderRE str of
-#if __GLASGOW_HASKELL__ < 503
- Just (_, _, after, _, (_:_:_:s1:s2:s3:_)) ->
-#else
- Just (_, _, after, (_:_:_:s1:s2:s3:_)) ->
-#endif
- (after, Just (ModuleInfo {
- portability = s3,
- stability = s2,
- maintainer = s1 }))
- _other -> (str, Nothing)
-
-moduleHeaderRE :: Regex
-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?).
-
-#if __GLASGOW_HASKELL__ < 500
-mkRegexWithOpts :: String -> Bool -> Bool -> Regex
-mkRegexWithOpts s single_line case_sensitive
- = unsafePerformIO (re_compile_pattern (packString s)
- single_line case_sensitive)
-#endif
+-- NB. The headers must be given in the order Module, Description,
+-- Copyright, License, Maintainer, Stability, Portability, except that
+-- any or all may be omitted.
+parseModuleHeader :: String -> Either String (String,ModuleInfo)
+parseModuleHeader str0 =
+ let
+ getKey :: String -> String -> (Maybe String,String)
+ getKey key str = case parseKey key str of
+ Nothing -> (Nothing,str)
+ Just (value,rest) -> (Just value,rest)
+
+ (moduleOpt,str1) = getKey "Module" str0
+ (descriptionOpt,str2) = getKey "Description" str1
+ (copyrightOpt,str3) = getKey "Copyright" str2
+ (licenseOpt,str4) = getKey "License" str3
+ (maintainerOpt,str5) = getKey "Maintainer" str4
+ (stabilityOpt,str6) = getKey "Stability" str5
+ (portabilityOpt,str7) = getKey "Portability" str6
+
+ description1 :: Either String (Maybe Doc)
+ description1 = case descriptionOpt of
+ Nothing -> Right Nothing
+ Just description -> case parseString . tokenise $ description of
+ Left mess -> Left ("Cannot parse Description: " ++ mess)
+ Right doc -> Right (Just doc)
+ in
+ case description1 of
+ Left mess -> Left mess
+ Right docOpt -> Right (str7,ModuleInfo {
+ description = docOpt,
+ portability = portabilityOpt,
+ stability = stabilityOpt,
+ maintainer = maintainerOpt
+ })
+
+
+-- | This function is how we read keys.
+--
+-- all fields in the header are optional and have the form
+--
+-- [spaces1][field name][spaces] ":"
+-- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
+-- where each [spaces2] should have [spaces1] as a prefix.
+--
+-- Thus for the key "Description",
+--
+-- > Description : this is a
+-- > rather long
+-- >
+-- > description
+-- >
+-- > The module comment starts here
+--
+-- the value will be "this is a .. description" and the rest will begin
+-- at "The module comment".
+parseKey :: String -> String -> Maybe (String,String)
+parseKey key toParse0 =
+ do
+ let
+ (spaces0,toParse1) = extractLeadingSpaces toParse0
+
+ indentation = spaces0
+ afterKey0 <- extractPrefix key toParse1
+ let
+ afterKey1 = extractLeadingSpaces afterKey0
+ afterColon0 <- case snd afterKey1 of
+ ':':afterColon -> return afterColon
+ _ -> Nothing
+ let
+ (_,afterColon1) = extractLeadingSpaces afterColon0
+
+ return (scanKey True indentation afterColon1)
+ where
+ scanKey :: Bool -> String -> String -> (String,String)
+ scanKey isFirst indentation [] = ([],[])
+ scanKey isFirst indentation str =
+ let
+ (nextLine,rest1) = extractNextLine str
+
+ accept = isFirst || sufficientIndentation || allSpaces
+
+ sufficientIndentation = case extractPrefix indentation nextLine of
+ Just (c:_) | isSpace c -> True
+ _ -> False
+
+ allSpaces = case extractLeadingSpaces nextLine of
+ (_,[]) -> True
+ _ -> False
+ in
+ if accept
+ then
+ let
+ (scanned1,rest2) = scanKey False indentation rest1
+
+ scanned2 = case scanned1 of
+ "" -> if allSpaces then "" else nextLine
+ _ -> nextLine ++ "\n" ++ scanned1
+ in
+ (scanned2,rest2)
+ else
+ ([],str)
+
+ extractLeadingSpaces :: String -> (String,String)
+ extractLeadingSpaces [] = ([],[])
+ extractLeadingSpaces (s@(c:cs))
+ | isSpace c =
+ let
+ (spaces1,cs1) = extractLeadingSpaces cs
+ in
+ (c:spaces1,cs1)
+ | True = ([],s)
+
+ extractNextLine :: String -> (String,String)
+ extractNextLine [] = ([],[])
+ extractNextLine (c:cs)
+ | c == '\n' =
+ ([],cs)
+ | True =
+ let
+ (line,rest) = extractNextLine cs
+ in
+ (c:line,rest)
+
+
+ -- indentation returns characters after last newline.
+ indentation :: String -> String
+ indentation s = fromMaybe s (indentation0 s)
+ where
+ indentation0 :: String -> Maybe String
+ indentation0 [] = Nothing
+ indentation0 (c:cs) =
+ case indentation0 cs of
+ Nothing -> if c == '\n' then Just cs else Nothing
+ in0 -> in0
+
+ -- comparison is case-insensitive.
+ extractPrefix :: String -> String -> Maybe String
+ extractPrefix [] s = Just s
+ extractPrefix s [] = Nothing
+ extractPrefix (c1:cs1) (c2:cs2)
+ | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
+ | True = Nothing
-- -----------------------------------------------------------------------------
-- Filename mangling functions stolen from GHC's main/DriverUtil.lhs.
@@ -323,6 +435,9 @@ die s = hPutStr stderr s >> exitWith (ExitFailure 1)
dieMsg :: String -> IO a
dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)
+noDieMsg :: String -> IO ()
+noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s)
+
mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]
mapSnd _ [] = []
mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
@@ -385,3 +500,38 @@ instance Binary HsIdentifier where
1 -> do s <- getString bh; return (HsSymbol s)
_ -> do s <- getString bh; return (HsSpecial s)
+instance Binary id => Binary (GenDoc id) where
+ put_ bh DocEmpty = putByte bh 0
+ put_ bh (DocAppend gd1 gd2) = do putByte bh 1;put_ bh gd1;put_ bh gd2
+ put_ bh (DocString s) = do putByte bh 2;putString bh s
+ put_ bh (DocParagraph gd) = do putByte bh 3;put_ bh gd
+ put_ bh (DocIdentifier id) = do putByte bh 4;put_ bh id
+ put_ bh (DocModule s) = do putByte bh 5;putString bh s
+ put_ bh (DocEmphasis gd) = do putByte bh 6;put_ bh gd
+ put_ bh (DocMonospaced gd) = do putByte bh 7;put_ bh gd
+ put_ bh (DocUnorderedList gd) = do putByte bh 8;put_ bh gd
+ put_ bh (DocOrderedList gd) = do putByte bh 9;put_ bh gd
+ put_ bh (DocDefList gd) = do putByte bh 10;put_ bh gd
+ put_ bh (DocCodeBlock gd) = do putByte bh 11;put_ bh gd
+ put_ bh (DocURL s) = do putByte bh 12;putString bh s
+ put_ bh (DocAName s) = do putByte bh 13;putString bh s
+ get bh = do b <- getByte bh
+ case b of
+ 0 -> return DocEmpty
+ 1 -> do gd1 <- get bh;gd2 <- get bh;return (DocAppend gd1 gd2)
+ 2 -> do s <- getString bh;return (DocString s)
+ 3 -> do gd <- get bh;return (DocParagraph gd)
+ 4 -> do id <- get bh;return (DocIdentifier id)
+ 5 -> do s <- getString bh;return (DocModule s)
+ 6 -> do gd <- get bh;return (DocEmphasis gd)
+ 7 -> do gd <- get bh;return (DocMonospaced gd)
+ 8 -> do gd <- get bh;return (DocUnorderedList gd)
+ 9 -> do gd <- get bh;return (DocOrderedList gd)
+ 10 -> do gd <- get bh;return (DocDefList gd)
+ 11 -> do gd <- get bh;return (DocCodeBlock gd)
+ 12 -> do s <- getString bh;return (DocURL s)
+ 13 -> do s <- getString bh;return (DocAName s)
+ _ -> error ("Mysterious byte in document in interface"
+ ++ show b)
+
+
diff --git a/src/HsParser.ly b/src/HsParser.ly
index 5ac3e4bc..21561e0a 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
-$Id: HsParser.ly,v 1.20 2004/04/20 13:08:04 simonmar Exp $
+$Id: HsParser.ly,v 1.21 2004/08/09 11:55:07 simonmar Exp $
(c) Simon Marlow, Sven Panne 1997-2002
@@ -155,14 +155,14 @@ Module Header
> opts info doc } }
> | body
> { HsModule main_mod Nothing (reverse (fst $1)) (snd $1)
-> Nothing Nothing Nothing }
+> Nothing emptyModuleInfo Nothing }
-> optdoc :: { (Maybe String, Maybe ModuleInfo, Maybe Doc) }
+> optdoc :: { (Maybe String,ModuleInfo,Maybe Doc) }
> : moduleheader { (Nothing, fst $1, snd $1) }
-> | DOCOPTIONS { (Just $1, Nothing, Nothing) }
+> | DOCOPTIONS { (Just $1, emptyModuleInfo,Nothing) }
> | DOCOPTIONS moduleheader { (Just $1, fst $2, snd $2) }
> | moduleheader DOCOPTIONS { (Just $2, fst $1, snd $1) }
-> | {- empty -} { (Nothing, Nothing, Nothing) }
+> | {- empty -} { (Nothing, emptyModuleInfo,Nothing) }
> body :: { ([HsImportDecl],[HsDecl]) }
> : '{' bodyaux '}' { $2 }
@@ -1007,11 +1007,15 @@ Documentation comments
> : docnext { Just $1 }
> | {- empty -} { Nothing }
-> moduleheader :: { (Maybe ModuleInfo, Maybe Doc) }
-> : DOCNEXT {% let (str, info) = parseModuleHeader $1 in
-> case parseParas (tokenise str) of {
-> Left err -> parseError err;
-> Right doc -> returnP (info, Just doc); } }
+> moduleheader :: { (ModuleInfo,Maybe Doc) }
+> : DOCNEXT {% case parseModuleHeader $1 of {
+> Right (str,info) ->
+> case parseParas (tokenise str) of {
+> Left err -> parseError err;
+> Right doc -> returnP (info,Just doc);
+> };
+> Left err -> parseError err
+> } }
-----------------------------------------------------------------------------
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index 664c9601..82f89da9 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
% -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.21 2004/08/02 20:31:13 panne Exp $
+% $Id: HsSyn.lhs,v 1.22 2004/08/09 11:55:07 simonmar Exp $
%
% (c) The GHC Team, 1997-2002
%
@@ -30,6 +30,8 @@ module HsSyn (
unit_tycon_qname, fun_tycon_qname, list_tycon_qname, tuple_tycon_qname,
unit_tycon, fun_tycon, list_tycon, tuple_tycon,
+ emptyModuleInfo,
+
hsIdentifierStr, hsAnchorNameStr, hsNameStr,
GenDoc(..), Doc, DocMarkup(..),
@@ -81,16 +83,26 @@ instance Show HsIdentifier where
data HsModule = HsModule Module (Maybe [HsExportSpec])
[HsImportDecl] [HsDecl]
(Maybe String) -- the doc options
- (Maybe ModuleInfo) -- the info (portability etc.)
- (Maybe Doc) -- the module doc
+ ModuleInfo -- the info (portability etc.)
+ (Maybe Doc) -- the module doc.
deriving Show
data ModuleInfo = ModuleInfo
- { portability :: String,
- stability :: String,
- maintainer :: String }
+ { description :: Maybe Doc,
+ portability :: Maybe String,
+ stability :: Maybe String,
+ maintainer :: Maybe String
+ }
deriving Show
+emptyModuleInfo :: ModuleInfo
+emptyModuleInfo = ModuleInfo {
+ description = Nothing,
+ portability = Nothing,
+ stability = Nothing,
+ maintainer = Nothing
+ }
+
-- Export/Import Specifications
data HsExportSpec
diff --git a/src/Main.hs b/src/Main.hs
index 5d7e3df7..08c3ba7a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -270,48 +270,13 @@ run flags files = do
-- dump an interface if requested
case dump_iface of
Nothing -> return ()
- Just fn -> do
- bh <- openBinMem 100000
- put_ bh prepared_ifaces
- writeBinMem bh fn
- where
- prepared_ifaces =
- [ (mdl, iface_package iface,
- OptHide `elem` iface_options iface,
- fmToList (iface_env iface),
- fmToList (iface_reexported iface),
- fmToList (iface_sub iface))
- | (mdl, iface) <- these_mod_ifaces ]
+ Just fn -> dumpInterfaces these_mod_ifaces fn
parseIfaceOption :: String -> (FilePath,FilePath)
parseIfaceOption s =
case break (==',') s of
(fpath,',':file) -> (fpath,file)
(file, _) -> ("", file)
-
-readIface :: FilePath -> IO [(Module,Interface)]
-readIface filename = do
- bh <- readBinMem filename
- stuff <- get bh
- return (map to_interface stuff)
- where
- to_interface (mdl, package, hide, env, reexported, sub) =
- (mdl, Interface {
- iface_filename = "",
- iface_package = package,
- iface_env = listToFM env,
- iface_import_env = emptyFM,
- iface_sub = listToFM sub,
- iface_reexported = listToFM reexported,
- iface_exports = [],
- iface_orig_exports = [],
- iface_insts = [],
- iface_decls = emptyFM,
- iface_info = Nothing,
- iface_doc = Nothing,
- iface_options = if hide then [OptHide] else []
- }
- )
updateHTMLXRefs :: [FilePath] -> [[(Module,Interface)]] -> IO ()
@@ -1127,6 +1092,112 @@ collectInstances mod_ifaces
| HsInstDecl _ ctxt (cls,args) _ <- all_instances,
nm <- nub (concat (map freeTyCons args))
]
+
+-- -----------------------------------------------------------------------------
+-- The interface file format.
+-- This has to read interfaces up to Haddock 0.6 (without the short
+-- document annotations), and interfaces afterwards, so we use the
+-- FormatVersion hack to work out which one the interface file contains.
+
+thisFormatVersion :: FormatVersion
+thisFormatVersion = mkFormatVersion 1
+
+-- | How we store interfaces. Not everything is stored.
+type StoredInterface =
+ (Module,Maybe Doc,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)],
+ [(HsName,[HsName])])
+
+-- | How we used to store interfaces.
+type NullVersionStoredInterface =
+ (Module,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)],
+ [(HsName,[HsName])])
+
+dumpInterfaces :: [(Module,Interface)] -> FilePath -> IO ()
+dumpInterfaces interfaces fileName =
+ do
+ let
+ preparedInterfaces :: [StoredInterface]
+ preparedInterfaces = map from_interface interfaces
+
+ bh <- openBinMem 100000
+ put_ bh thisFormatVersion
+ put_ bh preparedInterfaces
+ writeBinMem bh fileName
+
+
+readIface :: FilePath -> IO [(Module,Interface)]
+readIface fileName = do
+ bh <- readBinMem fileName
+ formatVersion <- get bh
+ if formatVersion == thisFormatVersion
+ then
+ do
+ (stuff :: [StoredInterface]) <- get bh
+ return (map to_interface stuff)
+ else
+ if formatVersion == nullFormatVersion
+ then
+ do
+ (stuff :: [NullVersionStoredInterface]) <- get bh
+ return (map nullVersion_to_interface stuff)
+ else
+ do
+ noDieMsg (
+ "Warning: The interface file " ++ show fileName
+ ++ " could not be read.\n"
+ ++ "Maybe it's from a later version of Haddock?\n")
+ return []
+
+from_interface :: (Module,Interface) -> StoredInterface
+from_interface (mdl,iface) =
+ (mdl, toDescription iface,iface_package iface,
+ OptHide `elem` iface_options iface,
+ fmToList (iface_env iface),
+ fmToList (iface_reexported iface),
+ fmToList (iface_sub iface)
+ )
+
+to_interface :: StoredInterface -> (Module,Interface)
+to_interface (mdl,descriptionOpt,package, hide, env, reexported, sub) =
+ (mdl, Interface {
+ iface_filename = "",
+ iface_package = package,
+ iface_env = listToFM env,
+ iface_import_env = emptyFM,
+ iface_sub = listToFM sub,
+ iface_reexported = listToFM reexported,
+ iface_exports = [],
+ iface_orig_exports = [],
+ iface_insts = [],
+ iface_decls = emptyFM,
+ iface_info = toModuleInfo descriptionOpt,
+ iface_doc = Nothing,
+ iface_options = if hide then [OptHide] else []
+ })
+
+nullVersion_to_interface :: NullVersionStoredInterface -> (Module,Interface)
+nullVersion_to_interface (mdl, package, hide, env, reexported, sub) =
+ (mdl, Interface {
+ iface_filename = "",
+ iface_package = package,
+ iface_env = listToFM env,
+ iface_import_env = emptyFM,
+ iface_sub = listToFM sub,
+ iface_reexported = listToFM reexported,
+ iface_exports = [],
+ iface_orig_exports = [],
+ iface_insts = [],
+ iface_decls = emptyFM,
+ iface_info = emptyModuleInfo,
+ iface_doc = Nothing,
+ iface_options = if hide then [OptHide] else []
+ })
+
+toModuleInfo :: Maybe Doc -> ModuleInfo
+toModuleInfo descriptionOpt =
+ emptyModuleInfo {description = descriptionOpt}
+
+
-- -----------------------------------------------------------------------------
-- A monad which collects error messages
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 07:45:52 +0000