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.0.0 +version: 4.1.0 synopsis: A program to find and display the docs of a name from a given module. description: Given a module name and a name, it will find and display @@ -53,18 +53,20 @@ Bug-Reports: http://github.com/chrisdone/haskell-docs/issues library + ghc-options: -O2 -Wall hs-source-dirs: src exposed-modules: Haskell.Docs, Haskell.Docs.Ghc, + Haskell.Docs.Cabal, Haskell.Docs.Formatting, Haskell.Docs.Haddock, Haskell.Docs.Types build-depends: base > 4 && < 5, ghc >= 7.2 && < 7.9, + Cabal, ghc-paths, containers, - monad-loops, - optparse-applicative + monad-loops if impl(ghc==7.8.*) build-depends: haddock==2.14.* if impl(ghc==7.6.*) @@ -83,8 +85,7 @@ hs-source-dirs: src/main main-is: Main.hs build-depends: base > 4 && < 5, - haskell-docs, - optparse-applicative + haskell-docs test-suite test type: exitcode-stdio-1.0 diff --git a/src/Haskell/Docs.hs b/src/Haskell/Docs.hs --- a/src/Haskell/Docs.hs +++ b/src/Haskell/Docs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} -- | Lookup the documentation of a name in a module (and in a specific -- package in the case of ambiguity). @@ -7,6 +8,8 @@ ,PackageName(..)) where +import Control.Monad +import Data.List import Haskell.Docs.Formatting import Haskell.Docs.Haddock import Haskell.Docs.Types @@ -16,15 +19,24 @@ import System.IO -- -- | Print the documentation of a name in the given module. -printDocForIdentInModule +searchAndPrintDoc :: Maybe PackageName -- ^ Package. - -> ModuleName -- ^ Module name. + -> Maybe ModuleName -- ^ Module name. -> Identifier -- ^ Identifier. -> Ghc () -printDocForIdentInModule pname mname name = - do result <- search Nothing pname mname name +searchAndPrintDoc pname mname ident = + do (result,printPkg,printModule) <- search case result of Left err -> error (show err) Right docs -> - mapM_ printIdentDoc docs + mapM_ (\(i,doc) -> do when (i > 0) + (liftIO (putStrLn "")) + printIdentDoc printPkg printModule doc) + (zip [0..] (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) + (Nothing,Nothing) -> fmap (,True,True) (searchIdent Nothing ident) + _ -> error "arguments: | []" diff --git a/src/Haskell/Docs/Cabal.hs b/src/Haskell/Docs/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Haskell/Docs/Cabal.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Cabal. + +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 +import Distribution.Simple.Program +import Distribution.Verbosity +import Module +import PackageConfig + +-- * Cabal + +-- | Get all installed packages, filtering out the given package. +getAllPackages :: IO [PackageConfig] +getAllPackages = + do config <- configureAllKnownPrograms + normal + (addKnownPrograms [ghcProgram,ghcPkgProgram] + emptyProgramConfiguration) + index <- getInstalledPackages + normal + [GlobalPackageDB,UserPackageDB] + config + return (map (imap convModule) + (concat (packagesByName index))) + +-- | Version-portable version of allPackagesByName. +packagesByName :: PackageIndex -> [[InstalledPackageInfo]] +#if MIN_VERSION_Cabal(1,16,0) +packagesByName = map snd . allPackagesByName +#else +packagesByName = allPackagesByName +#endif + +-- * Internal modules + +-- | Convert a Cabal module name to a GHC module name. +convModule :: Distribution.ModuleName.ModuleName -> Module.ModuleName +convModule = makeModuleName . intercalate "." . components + +-- | Because no Functor instance is available. +imap :: (a -> m) -> InstalledPackageInfo_ a -> InstalledPackageInfo_ m +imap f i@(InstalledPackageInfo{..}) = + i { exposedModules = map f exposedModules + , hiddenModules = map f hiddenModules } 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 @@ -7,6 +7,7 @@ import Haskell.Docs.Types import Haskell.Docs.Ghc +import Control.Monad import Data.Char import Data.List import Documentation.Haddock @@ -17,10 +18,19 @@ -- * Formatting -- | Print an identifier' documentation. -printIdentDoc :: IdentDoc -> Ghc () -printIdentDoc idoc = +printIdentDoc :: Bool -- ^ Print package? + -> Bool -- ^ Print module? + -> IdentDoc + -> Ghc () +printIdentDoc printPkg printModule idoc = do d <- getSessionDynFlags - liftIO (putStrLn ("Package: " ++ showPackageName (identDocPackageName idoc))) + when printPkg + (liftIO (putStrLn ("Package: " ++ showPackageName (identDocPackageName idoc)))) + when printModule + (maybe (return ()) + (\i -> liftIO (putStrLn ("Module: " ++ + showppr d (moduleName (nameModule (getName i)))))) + (identDocIdent idoc)) case identDocIdent idoc of Nothing -> return () Just i -> liftIO (putStrLn (showppr d i ++ " :: " ++ showppr d (idType i))) 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# OPTIONS -Wall -fno-warn-missing-signatures #-} @@ -5,6 +6,7 @@ module Haskell.Docs.Ghc where +import Control.Exception (SomeException) import Haskell.Docs.Types import GHC hiding (verbosity) @@ -37,14 +39,15 @@ -- | Get the type of the given identifier from the given module. findIdentifier :: ModuleName -> Identifier -> Ghc (Maybe Id) findIdentifier mname name = - do _ <- depanal [] False - _ <- load LoadAllTargets - setImportContext mname - names <- getNamesInScope - mty <- lookupName (head (filter ((==unIdentifier name).getOccString) names)) - case mty of - Just (AnId i) -> return (Just i) - _ -> return Nothing + gcatch (do _ <- depanal [] False + _ <- load LoadAllTargets + setImportContext mname + names <- getNamesInScope + mty <- lookupName (head (filter ((==unIdentifier name).getOccString) names)) + case mty of + Just (AnId i) -> return (Just i) + _ -> return Nothing) + (\(_ :: SomeException) -> return Nothing) -- | Make a module name. makeModuleName :: String -> ModuleName 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} @@ -8,12 +9,15 @@ module Haskell.Docs.Haddock where +import Haskell.Docs.Cabal import Haskell.Docs.Ghc import Haskell.Docs.Types import Control.Arrow +import Control.Exception (try,IOException) import Control.Monad import Data.Either +import Data.Function import Data.List import Data.Map (Map) import qualified Data.Map as M @@ -27,61 +31,99 @@ -- * Searching for ident docs -- | Search a name in the given module. -search :: Maybe PackageConfig - -> Maybe PackageName - -> ModuleName - -> Identifier - -> Ghc (Either DocsException [IdentDoc]) -search mprevious mpname mname name = do - result <- getPackagesByModule mname - case result of - Left{} -> - return (Left NoFindModule) - Right [package] -> - searchWithPackage package mname name - Right packages -> - case mpname of - Nothing -> do - fmap (Right . concat . rights) - (mapM (\package -> searchWithPackage package mname name) - (filter (not . isPrevious) packages)) - Just pname -> do - case find ((== pname) . PackageName . showPackageName . sourcePackageId) packages of - Nothing -> - return (Left NoModulePackageCombo) - Just package -> - searchWithPackage package mname name - where isPrevious m = - Just (sourcePackageId m) == fmap sourcePackageId mprevious +searchIdent + :: Maybe PackageConfig + -> Identifier + -> Ghc (Either DocsException [IdentDoc]) +searchIdent mprevious name = + do packages <- fmap (filterPrevious mprevious) (liftIO getAllPackages) + searchInPackages packages + Nothing + name +-- | Search a name in the given module. +searchModuleIdent + :: Maybe PackageConfig + -> ModuleName + -> Identifier + -> Ghc (Either DocsException [IdentDoc]) +searchModuleIdent mprevious mname name = + do result <- fmap (filterPrevious mprevious) (getPackagesByModule mname) + case result of + [] -> + return (Left NoFindModule) + [package] -> + searchWithPackage package (Just mname) name + packages -> + searchInPackages packages + (Just mname) + name + +-- | Search a name in the given module from the given package. +searchPackageModuleIdent + :: Maybe PackageConfig + -> PackageName + -> ModuleName + -> Identifier + -> Ghc (Either DocsException [IdentDoc]) +searchPackageModuleIdent mprevious pname mname name = + do result <- fmap (filterPrevious mprevious) (getPackagesByModule mname) + case result of + [] -> return (Left NoFindModule) + packages -> + case find ((== pname) . PackageName . showPackageName . sourcePackageId) packages of + Nothing -> + return (Left NoModulePackageCombo) + Just package -> + searchWithPackage package (Just mname) name + +filterPrevious exclude = + filter (maybe (const True) + (on (/=) sourcePackageId) + exclude) + +-- | Search for the identifier in a module in any of the given packages. +searchInPackages + :: [PackageConfig] + -> Maybe ModuleName + -> Identifier + -> Ghc (Either a [IdentDoc]) +searchInPackages packages mname name = + fmap (Right . concat . rights) + (mapM (\package -> searchWithPackage package mname name) + packages) + -- | Search for the given identifier in the given package. searchWithPackage :: PackageConfig - -> ModuleName + -> Maybe ModuleName -> Identifier -> Ghc (Either DocsException [IdentDoc]) -searchWithPackage package mname name = do - interfaceFiles <- getHaddockInterfacesByPackage package - case (lefts interfaceFiles,rights interfaceFiles) of - ([],[]) -> return (Left NoInterfaceFiles) - (errs@(_:_),_) -> return (Left (NoParseInterfaceFiles errs)) - (_,files) -> - fmap (Right . concat) - (forM files - (\interfaceFile -> - fmap (concat . rights) - (mapM (searchWithInterface package mname name) - (filter ((==mname) . moduleName . instMod) - (ifInstalledIfaces interfaceFile))))) +searchWithPackage package mname name = + do interfaceFiles <- getHaddockInterfacesByPackage package + case (lefts interfaceFiles,rights interfaceFiles) of + ([],[]) -> + return (Left NoInterfaceFiles) + (errs@(_:_),_) -> + return (Left (NoParseInterfaceFiles errs)) + (_,files) -> + fmap (Right . concat) + (forM files + (\interfaceFile -> + fmap (concat . rights) + (mapM (searchWithInterface package name) + (filter (maybe (const True) + (\n -> (==n) . moduleName . instMod) + mname) + (ifInstalledIfaces interfaceFile))))) -- | Search for the given identifier in the interface. searchWithInterface :: PackageConfig - -> ModuleName -> Identifier -> InstalledInterface -> Ghc (Either DocsException [IdentDoc]) -searchWithInterface package mname name interface = +searchWithInterface package name interface = case find ((==name) . Identifier . getOccString) (instExports interface) of Nothing -> return (Left NoFindNameInExports) @@ -95,7 +137,7 @@ _ -> return (Left NoFindNameInInterface) Just d -> - do mi <- findIdentifier mname name + do mi <- findIdentifier (moduleName (instMod interface)) name margs <- lookupArgsDocs interface name return (Right @@ -141,18 +183,25 @@ -- * Querying for packages and interfaces -- | Search for a module's package, returning suggestions if not --- found. -getPackagesByModule :: ModuleName -> Ghc (Either [Module] [PackageConfig]) +-- found. Filters out the given value. +getPackagesByModule :: ModuleName -> Ghc [PackageConfig] getPackagesByModule m = do df <- getSessionDynFlags - return (fmap (map fst) (lookupModuleWithSuggestions df m)) + return (either (const []) + (map fst) + (lookupModuleWithSuggestions df m)) -- | Get the Haddock interfaces of the given package. getHaddockInterfacesByPackage :: PackageConfig -> Ghc [Either DocsException InterfaceFile] getHaddockInterfacesByPackage = liftIO . - mapM (fmap (either (Left . NoReadInterfaceFile) Right) . readInterfaceFile freshNameCache) . + mapM (fmap (either (Left . NoReadInterfaceFile) Right) . safelyReadFile freshNameCache) . haddockInterfaces + where safelyReadFile cache p = + do result <- try (readInterfaceFile cache p) + case result of + Left (_::IOException) -> return (Left "Couldn't read file.") + Right r -> return r -- * Internal functions @@ -161,4 +210,4 @@ -- restart our search process. descendSearch :: PackageConfig -> Identifier -> Name -> Ghc (Either DocsException [IdentDoc]) descendSearch package name qname = do - search (Just package) Nothing (moduleName (nameModule qname)) name + searchModuleIdent (Just package) (moduleName (nameModule qname)) name 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 @@ -13,6 +13,7 @@ import Data.Typeable (Typeable) import Documentation.Haddock (Doc) import GHC (Id) +import Module (ModuleName) import PackageConfig (PackageIdentifier) -- | An identifier. @@ -30,6 +31,9 @@ , identDocIdent :: !(Maybe Id) , identDocArgDocs :: !(Maybe [(Int, Doc String)]) } + +instance Eq IdentDoc where + a == b = identDocIdent a == identDocIdent b -- | An exception when doing lookups. data DocsException diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -1,31 +1,49 @@ -{-# OPTIONS -Wall #-} - -- | Main command-line interface. module Main where import Haskell.Docs +import Haskell.Docs.Types import Haskell.Docs.Ghc -import Options.Applicative +import qualified Control.Exception as E +import System.Environment -- | Main entry point. main :: IO () main = - do (mname, name, pname, ghcopts) <- execParser opts - withInitializedPackages - ghcopts - (printDocForIdentInModule (fmap PackageName pname) - (makeModuleName mname) - (Identifier name)) - where - opts = info (helper <*> p) fullDesc - p = (\a b c d -> (a, b, c, d)) - <$> pModuleName - <*> pName - <*> (optional pPackageName) - <*> pGhcOptions - pModuleName = argument str (metavar "") - pName = argument str (metavar "") - pPackageName = argument str (metavar "") - pGhcOptions = many $ strOption (long "ghc-options" `mappend` short 'g') + do args <- getArgs + E.catch + (app args) + (error . printEx) + +-- | Do the printing. +app :: [String] -> IO () +app args = + withInitializedPackages + [] + (case args of + [name] -> + searchAndPrintDoc Nothing Nothing (Identifier name) + [mname,name,pname] -> + searchAndPrintDoc (Just (PackageName pname)) + (Just (makeModuleName mname)) + (Identifier name) + [mname,name] -> + searchAndPrintDoc Nothing + (Just (makeModuleName mname)) + (Identifier name) + _ -> error " [] | ") + +-- | Print an exception for humans. +printEx :: DocsException -> String +printEx e = + case e of + NoFindModule -> "Couldn't find any packages with that module." + 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?" + NoParseInterfaceFiles reasons -> "Couldn't parse interface files: " ++ + unlines (map printEx reasons) + NoFindNameInExports -> "Couldn't find that name in an export list." + NoFindNameInInterface -> "Couldn't find name in interface." + NoReadInterfaceFile _ -> "Couldn't read the interface file." diff --git a/src/test/Main.hs b/src/test/Main.hs --- a/src/test/Main.hs +++ b/src/test/Main.hs @@ -34,10 +34,17 @@ do it "printDocumentation" (withInitializedPackages [] - (void (printDocForIdentInModule - Nothing - (makeModuleName "System.IO") - (Identifier "hSetBuffering")))) + (void (searchAndPrintDoc + Nothing + (Just (makeModuleName "System.IO")) + (Identifier "hSetBuffering")))) + it "justIdentifier" + (withInitializedPackages + [] + (void (searchAndPrintDoc + Nothing + Nothing + (Identifier "hSetBuffering")))) -- | Test GHC types. types :: IO () @@ -45,9 +52,9 @@ do it "getType" (withInitializedPackages [] - (do void (printDocForIdentInModule + (do void (searchAndPrintDoc Nothing - (makeModuleName "System.IO") + (Just (makeModuleName "System.IO")) (Identifier "hSetBuffering")) void (findIdentifier (makeModuleName "System.IO") (Identifier "hSetBuffering"))))