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.1.5 +version: 4.2.0 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. @@ -60,13 +60,21 @@ Haskell.Docs.Cabal, Haskell.Docs.Formatting, Haskell.Docs.Haddock, - Haskell.Docs.Types - build-depends: base > 4 && < 5, + Haskell.Docs.Types, + Haskell.Docs.Index + build-depends: text, + base > 4 && < 5, ghc >= 7.2 && < 7.9, Cabal, ghc-paths, containers, - monad-loops + monad-loops, + aeson, + filepath, + directory, + text, + unordered-containers, + bytestring if impl(ghc==7.8.*) build-depends: haddock==2.14.* if impl(ghc==7.6.*) @@ -84,7 +92,8 @@ executable haskell-docs hs-source-dirs: src/main main-is: Main.hs - build-depends: base > 4 && < 5, + build-depends: text, + base > 4 && < 5, haskell-docs, ghc diff --git a/src/Haskell/Docs.hs b/src/Haskell/Docs.hs --- a/src/Haskell/Docs.hs +++ b/src/Haskell/Docs.hs @@ -10,26 +10,35 @@ ,PackageName(..)) where -import Haskell.Docs.Formatting -import Haskell.Docs.Haddock -import Haskell.Docs.Types +import Haskell.Docs.Formatting +import Haskell.Docs.Haddock +import Haskell.Docs.Ghc +import Haskell.Docs.Index +import Haskell.Docs.Types -import Control.Exception -import Control.Monad -import Data.List -import Data.Ord -import GHC hiding (verbosity) -import GhcMonad (liftIO) +import Control.Arrow +import Control.Exception +import Control.Monad +import qualified Data.HashMap.Strict as M +import Data.List +import Data.Ord +import qualified Data.Text.IO as T +import Data.Text (pack,unpack) +import GHC hiding (verbosity) +import GhcMonad (liftIO) +import Module +import Packages -- -- | Print the documentation of a name in the given module. -searchAndPrintDoc - :: Bool -- ^ Print modules only. +searchAndPrintDoc' + :: PackageConfigMap -- ^ Package map. + -> Bool -- ^ Print modules only. -> Bool -- ^ S-expression format. -> Maybe PackageName -- ^ Package. -> Maybe ModuleName -- ^ Module name. -> Identifier -- ^ Identifier. -> Ghc () -searchAndPrintDoc ms ss pname mname ident = +searchAndPrintDoc' pkgs ms ss pname mname ident = do (result,printPkg,printModule) <- search case result of Left err -> @@ -47,3 +56,22 @@ (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 Nothing ident) + +searchAndPrintDoc + :: PackageConfigMap -- ^ Package map. + -> Bool -- ^ Print modules only. + -> Bool -- ^ S-expression format. + -> Maybe PackageName -- ^ Package. + -> Maybe ModuleName -- ^ Module name. + -> Identifier -- ^ Identifier. + -> Ghc () +searchAndPrintDoc packagemap ms ss pname mname ident = + do result <- liftIO (lookupIdent (pack (unIdentifier ident))) + case result of + Nothing -> + throw NoFindModule + Just packages -> + if ms + then forM_ (concat (map snd (M.toList packages))) + (\modu -> liftIO (T.putStrLn modu)) + else searchAndPrintDoc' packagemap ms ss pname mname ident 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 @@ -5,13 +5,11 @@ module Haskell.Docs.Cabal where -import Data.Function import Haskell.Docs.Ghc import Data.List import Distribution.InstalledPackageInfo import Distribution.ModuleName -import Distribution.Package import Distribution.Simple.Compiler import Distribution.Simple.GHC import Distribution.Simple.PackageIndex diff --git a/src/Haskell/Docs/Ghc.hs b/src/Haskell/Docs/Ghc.hs --- a/src/Haskell/Docs/Ghc.hs +++ b/src/Haskell/Docs/Ghc.hs @@ -6,17 +6,17 @@ module Haskell.Docs.Ghc where -import Control.Exception (SomeException) import Haskell.Docs.Types +import Control.Exception (SomeException) import GHC hiding (verbosity) import GHC.Paths (libdir) import GhcMonad (liftIO) +import Module +import Name import Outputable import Packages import qualified SrcLoc -import Name -import Module #if __GLASGOW_HASKELL__ < 706 import DynFlags (defaultLogAction) @@ -27,14 +27,14 @@ -- * GHC actions -- | Run an action with an initialized GHC package set. -withInitializedPackages :: [String] -> Ghc a -> IO a +withInitializedPackages :: [String] -> (PackageConfigMap -> Ghc a) -> IO a withInitializedPackages ghcopts m = run (do dflags <- getSessionDynFlags (dflags', _, _) <- parseDynamicFlags dflags (map SrcLoc.noLoc ghcopts) _ <- setSessionDynFlags (dflags' { hscTarget = HscInterpreted - , ghcLink = LinkInMemory }) - (_dflags'',_packageids) <- liftIO (initPackages dflags') - m) + , ghcLink = LinkInMemory }) + (dflags'',_packageids) <- liftIO (initPackages dflags') + m (pkgIdMap (pkgState dflags''))) -- | Get the type of the given identifier from the given module. findIdentifier :: ModuleName -> Identifier -> Ghc (Maybe Id) 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 @@ -100,7 +100,7 @@ -> Identifier -> Ghc (Either DocsException [IdentDoc]) searchWithPackage package mname name = - do interfaceFiles <- getHaddockInterfacesByPackage package + do interfaceFiles <- liftIO (getHaddockInterfacesByPackage package) case (lefts interfaceFiles,rights interfaceFiles) of ([],[]) -> return (Left NoInterfaceFiles) @@ -194,9 +194,8 @@ (lookupModuleWithSuggestions df m)) -- | Get the Haddock interfaces of the given package. -getHaddockInterfacesByPackage :: PackageConfig -> Ghc [Either DocsException InterfaceFile] +getHaddockInterfacesByPackage :: PackageConfig -> IO [Either DocsException InterfaceFile] getHaddockInterfacesByPackage = - liftIO . mapM (fmap (either (Left . NoReadInterfaceFile) Right) . safelyReadFile freshNameCache) . haddockInterfaces where safelyReadFile cache p = diff --git a/src/Haskell/Docs/Index.hs b/src/Haskell/Docs/Index.hs new file mode 100644 --- /dev/null +++ b/src/Haskell/Docs/Index.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Make an index from identifiers to modules. + +module Haskell.Docs.Index where + +import Control.Exception as E +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy as L +import Data.Char +import Data.Either +import Data.Function +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Text (Text,pack) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import Documentation.Haddock +import GHC hiding (verbosity) +import Haskell.Docs.Cabal +import Haskell.Docs.Ghc +import Haskell.Docs.Haddock +import Name +import PackageConfig +import System.Directory +import System.FilePath +import System.IO + +-- * Looking up identifiers + +-- | Lookup an identifier. Automatically creates an index if none +-- exists. +lookupIdent :: Text + -> IO (Maybe (HashMap Text [Text])) +lookupIdent ident = + do d <- getTemporaryDirectory + exists <- doesFileExist (d indexFilename) + if exists + then lookupInIndex ident + else do generateIndex >>= saveIndex + lookupInIndex ident + +-- * Internally generating indexes + +-- | An identifier index. +type Index = HashMap Text Text + +-- | Generate an identifier index. +generateIndex :: IO Index +generateIndex = + do flatfile <- generateFlatFile + evaluate + (foldl' (\m (pkg,modu,name) -> + M.insertWith (\x y -> x <> " " <> y) + (pack name) + (pack pkg <> ":" <> pack modu) m) + M.empty + flatfile) + where (<>) = mappend + +-- | Generate a flat file of all package, module, name combinations. +generateFlatFile :: IO [(String, String, String)] +generateFlatFile = + do packages <- getAllPackages + fmap (concat . map explode . concat) + (forM packages + (\package -> + do files <- getHaddockInterfacesByPackage package + return + (concat + (map (map (\iface -> + (sourcePackageId package,instMod iface,instExports iface)) . + ifInstalledIfaces) + (rights files))))) + where explode (pkg,modu,names) = + map (showPackageName pkg + ,moduleNameString (moduleName modu) + ,) + (map getOccString names) + +-- | Save the index to file. +saveIndex :: Index -> IO () +saveIndex i = + do d <- getTemporaryDirectory + L.writeFile (d indexFilename) mempty + h <- openFile (d indexFilename) AppendMode + forM_ (M.toList i) + (\(ident,modules) -> T.hPutStrLn h (ident <> " " <> modules)) + hClose h + where (<>) = mappend + +-- | Filename to read/write index to. +indexFilename :: FilePath +indexFilename = "haskell-docs-indents.index" + +-- * Internally looking up inside indexes + +-- | Lookup an entry in the index by identifier. +lookupInIndex + :: Text + -> IO (Maybe (HashMap Text [Text])) +lookupInIndex (T.encodeUtf8 -> ident) = + do d <- getTemporaryDirectory + h <- openFile (d indexFilename) ReadMode + E.catch + (fix (\loop -> + do line <- S.hGetLine h + if S.takeWhile (/= space) line == ident + then do hClose h + return (Just (extractModules (S.drop 1 (S.dropWhile (/= space) line)))) + else loop)) + (\(_ :: IOException) -> return Nothing) + where space = S.c2w ' ' + +-- | Extract the \"package:Module package:Module\" string into a map from package to modules. +extractModules :: ByteString -> HashMap Text [Text] +extractModules = foldl' ins mempty . mapMaybe unpair . chunks . T.decodeUtf8 + where chunks = T.split isSpace + unpair t = case T.split (==':') t of + [package,modu] -> Just (package,modu) + _ -> Nothing + ins m (pkg,modu) = M.insertWith (++) pkg [modu] m diff --git a/src/Haskell/Docs/Types.hs b/src/Haskell/Docs/Types.hs --- a/src/Haskell/Docs/Types.hs +++ b/src/Haskell/Docs/Types.hs @@ -10,6 +10,7 @@ where import Control.Exception (Exception) +import Data.Text (Text) import Data.Typeable (Typeable) import Documentation.Haddock (Doc) import GHC (Id) @@ -40,6 +41,7 @@ -- | An exception when doing lookups. data DocsException = NoFindModule + | PackageLookupFailed !Text | NoModulePackageCombo | NoInterfaceFiles | NoParseInterfaceFiles [DocsException] diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -11,6 +11,8 @@ import Control.Exception import Control.Exception (IOException) import qualified Control.Exception as E +import Data.Monoid +import Data.Text (unpack) import Data.Typeable import GHC import GhcMonad @@ -29,31 +31,35 @@ app (extract -> x@(gs,ms,as,ss)) = withInitializedPackages gs - (catchErrors - (case as of - [name] -> - searchAndPrintDoc ms - ss - Nothing - Nothing - (Identifier name) - [mname,name,pname] -> - searchAndPrintDoc ms - ss - (Just (PackageName pname)) - (Just (makeModuleName mname)) - (Identifier name) - [mname,name] -> - searchAndPrintDoc ms - ss - Nothing - (Just (makeModuleName mname)) - (Identifier name) - _ -> bail " [] | \n\ - \\n\ - \Options: --g Specify GHC options.\n\ - \ --sexp Output s-expressions.\n\ - \ --modules Only output modules.")) + (\packages -> + catchErrors + (case as of + [name] -> + searchAndPrintDoc packages + ms + ss + Nothing + Nothing + (Identifier name) + [mname,name,pname] -> + searchAndPrintDoc packages + ms + ss + (Just (PackageName pname)) + (Just (makeModuleName mname)) + (Identifier name) + [mname,name] -> + searchAndPrintDoc packages + ms + ss + Nothing + (Just (makeModuleName mname)) + (Identifier name) + _ -> bail " [] | \n\ + \\n\ + \Options: --g Specify GHC options.\n\ + \ --sexp Output s-expressions.\n\ + \ --modules Only output modules.")) -- | Extract arguments. extract :: [String] -> ([String],Bool,[String],Bool) @@ -88,6 +94,7 @@ printEx e = case e of NoFindModule -> "Couldn't find any packages with that module." + PackageLookupFailed t -> "Couldn't lookup the right package: " <> unpack t NoModulePackageCombo -> "Couldn't match a module with that package." NoInterfaceFiles -> "No interface files to search through! \ \Maybe you need to generate documentation for the package?" @@ -96,3 +103,4 @@ NoFindNameInExports -> "Couldn't find that name in an export list." NoFindNameInInterface -> "Couldn't find name in interface." NoReadInterfaceFile _ -> "Couldn't read the interface file." + where (<>) = mappend diff --git a/src/test/Main.hs b/src/test/Main.hs --- a/src/test/Main.hs +++ b/src/test/Main.hs @@ -26,7 +26,7 @@ initialization :: IO () initialization = do it "withInitializedPackages" - (withInitializedPackages [] (return ())) + (withInitializedPackages [] (const (return ()))) -- | Test GHC docs. docs :: IO () @@ -34,21 +34,25 @@ do it "printDocumentation" (withInitializedPackages [] - (void (searchAndPrintDoc - False - False - Nothing - (Just (makeModuleName "System.IO")) - (Identifier "hSetBuffering")))) + (\pkgs -> + void (searchAndPrintDoc + pkgs + False + False + Nothing + (Just (makeModuleName "System.IO")) + (Identifier "hSetBuffering")))) it "justIdentifier" (withInitializedPackages [] - (void (searchAndPrintDoc - False - False - Nothing - Nothing - (Identifier "hSetBuffering")))) + (\pkgs -> + void (searchAndPrintDoc + pkgs + False + False + Nothing + Nothing + (Identifier "hSetBuffering")))) -- | Test GHC types. types :: IO () @@ -56,14 +60,16 @@ do it "getType" (withInitializedPackages [] - (do void (searchAndPrintDoc - False - False - Nothing - (Just (makeModuleName "System.IO")) - (Identifier "hSetBuffering")) - void (findIdentifier (makeModuleName "System.IO") - (Identifier "hSetBuffering")))) + (\pkgs -> + do void (searchAndPrintDoc + pkgs + False + False + Nothing + (Just (makeModuleName "System.IO")) + (Identifier "hSetBuffering")) + void (findIdentifier (makeModuleName "System.IO") + (Identifier "hSetBuffering")))) -- | Describe a test spec. describe :: String -> IO () -> IO ()