diff options
| -rw-r--r-- | haddock.cabal | 4 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 36 | ||||
| -rw-r--r-- | src/Main.hs | 555 |
3 files changed, 423 insertions, 172 deletions
diff --git a/haddock.cabal b/haddock.cabal index efe20d60..d226d8e1 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,6 +1,6 @@ name: haddock cabal-version: >=1.1.4 -version: 0.8 +version: 0.85 license: BSD3 license-file: LICENSE copyright: (c) Simon Marlow @@ -53,7 +53,7 @@ extra-source-files: haskell.vim src/haddock.sh -executable: haddock +executable: haddock-ghc hs-source-dirs: src main-is: Main.hs extensions: CPP, PatternGuards diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index 8a0edc11..185a4cb7 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -27,6 +27,9 @@ module HaddockUtil ( -- * HsDoc markup markup, idMarkup, + + -- * Binary extras +-- FormatVersion, mkFormatVersion ) where import HaddockTypes @@ -37,12 +40,15 @@ import GHC import SrcLoc import Name import OccName +import Binary import Control.Monad ( liftM, MonadPlus(..) ) import Data.Char ( isAlpha, isSpace, toUpper, ord ) import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( intersect, isSuffixOf, intersperse ) import Data.Maybe ( maybeToList, fromMaybe, isJust, fromJust ) +import Data.Word ( Word8 ) +import Data.Bits ( testBit ) import Network.URI import System.Environment ( getProgName ) import System.Exit ( exitWith, ExitCode(..) ) @@ -282,3 +288,33 @@ idMarkup = Markup { -- the same thing, modifying only the identifiers embedded in it. mapIdent f = idMarkup { markupIdentifier = f } + +----------------------------------------------------------------------------- +-- put here temporarily + +newtype FormatVersion = FormatVersion Int deriving (Eq,Ord) + +nullFormatVersion :: FormatVersion +nullFormatVersion = mkFormatVersion 0 + +mkFormatVersion :: Int -> FormatVersion +mkFormatVersion i = FormatVersion i + +instance Binary FormatVersion where + put_ bh (FormatVersion i) = + case compare i 0 of + EQ -> return () + GT -> put_ bh (-i) + LT -> error ( + "Binary.hs: negative FormatVersion " ++ show i + ++ " is not allowed") + get bh = + do + w8 :: Word8 <- get bh + if testBit w8 7 + then + do + i <- get bh + return (FormatVersion (-i)) + else + return nullFormatVersion diff --git a/src/Main.hs b/src/Main.hs index 856b5bd0..1043482a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,8 +14,10 @@ import HaddockTypes import HaddockUtil import HaddockVersion import Paths_haddock ( getDataDir ) +import Binary2 -import Control.Exception ( bracket ) +import Control.Exception ( bracket, throwIO, catch, Exception(..) ) +import Prelude hiding ( catch ) import Control.Monad ( when, liftM ) import Control.Monad.Writer ( Writer, runWriter, tell ) import Data.Char ( isSpace ) @@ -26,6 +28,7 @@ import Data.Maybe ( isJust, isNothing, maybeToList, listToMaybe ) import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..) ) import System.Environment ( getArgs ) import System.IO ( stderr, IOMode(..), openFile, hClose, hGetContents, hPutStrLn ) +import System.Directory ( doesFileExist, doesDirectoryExist ) #if defined(mingw32_HOST_OS) import Foreign import Foreign.C @@ -41,27 +44,57 @@ import Outputable import SrcLoc import qualified Digraph as Digraph import Name -import Module ( moduleString ) +import Module ( moduleString, mkModule ) import InstEnv import Class import TypeRep -import Var +import Var hiding ( varName ) import TyCon import PrelNames import FastString #define FSLIT(x) (mkFastString# (x#)) -import qualified DynFlags as DynFlags +import DynFlags hiding ( Option ) +import Unique ( mkUnique ) +import Packages ----------------------------------------------------------------------------- -- Top-level stuff + main :: IO () main = do - cmdline <- getArgs - case getOpt Permute (options True) cmdline of - (flags, args, [] ) -> run flags args - (_, _, errors) -> do prog <- getProgramName - die (concat errors ++ - usageInfo (usageHeader prog) (options False)) + args <- getArgs + (libDir, rest) <- getLibDir args + (session, nonGHCOpts) <- startGHC libDir rest + (flags, args) <- parseHaddockOpts nonGHCOpts + run flags args session + +parseHaddockOpts :: [String] -> IO ([Flag], [String]) +parseHaddockOpts words = + case getOpt Permute (options True) words of + (flags, args, []) -> return (flags, args) + (_, _, errors) -> do + prog <- getProgramName + die (concat errors ++ usageInfo (usageHeader prog) (options False)) + +getLibDir :: [String] -> IO (String, [String]) +getLibDir ("-B":dir:rest) = return (dir, rest) +getLibDir (('-':'B':dir):rest) | not (null dir) = return (dir, rest) +getLibDir _ = die "Missing GHC lib dir option: -B <dir>\n" + +-- | Initialize GHC, then parse the passed in strings and set the corresponding +-- GHC flags (if any). Also add the -haddock flag. Return the Session handle +-- and the strings that were not GHC flags. +startGHC :: String -> [String] -> IO (Session, [String]) +startGHC libDir possibleOpts = do + GHC.init (Just libDir) + let ghcMode = JustTypecheck + session <- newSession ghcMode + flags <- getSessionDynFlags session + flags' <- initPackages flags + (flags'', nonOpts) <- parseDynamicFlags flags' possibleOpts + let flags''' = dopt_set flags'' Opt_Haddock + setSessionDynFlags session flags''' + return (session, nonOpts) usageHeader :: String -> String usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n" @@ -97,12 +130,11 @@ data Flag | Flag_IgnoreAllExports | Flag_HideModule String | Flag_UsePackage String - | Flag_GHCFlag String deriving (Eq) options :: Bool -> [OptDescr Flag] options backwardsCompat = - [ + [ Option ['o'] ["odir"] (ReqArg Flag_OutputDir "DIR") "directory in which to put the output files", Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE") @@ -163,37 +195,37 @@ options backwardsCompat = Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") "behave as if MODULE has the hide attribute", Option [] ["use-package"] (ReqArg Flag_UsePackage "PACKAGE") - "the modules being processed depend on PACKAGE", - Option [] ["ghc-flag"] (ReqArg Flag_GHCFlag "FLAG") - "send a one-word FLAG to the Glasgow Haskell Compiler" + "the modules being processed depend on PACKAGE" ] -run :: [Flag] -> [FilePath] -> IO () -run flags files = do +run :: [Flag] -> [FilePath] -> Session -> IO () +run flags files session = do whenFlag Flag_Help $ do - prog <- getProgramName - bye (usageInfo (usageHeader prog) (options False)) + prog <- getProgramName + bye (usageInfo (usageHeader prog) (options False)) whenFlag Flag_Version $ - bye ("Haddock version " ++ projectVersion ++ - ", (c) Simon Marlow 2003; port to GHC-api by David Waern 2006\n") + bye ("Haddock version " ++ projectVersion ++ + ", (c) Simon Marlow 2003; port to GHC-api by David Waern 2006\n") + + let - let title = case [str | Flag_Heading str <- flags] of + title = case [str | Flag_Heading str <- flags] of [] -> "" (t:_) -> t - package = listToMaybe [str | Flag_Package str <- flags] + package = listToMaybe [str | Flag_Package str <- flags] - maybe_source_urls = (listToMaybe [str | Flag_SourceBaseURL str <- flags] - ,listToMaybe [str | Flag_SourceModuleURL str <- flags] - ,listToMaybe [str | Flag_SourceEntityURL str <- flags]) + maybe_source_urls = (listToMaybe [str | Flag_SourceBaseURL str <- flags] + ,listToMaybe [str | Flag_SourceModuleURL str <- flags] + ,listToMaybe [str | Flag_SourceEntityURL str <- flags]) - maybe_wiki_urls = (listToMaybe [str | Flag_WikiBaseURL str <- flags] - ,listToMaybe [str | Flag_WikiModuleURL str <- flags] - ,listToMaybe [str | Flag_WikiEntityURL str <- flags]) + maybe_wiki_urls = (listToMaybe [str | Flag_WikiBaseURL str <- flags] + ,listToMaybe [str | Flag_WikiModuleURL str <- flags] + ,listToMaybe [str | Flag_WikiEntityURL str <- flags]) - verbose = Flag_Verbose `elem` flags + verbose = Flag_Verbose `elem` flags libdir <- case [str | Flag_Lib str <- flags] of [] -> getDataDir -- provided by Cabal @@ -207,61 +239,56 @@ run flags files = do [] -> return "." fs -> return (last fs) - let dump_iface = case [str | Flag_DumpInterface str <- flags] of + let + + dumpIface = case [str | Flag_DumpInterface str <- flags] of [] -> Nothing fs -> Just (last fs) - read_iface_flags = [ parseIfaceOption str - | Flag_ReadInterface str <- flags ] + readIfaceFlags = [ parseIfaceOption str | Flag_ReadInterface str <- flags ] - maybe_contents_url = - case [url | Flag_UseContents url <- flags] of - [] -> Nothing - us -> Just (last us) + maybe_contents_url = + case [url | Flag_UseContents url <- flags] of + [] -> Nothing + us -> Just (last us) - maybe_index_url = - case [url | Flag_UseIndex url <- flags] of - [] -> Nothing - us -> Just (last us) + maybe_index_url = + case [url | Flag_UseIndex url <- flags] of + [] -> Nothing + us -> Just (last us) + + maybe_html_help_format = + case [hhformat | Flag_HtmlHelp hhformat <- flags] of + [] -> Nothing + formats -> Just (last formats) - maybe_html_help_format = - case [hhformat | Flag_HtmlHelp hhformat <- flags] of - [] -> Nothing - formats -> Just (last formats) - prologue <- getPrologue flags when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) && Flag_Html `elem` flags) $ die ("-h cannot be used with --gen-index or --gen-contents") - GHC.init (Just "/home/davve/dev/local/lib/ghc-6.5") - let ghcMode = JustTypecheck - session <- newSession ghcMode ghcFlags <- getSessionDynFlags session - ghcFlags' <- initPackages ghcFlags - - let haddockGhcFlags = [ f | Flag_GHCFlag f <- flags ] - (ghcFlags'', rest) <- parseDynamicFlags ghcFlags' haddockGhcFlags - when (not (null rest)) (die $ "The following flags are not GHC flags: " ++ pprList rest ++ "\n") - let ghcFlags''' = DynFlags.dopt_set ghcFlags'' DynFlags.Opt_Haddock - - sorted_checked_modules <- defaultErrorHandler ghcFlags''' $ do - setSessionDynFlags session ghcFlags''' + + sorted_checked_modules <- defaultErrorHandler ghcFlags $ do targets <- mapM (\s -> guessTarget s Nothing) files setTargets session targets maybe_module_graph <- depanal session [] True module_graph <- case maybe_module_graph of Just module_graph -> return module_graph - Nothing -> die "Failed to load modules\n" - let sorted_modules = concatMap Digraph.flattenSCC (topSortModuleGraph False module_graph Nothing) - let (modules, filenames) = unzip [ (ms_mod modsum, fromJust $ ml_hs_file (ms_location modsum)) | modsum <- sorted_modules, - fromJust (ml_hs_file (ms_location modsum)) `elem` files ] + Nothing -> die "Failed to load modules 1\n" + + let + modSumFile = fromJust . ml_hs_file . ms_location + sorted_modules = concatMap Digraph.flattenSCC (topSortModuleGraph False module_graph Nothing) + (modules, filenames) = unzip [ (ms_mod modsum, modSumFile modsum) | modsum <- sorted_modules, + modSumFile modsum `elem` files ] + --print_ modules mb_checked_modules <- mapM (checkModule session) modules let checked_modules = catMaybes mb_checked_modules if length checked_modules /= length mb_checked_modules - then die "Failed to load all modules\n" + then die "Failed to load all modules 2\n" else return (zip3 modules checked_modules filenames) sorted_checked_modules' <- remove_maybes sorted_checked_modules @@ -271,15 +298,25 @@ run flags files = do haddockModules = catMaybes [ Map.lookup mod modMap | (mod, _, file) <- sorted_checked_modules', file `elem` files ] - - let env = buildGlobalDocEnv haddockModules - let haddockModules' = attachInstances haddockModules + packageFiles <- getPackageFiles ghcFlags + --print packageFiles + let + totalFiles = packageFiles ++ readIfaceFlags + (htmlPaths, ifacePaths) = unzip totalFiles + ifaces <- mapM readIface ifacePaths - let (haddockModules'', messages') = runWriter $ mapM (renameModule env) haddockModules' + let + (moduless, extEnvs) = unzip ifaces + homeEnv = buildGlobalDocEnv haddockModules + env = Map.unions (homeEnv:extEnvs) + haddockModules' = attachInstances haddockModules + (haddockModules'', messages') = runWriter $ mapM (renameModule env) haddockModules' + updateHTMLXRefs htmlPaths moduless + -- putStrLn "pass 1 messages:" - print messages + mapM_ putStrLn messages {- putStrLn "pass 1 export items:" printSDoc (ppr (map hmod_export_items haddockModules')) defaultUserStyle @@ -292,8 +329,6 @@ run flags files = do let visibleModules = [ m | m <- haddockModules'', OptHide `notElem` (hmod_options m) ] - updateHTMLXRefs [] [] - when (Flag_GenIndex `elem` flags) $ do ppHtmlIndex odir title package maybe_html_help_format maybe_contents_url maybe_source_urls maybe_wiki_urls @@ -317,73 +352,11 @@ run flags files = do copyHtmlBits odir libdir css_file return () -{- parsed_mods <- mapM parse_file files - - sorted_mod_files <- sortModules (zip parsed_mods files) - -- emits an error message if there are recursive modules - - -- process the modules in sorted order, building up a mapping from - -- modules to interfaces. - let - loop mod_env ifaces [] = return (reverse ifaces) - loop mod_env ifaces ((hsmod,file):mdls) = do - let (iface,msgs) = runWriter $ - mkInterfacePhase1 flags verbose mod_env file package hsmod - new_mod_env = Map.insert (iface_module iface) iface mod_env - mapM_ (hPutStrLn stderr) msgs - loop new_mod_env (iface:ifaces) mdls - - let - mod_map = Map.fromList [ (iface_module iface,iface) - | iface <- read_ifaces ] - - ifaces <- loop mod_map read_ifaces sorted_mod_files - let - these_ifaces0 = [ iface | iface <- ifaces, - iface_module iface `notElem` external_mods ] - - let these_ifaces1 = attachInstances these_ifaces0 - this_doc_env = buildGlobalDocEnv these_ifaces1 - global_doc_env = this_doc_env `Map.union` - ext_doc_env `Map.union` - builtinDocEnv - - --- Now do phase 2 - let - loop2 ifaces [] = return (reverse ifaces) - loop2 ifaces (iface:rest) = do - let (iface',msgs) = runWriter $ - mkInterfacePhase2 verbose iface global_doc_env - mapM_ (hPutStrLn stderr) msgs - loop2 (iface':ifaces) rest - - these_ifaces <- loop2 [] these_ifaces1 - --- when (Flag_DocBook `elem` flags) $ --- putStr (ppDocBook odir mod_ifaces) - - - when (Flag_Debug `elem` flags) $ do - mapM_ putStrLn (map show [ (iface_module i, - Map.toAscList (iface_env i), - Map.toAscList (iface_sub i)) - | i <- these_ifaces ]) - - when (Flag_Html `elem` flags) $ do - ppHtml title package these_ifaces odir - prologue maybe_html_help_format - maybe_source_urls maybe_wiki_urls - maybe_contents_url maybe_index_url - copyHtmlBits odir libdir css_file - - when (Flag_Hoogle `elem` flags) $ do - ppHoogle package these_ifaces odir -- dump an interface if requested - case dump_iface of - Nothing -> return () - Just fn -> dumpInterfaces these_ifaces this_doc_env fn -} + case dumpIface of + Nothing -> return () + Just fn -> dumpInterfaces env (map hmod_mod visibleModules) fn where whenFlag flag action = when (flag `elem` flags) action @@ -417,7 +390,7 @@ type FullyCheckedModule = (ParsedSource, printEntity (DocEntity doc) = show doc printEntity (DeclEntity name) = show $ ppr name defaultUserStyle -pass1 :: [(Module, FullyCheckedModule, FilePath)] -> [Flag] -> Maybe String-> ErrMsgM ModuleMap2 +pass1 :: [(Module, FullyCheckedModule, FilePath)] -> [Flag] -> Maybe String -> ErrMsgM ModuleMap2 pass1 modules flags package = worker modules (Map.empty) flags where worker :: [(Module, FullyCheckedModule, FilePath)] -> ModuleMap2 -> [Flag] -> ErrMsgM ModuleMap2 @@ -427,7 +400,7 @@ pass1 modules flags package = worker modules (Map.empty) flags let (parsed_source, renamed_source, _, moduleInfo) = checked_mod (mb_doc_opts, _, _) = get_module_stuff parsed_source - opts <- mk_doc_opts mb_doc_opts + opts <- mkDocOpts mb_doc_opts let (group, _, mb_exports, mbModDoc, haddockModInfo) = renamed_source @@ -444,15 +417,15 @@ pass1 modules flags package = worker modules (Map.empty) flags subMap = mk_sub_map_from_group group - -- tell (map printEntity entities) - theseVisibleNames <- visibleNames mod moduleMap localNames scopeNames subMap exports opts - - let exportedDeclMap = mkDeclMap exportedNames group + exportedDeclMap = mkDeclMap exportedNames group localDeclMap = mkDeclMap theseEntityNames group docMap = mkDocMap group ignoreAllExports = Flag_IgnoreAllExports `elem` flags + theseVisibleNames <- visibleNames mod moduleMap localNames scopeNames + subMap exports opts localDeclMap + exportItems <- mkExportItems moduleMap mod exportedNames exportedDeclMap localDeclMap subMap entities opts exports ignoreAllExports docMap @@ -494,8 +467,8 @@ pass1 modules flags package = worker modules (Map.empty) flags let HsModule _ _ _ _ _ mb_opts info mb_doc = unLoc source in (mb_opts, info, mb_doc) - mk_doc_opts mb_opts = do - opts <- case mb_opts of + mkDocOpts mbOpts = do + opts <- case mbOpts of Just opts -> processOptions opts Nothing -> return [] let opts' = if Flag_HideModule (moduleString mod) `elem` flags @@ -513,17 +486,14 @@ sameName (DeclEntity a) (DeclEntity b) = a == b mkDocMap :: HsGroup Name -> Map Name (HsDoc Name) mkDocMap group = Map.fromList (topDeclDocs ++ classMethDocs ++ recordFieldDocs) where - tyclds = map unLoc (hs_tyclds group) - classes = filter isClassDecl tyclds - datadecls = filter isDataDecl tyclds - constrs = [ con | d <- datadecls, L _ con <- tcdCons d ] - fields = concat [ fields | RecCon fields <- map con_details constrs] + tyclds = map unLoc (hs_tyclds group) + classes = filter isClassDecl tyclds + datadecls = filter isDataDecl tyclds + constrs = [ con | d <- datadecls, L _ con <- tcdCons d ] + fields = concat [ fields | RecCon fields <- map con_details constrs] topDeclDocs = collectDocs (reverse (hs_docs group)) - - classMethDocs - = concatMap (collectDocs . tcdDocs) classes - + classMethDocs = concatMap (collectDocs . tcdDocs) classes recordFieldDocs = [ (unLoc lname, doc) | HsRecField lname _ (Just (L _ doc)) <- fields ] @@ -638,14 +608,10 @@ parseIfaceOption s = (fpath,',':file) -> (fpath,file) (file, _) -> ("", file) -updateHTMLXRefs :: [FilePath] -> [[HaddockModule]] -> IO () -updateHTMLXRefs paths hmods_s = - writeIORef html_xrefs_ref (Map.fromList mapping) - where - mapping = [ (hmod_mod hmod, fpath) - | (fpath, hmods) <- zip paths hmods_s, - hmod <- hmods - ] +updateHTMLXRefs :: [FilePath] -> [[Module]] -> IO () +updateHTMLXRefs paths modss = writeIORef html_xrefs_ref (Map.fromList mapping) + where + mapping = [ (mod, fpath) | (fpath, mods) <- zip paths modss, mod <- mods ] getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName)) getPrologue flags @@ -784,13 +750,12 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m fullContentsOfThisModule :: Module -> [DocEntity Name] -> Map Name (LHsDecl Name) -> Map Name (HsDoc Name) -> [ExportItem2 Name] -fullContentsOfThisModule module_ entities declMap docMap = map mkExportItem entities +fullContentsOfThisModule module_ entities declMap docMap + = catMaybes (map mkExportItem entities) where - mkExportItem (DocEntity (DocGroup lev doc)) = ExportGroup2 lev "" doc - mkExportItem (DeclEntity name) = trace (show (ppr name defaultUserStyle)) $ case Map.lookup name declMap of - Just decl -> let maybeDoc = Map.lookup name docMap in ExportDecl2 name decl maybeDoc [] - -- this can happen if there was no type signature for a value binding - Nothing -> ExportNoDecl2 name name [] + mkExportItem (DocEntity (DocGroup lev doc)) = Just (ExportGroup2 lev "" doc) + mkExportItem (DeclEntity name) = fmap mkExport (Map.lookup name declMap) + where mkExport decl = ExportDecl2 name decl (Map.lookup name docMap) [] -- Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these @@ -868,16 +833,18 @@ visibleNames :: Module -> Map Name [Name] -> Maybe [IE Name] -> [DocOption] + -> Map Name (LHsDecl Name) -> ErrMsgM [Name] -visibleNames mdl modMap localNames scope subMap maybeExps opts +visibleNames mdl modMap localNames scope subMap maybeExps opts declMap -- if no export list, just return all local names - | Nothing <- maybeExps = return localNames + | Nothing <- maybeExps = return (filter hasDecl localNames) | OptIgnoreExports `elem` opts = return localNames | Just expspecs <- maybeExps = do visibleNames <- mapM extract expspecs return $ filter isNotPackageName (concat visibleNames) where + hasDecl name = isJust (Map.lookup name declMap) isNotPackageName name = nameMod == mdl || isJust (Map.lookup nameMod modMap) where nameMod = nameModule name @@ -924,8 +891,6 @@ allSubsOfName mod_map name -- -- The interfaces are passed in in topologically sorted order, but we start -- by reversing the list so we can do a foldl. --- - buildGlobalDocEnv :: [HaddockModule] -> Map Name Name buildGlobalDocEnv modules = foldl upd Map.empty (reverse modules) @@ -1081,3 +1046,253 @@ toHsType t = case t of type ErrMsg = String type ErrMsgM a = Writer [ErrMsg] a + +-- ----------------------------------------------------------------------------- +-- Packages + +getPackageFiles :: DynFlags -> IO [(String, String)] +getPackageFiles dynflags = do + packages <- getExplicitPackagesAnd dynflags [] + mbFiles <- mapM check packages + return [ pair | Just pair <- mbFiles ] + where + check p = (do + pair <- check' p + return (Just pair)) `catch` (\e -> do + putStrLn ("Warning: Cannot use package " ++ pkg ++ ":") + putStrLn (" " ++ show e) + return Nothing) + where + pkg = showPackageId (package p) + + check' p = do + when (null html || null iface) $ + throwIO (ErrorCall "No Haddock documentation installed.") + + htmlExists <- doesDirectoryExist html + when (not htmlExists) $ + throwIO (ErrorCall ("HTML directory " ++ html ++ " does not exist.")) + + ifaceExists <- doesFileExist iface + when (not ifaceExists) $ + throwIO (ErrorCall ("Interace " ++ iface ++ " does not exist.")) + + return (html, iface) + where + html = first (haddockHTMLs p) + iface = first (haddockInterfaces p) + + first [] = [] + first (x:_) = x + +-- ----------------------------------------------------------------------------- +-- The interface file format +-- ehhm. this is a hack... + +thisFormatVersion :: FormatVersion +thisFormatVersion = mkFormatVersion 3 + +dumpInterfaces :: Map Name Name -> [Module] -> FilePath -> IO () +dumpInterfaces globalDocEnv modules fileName = do + bh <- openBinMem 100000 + put_ bh thisFormatVersion + mapM (put_ bh) modules + putDocEnv bh globalDocEnv + writeBinMem bh fileName + +putDocEnv :: BinHandle -> Map Name Name -> IO () +putDocEnv bh env = put_ bh list + where + list = [ (nameModule o, nameOccName o, nameModule e) | + (o, e) <- Map.toList env ] + +getDocEnv :: BinHandle -> IO (Map Name Name) +getDocEnv bh = do + list <- get bh + return (Map.fromList [(mkName mdl1 occ, mkName mdl2 occ) | + (mdl1,occ,mdl2) <- list]) + +mkName mdl occ = mkExternalName (mkUnique 'X' 0) mdl occ Nothing noSrcLoc + +--type StoredInterface2 = +-- (Module,Maybe Doc,Maybe String,Bool,[(HsName,Module)], [(HsName,[HsName])]) + +readIface :: FilePath -> IO ([Module], Map Name Name) +readIface fileName = do + bh <- readBinMem fileName + formatVersion <- get bh + case formatVersion of + v | v == thisFormatVersion -> do + modules::[Module] <- get bh + env <- getDocEnv bh + return (modules, env) +-- v | v == mkFormatVersion 2 -> do +-- (stuff :: [StoredInterface2]) <- get bh +-- doc_env <- getDocEnv bh +-- return (map to_interface2 stuff, doc_env) + otherwise -> do + noDieMsg ( + "Warning: The interface file " ++ show fileName + ++ " could not be read.\n" + ++ "Interface files from earlier version of Haddock are not " + ++ "supported yet.\n") + return ([],Map.empty) + +encodeNS n + | isVarOcc n = 0 + | isDataOcc n = 1 + | isTvOcc n = 2 + | isTcOcc n = 3 + +decodeNS n = case n of + 0 -> varName + 1 -> dataName + 2 -> tvName + _ -> tcClsName + +instance Binary OccName where + put_ bh n = do + put_ bh (occNameString n) + putByte bh (encodeNS n) + get bh = do + string <- get bh + ns <- getByte bh + return (mkOccName (decodeNS ns) string) + +instance Binary Module where + put_ bh m = put_ bh (moduleString m) + get bh = do m <- get bh; return (mkModule m) + +{- +thisFormatVersion :: FormatVersion +thisFormatVersion = mkFormatVersion 2 + +-- | How we store interfaces. Not everything is stored. +type StoredInterface2 = + (Module,Maybe Doc,Maybe String,Bool,[(HsName,Module)], [(HsName,[HsName])]) + +-- | How we store interfaces. Not everything is stored. +type StoredInterface1 = + (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 :: [Interface] -> Map HsQName HsQName -> FilePath -> IO () +dumpInterfaces interfaces global_doc_env fileName = + do + let + preparedInterfaces :: [StoredInterface2] + preparedInterfaces = map from_interface interfaces + + bh <- openBinMem 100000 + put_ bh thisFormatVersion + put_ bh preparedInterfaces + putDocEnv bh global_doc_env + writeBinMem bh fileName + + +readIface :: FilePath -> IO ([Interface], Map HsQName HsQName) +readIface fileName = do + bh <- readBinMem fileName + formatVersion <- get bh + case formatVersion of + v | v == thisFormatVersion -> do + (stuff :: [StoredInterface2]) <- get bh + doc_env <- getDocEnv bh + return (map to_interface2 stuff, doc_env) + v | v == mkFormatVersion 1 -> do + (stuff :: [StoredInterface1]) <- get bh + return (map to_interface1 stuff, Map.empty) + v | v == nullFormatVersion -> do + (stuff :: [NullVersionStoredInterface]) <- get bh + return (map nullVersion_to_interface stuff, Map.empty) + otherwise -> do + noDieMsg ( + "Warning: The interface file " ++ show fileName + ++ " could not be read.\n" + ++ "Maybe it's from a later version of Haddock?\n") + return ([], Map.empty) + +from_interface :: Interface -> StoredInterface2 +from_interface iface = + ( iface_module iface, + toDescription iface,iface_package iface, + OptHide `elem` iface_options iface, + [(n,mdl) | (n,Qual mdl n') <- Map.toAscList (iface_env iface), + if n /= n' then error "help!" else True], + Map.toAscList (iface_sub iface) + ) + +getDocEnv :: BinHandle -> IO (Map HsQName HsQName) +getDocEnv bh = do + doc_env_list <- get bh + return (Map.fromList [(Qual mdl1 nm,Qual mdl2 nm) | + (mdl1,nm,mdl2) <- doc_env_list]) + +to_interface1 :: StoredInterface1 -> Interface +to_interface1 (mdl,descriptionOpt,package, hide, env, _, sub) = + Interface { + iface_module = mdl, + iface_filename = "", + iface_orig_filename= "", + iface_package = package, + iface_env = Map.fromList env, + iface_sub = Map.fromList sub, + iface_reexported = [], + iface_exports = [], + iface_orig_exports = [], + iface_insts = [], + iface_decls = Map.empty, + iface_info = toModuleInfo descriptionOpt, + iface_doc = Nothing, + iface_options = if hide then [OptHide] else [] + } + +to_interface2 :: StoredInterface2 -> Interface +to_interface2 (mdl,descriptionOpt,package, hide, env, sub) = + Interface { + iface_module = mdl, + iface_filename = "", + iface_orig_filename= "", + iface_package = package, + iface_env = + Map.fromList [(n,Qual mdl n) | (n,mdl) <- env], + iface_sub = Map.fromList sub, + iface_reexported = [], + iface_exports = [], + iface_orig_exports = [], + iface_insts = [], + iface_decls = Map.empty, + iface_info = toModuleInfo descriptionOpt, + iface_doc = Nothing, + iface_options = if hide then [OptHide] else [] + } + +nullVersion_to_interface :: NullVersionStoredInterface -> Interface +nullVersion_to_interface (mdl, package, hide, env, reexported, sub) = + Interface { + iface_module = mdl, + iface_filename = "", + iface_orig_filename= "", + iface_package = package, + iface_env = Map.fromList env, + iface_sub = Map.fromList sub, + iface_reexported = [], + iface_exports = [], + iface_orig_exports = [], + iface_insts = [], + iface_decls = Map.empty, + iface_info = emptyModuleInfo, + iface_doc = Nothing, + iface_options = if hide then [OptHide] else [] + } + +toModuleInfo :: Maybe Doc -> ModuleInfo +toModuleInfo descriptionOpt = + emptyModuleInfo {description = descriptionOpt} + +-} |