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.1 +version: 4.2.2 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. diff --git a/src/Haskell/Docs.hs b/src/Haskell/Docs.hs --- a/src/Haskell/Docs.hs +++ b/src/Haskell/Docs.hs @@ -26,18 +26,17 @@ import qualified Data.Text.IO as T import GHC hiding (verbosity) import MonadUtils -import Packages -- -- | Print the documentation of a name in the given module. -searchAndPrintDoc' - :: PackageConfigMap -- ^ Package map. +searchAndPrintDoc + :: [String] -- ^ GHC Options -> Bool -- ^ Print modules only. -> Bool -- ^ S-expression format. -> Maybe PackageName -- ^ Package. -> Maybe ModuleName -- ^ Module name. -> Identifier -- ^ Identifier. -> Ghc () -searchAndPrintDoc' pkgs ms ss pname mname ident = +searchAndPrintDoc gs ms ss pname mname ident = do (result,printPkg,printModule) <- search case result of Left err -> @@ -54,33 +53,15 @@ 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 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 + _ -> fmap (,True,True) (searchIdent gs Nothing ident) -searchAndPrintModules :: MonadIO m => Identifier -> m () -searchAndPrintModules ident = - do result <- liftIO (lookupIdent (pack (unIdentifier ident))) +-- | Search only for identifiers and print out all modules associated. +searchAndPrintModules :: [String] -> Identifier -> IO () +searchAndPrintModules flags ident = + do result <- lookupIdent flags (pack (unIdentifier ident)) case result of Nothing -> throw NoFindModule Just packages -> forM_ (nub (concat (map snd (M.toList packages)))) - (\modu -> liftIO (T.putStrLn modu)) + T.putStrLn 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 @@ -7,6 +7,7 @@ import Haskell.Docs.Ghc +import Data.Char (isSpace) import Data.List import Distribution.InstalledPackageInfo import Distribution.ModuleName @@ -20,16 +21,22 @@ -- * Cabal +getGhcOpsPackageDB :: [String] -> [PackageDB] +getGhcOpsPackageDB gs = map (SpecificPackageDB . trim) pkgDBOps + where + pkgDBOps = filter ("--package-db" `isPrefixOf`) gs + trim = (drop 1) . snd . (break isSpace) + -- | Get all installed packages, filtering out the given package. -getAllPackages :: IO [PackageConfig] -getAllPackages = +getAllPackages :: [String] -> IO [PackageConfig] +getAllPackages gs = do config <- configureAllKnownPrograms normal (addKnownPrograms [ghcProgram,ghcPkgProgram] emptyProgramConfiguration) index <- getInstalledPackages normal - [GlobalPackageDB,UserPackageDB] + (concat [[GlobalPackageDB,UserPackageDB],getGhcOpsPackageDB gs]) config return (map (imap convModule) (concat (packagesByName index))) 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 @@ -27,14 +27,15 @@ -- * GHC actions -- | Run an action with an initialized GHC package set. -withInitializedPackages :: [String] -> (PackageConfigMap -> Ghc a) -> IO a +withInitializedPackages :: [String] -> 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 (pkgIdMap (pkgState dflags''))) + _ <- setSessionDynFlags dflags'' + m) -- | 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 @@ -32,11 +32,12 @@ -- | Search a name in the given module. searchIdent - :: Maybe PackageConfig + :: [String] + -> Maybe PackageConfig -> Identifier -> Ghc (Either DocsException [IdentDoc]) -searchIdent mprevious name = - do packages <- fmap (filterPrevious mprevious) (liftIO getAllPackages) +searchIdent gs mprevious name = + do packages <- fmap (filterPrevious mprevious) (liftIO $ getAllPackages gs) searchInPackages packages Nothing name 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 @@ -7,6 +7,9 @@ module Haskell.Docs.Index where +import Haskell.Docs.Ghc +import Haskell.Docs.Haddock + import Control.Exception as E import Control.Monad import Data.ByteString (ByteString) @@ -27,11 +30,9 @@ 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 Prelude import System.Directory import System.FilePath import System.IO @@ -40,14 +41,15 @@ -- | Lookup an identifier. Automatically creates an index if none -- exists. -lookupIdent :: Text +lookupIdent :: [String] + -> Text -> IO (Maybe (HashMap Text [Text])) -lookupIdent ident = +lookupIdent flags ident = do d <- getTemporaryDirectory exists <- doesFileExist (d indexFilename) if exists then lookupInIndex ident - else do generateIndex >>= saveIndex + else do generateIndex flags >>= saveIndex lookupInIndex ident -- * Internally generating indexes @@ -56,9 +58,9 @@ type Index = HashMap Text Text -- | Generate an identifier index. -generateIndex :: IO Index -generateIndex = - do flatfile <- generateFlatFile +generateIndex :: [String] -> IO Index +generateIndex flags = + do flatfile <- generateFlatFile flags evaluate (foldl' (\m (pkg,modu,name) -> M.insertWith (\x y -> x <> " " <> y) @@ -69,9 +71,13 @@ where (<>) = mappend -- | Generate a flat file of all package, module, name combinations. -generateFlatFile :: IO [(String, String, String)] -generateFlatFile = - do packages <- getAllPackages +generateFlatFile :: [String] -> IO [(String, String, String)] +generateFlatFile flags = + do packages <- withInitializedPackages + flags + (do flags <- getSessionDynFlags + return (fromMaybe [] (pkgDatabase flags))) + {-packages <- getAllPackages-} fmap (concat . map explode . concat) (forM packages (\package -> @@ -79,7 +85,9 @@ return (concat (map (map (\iface -> - (sourcePackageId package,instMod iface,instExports iface)) . + (sourcePackageId package + ,instMod iface + ,instVisibleExports iface)) . ifInstalledIfaces) (rights files))))) where explode (pkg,modu,names) = @@ -101,7 +109,7 @@ -- | Filename to read/write index to. indexFilename :: FilePath -indexFilename = "haskell-docs-indents.index" +indexFilename = "haskell-docs-idents.index" -- * Internally looking up inside indexes diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -14,8 +14,10 @@ import Data.Monoid import Data.Text (unpack) import Data.Typeable +import Exception import GHC import GhcMonad +import MonadUtils import System.Environment import System.Exit import System.IO @@ -30,41 +32,41 @@ app :: [String] -> IO () app (extract -> x@(gs,ms,as,ss)) = do if ms - then case as of - [name] -> searchAndPrintModules (Identifier name) - [_,name,_] -> searchAndPrintModules (Identifier name) - [_,name] -> searchAndPrintModules (Identifier name) + then catchErrors + (case as of + [name] -> searchAndPrintModules gs (Identifier name) + [_,name,_] -> searchAndPrintModules gs (Identifier name) + [_,name] -> searchAndPrintModules gs (Identifier name)) else withInitializedPackages gs - (\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." )) + (catchErrors + (case as of + [name] -> + searchAndPrintDoc gs + ms + ss + Nothing + Nothing + (Identifier name) + [mname,name,pname] -> + searchAndPrintDoc gs + ms + ss + (Just (PackageName pname)) + (Just (makeModuleName mname)) + (Identifier name) + [mname,name] -> + searchAndPrintDoc gs + 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) @@ -77,7 +79,7 @@ go (gs,ms,as,ss) [] = (gs,ms,reverse as,ss) -- | Catch errors and print 'em out. -catchErrors :: Ghc () -> Ghc () +catchErrors :: (MonadIO m,ExceptionMonad m) => m () -> m () catchErrors m = gcatch m @@ -90,7 +92,7 @@ bail ("Exception: " ++ show e ++ " :: " ++ show (typeOf e) ++ "")) -- | Print an error and bail out. -bail :: String -> Ghc () +bail :: MonadIO m => String -> m () bail e = liftIO (hPutStrLn stderr e) 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 [] (const (return ()))) + (withInitializedPackages [] (return ())) -- | Test GHC docs. docs :: IO () @@ -34,25 +34,23 @@ do it "printDocumentation" (withInitializedPackages [] - (\pkgs -> - void (searchAndPrintDoc - pkgs - False - False - Nothing - (Just (makeModuleName "System.IO")) - (Identifier "hSetBuffering")))) + (searchAndPrintDoc + [] + False + False + Nothing + (Just (makeModuleName "System.IO")) + (Identifier "hSetBuffering"))) it "justIdentifier" (withInitializedPackages [] - (\pkgs -> - void (searchAndPrintDoc - pkgs - False - False - Nothing - Nothing - (Identifier "hSetBuffering")))) + ((searchAndPrintDoc + [] + False + False + Nothing + Nothing + (Identifier "hSetBuffering")))) -- | Test GHC types. types :: IO () @@ -60,16 +58,15 @@ do it "getType" (withInitializedPackages [] - (\pkgs -> - do void (searchAndPrintDoc - pkgs - False - False - Nothing - (Just (makeModuleName "System.IO")) - (Identifier "hSetBuffering")) - void (findIdentifier (makeModuleName "System.IO") - (Identifier "hSetBuffering")))) + (do void (searchAndPrintDoc + [] + False + False + Nothing + (Just (makeModuleName "System.IO")) + (Identifier "hSetBuffering")) + void (findIdentifier (makeModuleName "System.IO") + (Identifier "hSetBuffering")))) -- | Describe a test spec. describe :: String -> IO () -> IO ()