diff options
-rw-r--r-- | src/Binary.hs | 8 | ||||
-rw-r--r-- | src/HaddockHH.hs | 4 | ||||
-rw-r--r-- | src/HaddockHtml.hs | 47 | ||||
-rw-r--r-- | src/HaddockModuleTree.hs | 31 | ||||
-rw-r--r-- | src/HaddockTypes.hs | 2 | ||||
-rw-r--r-- | src/HaddockUtil.hs | 232 | ||||
-rw-r--r-- | src/HsParser.ly | 24 | ||||
-rw-r--r-- | src/HsSyn.lhs | 24 | ||||
-rw-r--r-- | src/Main.hs | 143 |
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 |