diff options
| -rw-r--r-- | haddock-api/src/Haddock.hs | 13 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 6 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 25 |
3 files changed, 17 insertions, 27 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index ee6e3050..0bf94129 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -47,7 +47,6 @@ import Data.IORef import qualified Data.Map as Map import System.IO import System.Exit -import System.Directory #if defined(mingw32_HOST_OS) import Foreign @@ -68,6 +67,8 @@ import DynFlags hiding (verbosity) import StaticFlags (discardStaticFlags) import Panic (handleGhcException) import Module +import PackageConfig +import FastString -------------------------------------------------------------------------------- -- * Exception handling @@ -250,7 +251,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do pkgMod = ifaceMod (head ifaces) pkgKey = modulePackageKey pkgMod pkgStr = Just (packageKeyString pkgKey) - (pkgName,pkgVer) = modulePackageInfo pkgMod + (pkgName,pkgVer) = modulePackageInfo dflags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity @@ -286,15 +287,17 @@ render dflags flags qual ifaces installedIfaces srcMap = do -- TODO: we throw away Meta for both Hoogle and LaTeX right now, -- might want to fix that if/when these two get some work on them when (Flag_Hoogle `elem` flags) $ do - let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName - ppHoogle dflags pkgName2 pkgVer title (fmap _doc prologue) visibleIfaces + let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] + = title + | otherwise = unpackFS pkgNameFS + where PackageName pkgNameFS = pkgName + ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces odir when (Flag_LaTeX `elem` flags) $ do ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir - ------------------------------------------------------------------------------- -- * Reading and dumping interface files ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index dd2e7387..3ea73db5 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -25,6 +25,7 @@ import Outputable import Data.Char import Data.List import Data.Maybe +import Data.Version import System.FilePath import System.IO @@ -34,13 +35,14 @@ prefix = ["-- Hoogle documentation, generated by Haddock" ,""] -ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () ppHoogle dflags package version synopsis prologue ifaces odir = do let filename = package ++ ".txt" contents = prefix ++ docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ ["@package " ++ package] ++ - ["@version " ++ version | version /= ""] ++ + ["@version " ++ showVersion version + | not (null (versionBranch version)) ] ++ concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] h <- openFile (odir </> filename) WriteMode hSetEncoding h utf8 diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 33d92131..2c7b79a1 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -22,8 +22,6 @@ import Control.Arrow import Data.Foldable hiding (concatMap) import Data.Function import Data.Traversable -import Distribution.Compat.ReadP -import Distribution.Text import Exception import Outputable @@ -43,24 +41,11 @@ moduleString = moduleNameString . moduleName -- return the (name,version) of the package -modulePackageInfo :: Module -> (String, [Char]) -modulePackageInfo modu = case unpackPackageKey pkg of - Nothing -> (packageKeyString pkg, "") - Just x -> (display $ pkgName x, showVersion (pkgVersion x)) - where pkg = modulePackageKey modu - - --- This was removed from GHC 6.11 --- XXX we shouldn't be using it, probably - --- | Try and interpret a GHC 'PackageKey' as a cabal 'PackageIdentifer'. Returns @Nothing@ if --- we could not parse it as such an object. -unpackPackageKey :: PackageKey -> Maybe PackageIdentifier -unpackPackageKey p - = case [ pid | (pid,"") <- readP_to_S parse str ] of - [] -> Nothing - (pid:_) -> Just pid - where str = packageKeyString p +modulePackageInfo :: DynFlags -> Module -> (PackageName, Version) +modulePackageInfo dflags modu = + (packageName pkg, packageVersion pkg) + where + pkg = getPackageDetails dflags (modulePackageKey modu) lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv) |