diff --git a/haskell-docs.cabal b/haskell-docs.cabal --- a/haskell-docs.cabal +++ b/haskell-docs.cabal @@ -1,5 +1,5 @@ name: haskell-docs -version: 4.2.2 +version: 4.2.3 synopsis: A program to find and display the docs and type of a name description: Given a module name and a name, or just a name, it will find and display the documentation of that name. @@ -54,28 +54,37 @@ library ghc-options: -O2 -Wall - hs-source-dirs: src + if impl(ghc>=7.8.4) + hs-source-dirs: src, src/haddock-api + if impl(ghc<7.8.4) + hs-source-dirs: src, src/haddock exposed-modules: Haskell.Docs, Haskell.Docs.Ghc, Haskell.Docs.Cabal, Haskell.Docs.Formatting, Haskell.Docs.Haddock, Haskell.Docs.Types, - Haskell.Docs.Index - build-depends: text, - base > 4 && < 5, - ghc >= 7.2 && < 7.9, - Cabal, - ghc-paths, - containers, - monad-loops, - aeson, - filepath, - directory, - text, - unordered-containers, - bytestring - if impl(ghc==7.8.*) + Haskell.Docs.Index, + Haskell.Docs.HaddockDoc + build-depends: Cabal + , aeson + , base > 4 && < 5 + , base16-bytestring + , bytestring + , containers + , cryptohash + , directory + , filepath + , ghc >= 7.2 && < 7.9 + , ghc-paths + , monad-loops + , process + , text + , text + , unordered-containers + if impl(ghc==7.8.4) + build-depends: haddock-api==2.15.* + if impl(ghc==7.8.3) build-depends: haddock==2.14.* if impl(ghc==7.6.*) build-depends: haddock==2.13.* @@ -84,8 +93,8 @@ if impl(ghc==7.2.*) build-depends: haddock==2.9.* - if impl(ghc>=7.8) - build-depends: haddock + if impl(ghc>=7.8.4) + build-depends: haddock-api if impl(ghc<7.2) build-depends: haddock diff --git a/src/Haskell/Docs.hs b/src/Haskell/Docs.hs --- a/src/Haskell/Docs.hs +++ b/src/Haskell/Docs.hs @@ -7,15 +7,16 @@ module Haskell.Docs (module Haskell.Docs ,Identifier(..) - ,PackageName(..) - ,searchAndPrintModules - ,searchAndPrintDoc) + ,PackageName(..)) where +import Haskell.Docs.Cabal import Haskell.Docs.Formatting +import Haskell.Docs.Ghc import Haskell.Docs.Haddock import Haskell.Docs.Index import Haskell.Docs.Types +import PackageConfig import Control.Exception import Control.Monad @@ -23,6 +24,7 @@ import Data.List import Data.Ord import Data.Text (pack,unpack) +import qualified Data.Text as T import qualified Data.Text.IO as T import GHC hiding (verbosity) import MonadUtils @@ -36,24 +38,36 @@ -> Maybe ModuleName -- ^ Module name. -> Identifier -- ^ Identifier. -> Ghc () -searchAndPrintDoc gs ms ss pname mname ident = - do (result,printPkg,printModule) <- search +searchAndPrintDoc flags ms ss pname mname ident = + do result <- liftIO (lookupIdent flags + (pack (unIdentifier ident))) case result of - Left err -> - throw err - Right (sortBy (comparing identDocPackageName) -> docs) -> - if ss - then printSexp (nub docs) - else mapM_ (\(i,doc') -> - do when (not ms && i > 0) - (liftIO (putStrLn "")) - printIdentDoc ms printPkg printModule doc') - (zip [0::Int ..] (nub docs)) - where search = - case (pname,mname) of - (Just p,Just m) -> fmap (,False,False) (searchPackageModuleIdent Nothing p m ident) - (Nothing,Just m) -> fmap (,True,False) (searchModuleIdent Nothing m ident) - _ -> fmap (,True,True) (searchIdent gs Nothing ident) + Nothing -> throw NoFindModule + Just pkgModuleMap -> + do pkgs <- getAllPackages flags + docs <- fmap concat + (forM (M.toList pkgModuleMap) + (searchResult pkgs)) + if ss + then printSexp docs + else mapM_ (\(i,doc') -> + printIdentDoc False True True doc') + (zip [0 :: Int ..] + (nub docs)) + where searchResult pkgs (pkgName,modName) = + case find (matchingPkg pkgName) pkgs of + Nothing -> return [] + Just pkg -> searchPkg pkg modName + where matchingPkg pkgName = (== pkgName) . T.pack . showPackageName . + sourcePackageId + searchPkg pkg modName = + do result <- searchWithPackage + pkg + (Just (head (fmap (makeModuleName . T.unpack) modName))) + ident + case result of + Left err -> throw err + Right (sortBy (comparing identDocPackageName) -> docs) -> return docs -- | Search only for identifiers and print out all modules associated. searchAndPrintModules :: [String] -> Identifier -> IO () diff --git a/src/Haskell/Docs/Cabal.hs b/src/Haskell/Docs/Cabal.hs --- a/src/Haskell/Docs/Cabal.hs +++ b/src/Haskell/Docs/Cabal.hs @@ -9,13 +9,13 @@ import Data.Char (isSpace) import Data.List +import Data.Maybe import Distribution.InstalledPackageInfo import Distribution.ModuleName import Distribution.Simple.Compiler -import Distribution.Simple.GHC import Distribution.Simple.PackageIndex -import Distribution.Simple.Program -import Distribution.Verbosity +import DynFlags +import GHC import Module import PackageConfig @@ -28,18 +28,20 @@ trim = (drop 1) . snd . (break isSpace) -- | Get all installed packages, filtering out the given package. -getAllPackages :: [String] -> IO [PackageConfig] +getAllPackages :: [String] -> Ghc [PackageConfig.PackageConfig] getAllPackages gs = - do config <- configureAllKnownPrograms - normal - (addKnownPrograms [ghcProgram,ghcPkgProgram] - emptyProgramConfiguration) - index <- getInstalledPackages - normal - (concat [[GlobalPackageDB,UserPackageDB],getGhcOpsPackageDB gs]) - config - return (map (imap convModule) - (concat (packagesByName index))) + do flags <- getSessionDynFlags + return (fromMaybe [] (pkgDatabase flags)) + -- do config <- configureAllKnownPrograms + -- normal + -- (addKnownPrograms [ghcProgram,ghcPkgProgram] + -- emptyProgramConfiguration) + -- index <- getInstalledPackages + -- normal + -- (concat [[GlobalPackageDB,UserPackageDB],getGhcOpsPackageDB gs]) + -- config + -- return (map (imap convModule) + -- (concat (packagesByName index))) -- | Version-portable version of allPackagesByName. packagesByName :: PackageIndex -> [[InstalledPackageInfo]] diff --git a/src/Haskell/Docs/Formatting.hs b/src/Haskell/Docs/Formatting.hs --- a/src/Haskell/Docs/Formatting.hs +++ b/src/Haskell/Docs/Formatting.hs @@ -6,6 +6,7 @@ import Haskell.Docs.Types import Haskell.Docs.Ghc +import Haskell.Docs.HaddockDoc import Control.Monad import Data.Char @@ -82,66 +83,6 @@ ,[List [Atom "arguments",List ((map (\(i,x) -> String (formatArg i x)) args))] |Just args <- [identDocArgDocs idoc]] ,[List [Atom "documentation",String (formatDoc (identDocDocs idoc))]]] - --- | Render the doc. -doc :: Doc String -> String -doc DocEmpty = "" -doc (DocAppend a b) = doc a ++ doc b -doc (DocString str) = normalize str -doc (DocParagraph p) = doc p ++ "\n" -doc (DocModule m) = m -doc (DocEmphasis e) = "*" ++ doc e ++ "*" -doc (DocMonospaced e) = "`" ++ doc e ++ "`" -doc (DocUnorderedList i) = unlines (map (("* " ++) . doc) i) -doc (DocOrderedList i) = unlines (zipWith (\j x -> show j ++ ". " ++ doc x) [1 :: Int ..] i) -doc (DocDefList xs) = unlines (map (\(i,x) -> doc i ++ ". " ++ doc x) xs) -doc (DocCodeBlock bl) = unlines (map (" " ++) (lines (doc bl))) ++ "\n" -doc (DocAName name) = name -doc (DocExamples exs) = unlines (map formatExample exs) - -#if MIN_VERSION_haddock(2,10,0) --- The header type is unexported, so this constructor is useless. -doc (DocIdentifier i) = i -doc (DocWarning d) = "Warning: " ++ doc d -#else -doc (DocPic pic) = pic -doc (DocIdentifier i) = intercalate "." i -#endif - -#if MIN_VERSION_haddock(2,11,0) -doc (DocIdentifierUnchecked (mname,occname)) = - moduleNameString mname ++ "." ++ occNameString occname -doc (DocPic pic) = show pic -#endif - -#if MIN_VERSION_haddock(2,13,0) -doc (DocHyperlink (Hyperlink url label)) = maybe url (\l -> l ++ "[" ++ url ++ "]") label -doc (DocProperty p) = "Property: " ++ p -#else -doc (DocURL url) = url -#endif - -#if MIN_VERSION_haddock(2,14,0) -doc (DocBold d) = "**" ++ doc d ++ "**" -doc (DocHeader _) = "" -#endif - --- | Strip redundant whitespace. -normalize :: [Char] -> [Char] -normalize = go where - go (' ':' ':cs) = go (' ':cs) - go (c:cs) = c : go cs - go [] = [] - --- | Trim either side of a string. -trim :: [Char] -> [Char] -trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace - --- | Format an example to plain text. -formatExample :: Example -> String -formatExample (Example expression result) = - " > " ++ expression ++ - unlines (map (" " ++) result) -- | Format an argument. formatArg :: Show a => a -> Doc String -> String diff --git a/src/Haskell/Docs/Haddock.hs b/src/Haskell/Docs/Haddock.hs --- a/src/Haskell/Docs/Haddock.hs +++ b/src/Haskell/Docs/Haddock.hs @@ -10,6 +10,7 @@ module Haskell.Docs.Haddock where import Haskell.Docs.Cabal +import Haskell.Docs.HaddockDoc import Haskell.Docs.Ghc import Haskell.Docs.Types @@ -37,7 +38,7 @@ -> Identifier -> Ghc (Either DocsException [IdentDoc]) searchIdent gs mprevious name = - do packages <- fmap (filterPrevious mprevious) (liftIO $ getAllPackages gs) + do packages <- fmap (filterPrevious mprevious) (getAllPackages gs) searchInPackages packages Nothing name @@ -148,32 +149,6 @@ d mi margs]) - --- * Get documentation of parts of things - --- | Get a mapping from names to doc string of that name from a --- Haddock interface. -interfaceNameMap :: InstalledInterface -> Map String (Doc String) -#if MIN_VERSION_haddock(2,10,0) -interfaceNameMap iface = - M.fromList (map (second (fmap getOccString) . first getOccString) - (M.toList (instDocMap iface))) -#else -interfaceNameMap iface = - M.fromList (map (second (fmap getOccString . maybe DocEmpty id . fst) . first getOccString) - (M.toList (instDocMap iface))) -#endif - --- | Get a mapping from names to doc string of that name from a --- Haddock interface. -interfaceArgMap :: InstalledInterface -> Map String (Map Int (Doc Name)) -#if MIN_VERSION_haddock(2,10,0) -interfaceArgMap iface = - M.fromList (map (first getOccString) (M.toList (instArgMap iface))) -#else -interfaceArgMap iface = M.fromList (map (second (const M.empty) . first getOccString) - (M.toList (instDocMap iface))) -#endif -- | Find arguments documentation for the identifier. lookupArgsDocs :: InstalledInterface -> Identifier -> Ghc (Maybe [(Int, Doc String)]) diff --git a/src/Haskell/Docs/Index.hs b/src/Haskell/Docs/Index.hs --- a/src/Haskell/Docs/Index.hs +++ b/src/Haskell/Docs/Index.hs @@ -12,8 +12,11 @@ import Control.Exception as E import Control.Monad +import qualified Crypto.Hash.SHA1 as SHA1 import Data.ByteString (ByteString) import qualified Data.ByteString as S +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Lazy as L import Data.Char @@ -34,8 +37,10 @@ import PackageConfig import Prelude import System.Directory +import System.Environment import System.FilePath import System.IO +import System.Process -- * Looking up identifiers @@ -46,7 +51,8 @@ -> IO (Maybe (HashMap Text [Text])) lookupIdent flags ident = do d <- getTemporaryDirectory - exists <- doesFileExist (d indexFilename) + fp <- getIndexFilename + exists <- doesFileExist (d fp) if exists then lookupInIndex ident else do generateIndex flags >>= saveIndex @@ -77,7 +83,6 @@ flags (do flags <- getSessionDynFlags return (fromMaybe [] (pkgDatabase flags))) - {-packages <- getAllPackages-} fmap (concat . map explode . concat) (forM packages (\package -> @@ -100,6 +105,7 @@ saveIndex :: Index -> IO () saveIndex i = do d <- getTemporaryDirectory + indexFilename <- getIndexFilename L.writeFile (d indexFilename) mempty h <- openFile (d indexFilename) AppendMode forM_ (M.toList i) @@ -108,8 +114,10 @@ where (<>) = mappend -- | Filename to read/write index to. -indexFilename :: FilePath -indexFilename = "haskell-docs-idents.index" +getIndexFilename :: IO FilePath +getIndexFilename = + do flags <- getPkgFlags + return ("haskell-docs-" ++ sha1 flags ++ ".index") -- * Internally looking up inside indexes @@ -119,6 +127,7 @@ -> IO (Maybe (HashMap Text [Text])) lookupInIndex (T.encodeUtf8 -> ident) = do d <- getTemporaryDirectory + indexFilename <- getIndexFilename h <- openFile (d indexFilename) ReadMode E.catch (fix (\loop -> @@ -138,3 +147,17 @@ [package,modu] -> Just (package,modu) _ -> Nothing ins m (pkg,modu) = M.insertWith (++) pkg [modu] m + +-- | SHA1 hex-encode a string. +sha1 :: String -> String +sha1 = S8.unpack . B16.encode . SHA1.hash . S8.pack + +-- | Get unique package flags string. +getPkgFlags :: IO String +getPkgFlags = + do env <- getEnvironment + case lookup "HSENV" env >> lookup "PACKAGE_DB_FOR_GHC" env of + Just uflags -> return uflags + Nothing -> case lookup "GHC_PACKAGE_PATH" env of + Just path -> return ("-no-user-pg-db" ++ "-pkg-db=" ++ path) + Nothing -> readProcess "ghc-pkg" ["--version"] "" diff --git a/src/haddock-api/Haskell/Docs/HaddockDoc.hs b/src/haddock-api/Haskell/Docs/HaddockDoc.hs new file mode 100644 --- /dev/null +++ b/src/haddock-api/Haskell/Docs/HaddockDoc.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE CPP #-} + +-- | Post-haddock-api. + +module Haskell.Docs.HaddockDoc where + +import Control.Arrow +import Control.Exception (try,IOException) +import Control.Monad +import Control.Monad +import Data.Char +import Data.Either +import Data.Function +import Data.List +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Documentation.Haddock +import Documentation.Haddock +import GHC hiding (verbosity) +import GHC hiding (verbosity) +import GhcMonad (liftIO) +import GhcMonad (liftIO) +import Haskell.Docs.Cabal +import Haskell.Docs.Ghc +import Haskell.Docs.Ghc +import Haskell.Docs.Types +import Haskell.Docs.Types +import Name +import Name +import PackageConfig +import Packages + +-- | Render the doc. +doc :: Doc String -> String +doc DocEmpty = "" +doc (DocAppend a b) = doc a ++ doc b +doc (DocString str) = normalize str +doc (DocParagraph p) = doc p ++ "\n" +doc (DocModule m) = m +doc (DocEmphasis e) = "*" ++ doc e ++ "*" +doc (DocMonospaced e) = "`" ++ doc e ++ "`" +doc (DocUnorderedList i) = unlines (map (("* " ++) . doc) i) +doc (DocOrderedList i) = unlines (zipWith (\j x -> show j ++ ". " ++ doc x) [1 :: Int ..] i) +doc (DocDefList xs) = unlines (map (\(i,x) -> doc i ++ ". " ++ doc x) xs) +doc (DocCodeBlock bl) = unlines (map (" " ++) (lines (doc bl))) ++ "\n" +doc (DocAName name) = name +doc (DocExamples exs) = unlines (map formatExample exs) + +#if MIN_VERSION_haddock_api(2,10,0) +-- The header type is unexported, so this constructor is useless. +doc (DocIdentifier i) = i +doc (DocWarning d) = "Warning: " ++ doc d +#else +doc (DocPic pic) = pic +doc (DocIdentifier i) = intercalate "." i +#endif + +#if MIN_VERSION_haddock_api(2,11,0) +doc (DocIdentifierUnchecked (mname,occname)) = + moduleNameString mname ++ "." ++ occNameString occname +doc (DocPic pic) = show pic +#endif + +#if MIN_VERSION_haddock_api(2,13,0) +doc (DocHyperlink (Hyperlink url label)) = maybe url (\l -> l ++ "[" ++ url ++ "]") label +doc (DocProperty p) = "Property: " ++ p +#else +doc (DocURL url) = url +#endif + +#if MIN_VERSION_haddock_api(2,14,0) +doc (DocBold d) = "**" ++ doc d ++ "**" +doc (DocHeader _) = "" +#endif + +-- * Get documentation of parts of things + +-- | Get a mapping from names to doc string of that name from a +-- Haddock interface. +interfaceNameMap :: InstalledInterface -> Map String (Doc String) +#if MIN_VERSION_haddock_api(2,10,0) +interfaceNameMap iface = + M.fromList (map (second (fmap getOccString) . first getOccString) + (M.toList (instDocMap iface))) +#else +interfaceNameMap iface = + M.fromList (map (second (fmap getOccString . maybe DocEmpty id . fst) . first getOccString) + (M.toList (instDocMap iface))) +#endif + +-- | Get a mapping from names to doc string of that name from a +-- Haddock interface. +interfaceArgMap :: InstalledInterface -> Map String (Map Int (Doc Name)) +#if MIN_VERSION_haddock_api(2,10,0) +interfaceArgMap iface = + M.fromList (map (first getOccString) (M.toList (instArgMap iface))) +#else +interfaceArgMap iface = M.fromList (map (second (const M.empty) . first getOccString) + (M.toList (instDocMap iface))) +#endif + +-- | Strip redundant whitespace. +normalize :: [Char] -> [Char] +normalize = go where + go (' ':' ':cs) = go (' ':cs) + go (c:cs) = c : go cs + go [] = [] + +-- | Trim either side of a string. +trim :: [Char] -> [Char] +trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +-- | Format an example to plain text. +formatExample :: Example -> String +formatExample (Example expression result) = + " > " ++ expression ++ + unlines (map (" " ++) result)