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: 3.0.3 +version: 4.0.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 @@ -54,9 +54,13 @@ library hs-source-dirs: src - exposed-modules: Documentation.Haddock.Docs + exposed-modules: Haskell.Docs, + Haskell.Docs.Ghc, + Haskell.Docs.Formatting, + Haskell.Docs.Haddock, + Haskell.Docs.Types build-depends: base > 4 && < 5, - ghc > 7.2 && < 7.9, + ghc >= 7.2 && < 7.9, ghc-paths, containers, monad-loops, @@ -79,7 +83,6 @@ hs-source-dirs: src/main main-is: Main.hs build-depends: base > 4 && < 5, - ghc > 7.2 && < 7.9, haskell-docs, optparse-applicative diff --git a/src/Documentation/Haddock/Docs.hs b/src/Documentation/Haddock/Docs.hs deleted file mode 100644 --- a/src/Documentation/Haddock/Docs.hs +++ /dev/null @@ -1,320 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS -Wall -fno-warn-missing-signatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving #-} - --- | Lookup the documentation of a name in a module (and in a specific --- package in the case of ambiguity). - -module Documentation.Haddock.Docs - (withInitializedPackages - ,printDocumentation - ,mkModuleName - ,getType) - where - -import Control.Arrow -import Control.Exception -import Control.Monad -import Control.Monad.Loops -import Data.Char -import Data.Either -import Data.List -import Data.Map (Map) -import qualified Data.Map as M -import Data.Typeable -import Documentation.Haddock -import GHC hiding (verbosity) -import GHC.Paths (libdir) -import GhcMonad (liftIO) -import Module -import Name -import Outputable -import PackageConfig -import Packages -import qualified SrcLoc - -#if __GLASGOW_HASKELL__ < 706 -import DynFlags (defaultLogAction) -#else -import DynFlags (defaultFlushOut, defaultFatalMessager) -#endif - -data DocsException - = Couldn'tFindModule - deriving (Typeable,Show) -instance Exception DocsException - --- | Print documentation with an initialized package set. -printDocumentationInitialized :: String -> ModuleName -> Maybe String -> [String] -> IO Bool -printDocumentationInitialized x y z ghcopts = - withInitializedPackages ghcopts $ \d -> - printDocumentation d x y z Nothing - --- | Print the documentation of a name in the given module. -printDocumentation :: DynFlags -> String -> ModuleName -> Maybe String -> Maybe PackageConfig -> Ghc Bool -printDocumentation d name mname mpname previous = do - result <- liftIO (getPackagesByModule d mname) - case result of - Left _suggestions -> error "Couldn't find that module. Suggestions are forthcoming." - Right [package] -> printWithPackage d False name mname package - Right packages -> - case mpname of - Nothing -> do - liftIO (putStrLn $ "Ambiguous module, belongs to more than one package: " ++ - unwords (map (showPackageName . sourcePackageId) packages) ++ - "\nContinuing anyway... ") - anyM (printWithPackage d True name mname) (filter (not . isPrevious) packages) - Just pname -> do - case find ((== pname) . showPackageName . sourcePackageId) packages of - Nothing -> error "Unable to find that module/package combination." - Just package -> printWithPackage d False name mname package - - where isPrevious m = Just (sourcePackageId m) == fmap sourcePackageId previous - --- | Show the package name e.g. base. -showPackageName :: PackageIdentifier -> String -showPackageName = packageIdString . mkPackageId - --- | Print the documentation with the given package. -printWithPackage :: DynFlags -> Bool -> String -> ModuleName -> PackageConfig -> Ghc Bool -printWithPackage d printPackage name mname package = do - interfaceFiles <- liftIO (getHaddockInterfacesByPackage package) - case (lefts interfaceFiles,rights interfaceFiles) of - ([],[]) -> error "Found no interface files." - (errs@(_:_),_) -> error $ "Couldn't parse interface file(s): " ++ unlines errs - (_,files) -> - flip anyM files $ \interfaceFile -> - case filter ((==mname) . moduleName . instMod) (ifInstalledIfaces interfaceFile) of - [] -> error "Couldn't find an interface for that module in the package description." - interfaces -> anyM (printWithInterface d printPackage package name mname) interfaces - --- | Print the documentation from the given interface. -printWithInterface :: DynFlags -> Bool -> PackageConfig -> String -> ModuleName -> InstalledInterface - -> Ghc Bool -printWithInterface df printPackage package name mname interface = do - case find ((==name).getOccString) (instExports interface) of - Nothing -> bail - Just{} -> - case M.lookup name docMap of - Nothing -> do - case lookup name (map (getOccString &&& id) (instExports interface)) of - Just subname - | moduleName (nameModule subname) /= moduleName (instMod interface) -> - descendSearch df name subname package - _ -> bail - Just d -> - do liftIO (when printPackage $ - putStrLn $ "Package: " ++ showPackageName (sourcePackageId package)) - printType df mname name - liftIO (putStrLn (formatDoc d)) - printArgs interface name - return True - - where docMap = interfaceNameMap interface - bail = do - liftIO (putStrLn $ "Couldn't find name ``" ++ name ++ "'' in Haddock interface: " ++ - moduleNameString (moduleName (instMod interface))) - return False - --- | Print the type of the given identifier from the given module. -printType :: DynFlags -> ModuleName -> String -> Ghc () -printType d mname name = - do _ <- depanal [] False - _ <- load LoadAllTargets - portableSetContext mname - names <- getNamesInScope - mty <- lookupName (head (filter ((==name).getOccString) names)) - case mty of - Just (AnId i) -> liftIO (do putStr (showppr d i ++ " :: ") - putStrLn (showppr d (idType i))) - _ -> liftIO (putStrLn "Unable to find type for identifier.") - - --- | Get the type of the given identifier from the given module. -getType :: DynFlags -> ModuleName -> String -> Ghc String -getType d mname name = - do _ <- depanal [] False - _ <- load LoadAllTargets - portableSetContext mname - names <- getNamesInScope - mty <- lookupName (head (filter ((==name).getOccString) names)) - case mty of - Just (AnId i) -> return (showppr d (idType i)) - _ -> error "Unable to find type for identifier." - --- | Set the import context. -portableSetContext :: ModuleName -> Ghc () -#if __GLASGOW_HASKELL__ == 702 -portableSetContext mname = setContext [] [simpleImportDecl mname] -#else -portableSetContext mname = setContext [IIDecl (simpleImportDecl mname)] -#endif - --- | Print the documentation of the arguments. -printArgs :: InstalledInterface -> String -> Ghc () -printArgs interface name = do - case M.lookup name (interfaceArgMap interface) of - Nothing -> return () - Just argMap -> - liftIO (putStr $ unlines - $ map (\(i,x) -> formatArg i x) - (map (second (fmap getOccString)) (M.toList argMap))) - - where formatArg i x = prefix ++ - indentAfter (length prefix) (formatDoc x) - where prefix = show i ++ ": " - --- | Indent after the first line. -indentAfter :: Int -> String -> String -indentAfter i xs = intercalate "\n" (take 1 l ++ map (replicate (i-1) ' ' ++) (drop 1 l)) - where l = lines xs - --- | The module symbol doesn't actually exist in the module we --- intended, so we descend into the module that it does exist in and --- restart our search process. -descendSearch :: DynFlags -> String -> Name -> PackageConfig -> Ghc Bool -descendSearch d name qname package = do - printDocumentation d name (moduleName (nameModule qname)) Nothing (Just package) - --------------------------------------------------------------------------------- --- Printing documentation - --- | Format some documentation to plain text. -formatDoc :: Doc String -> String -formatDoc = trim . doc where - --- | 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 block) = unlines (map (" " ++) (lines (doc block))) ++ "\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 - -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) - --------------------------------------------------------------------------------- --- Package querying functions - --- | 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 --- | Search for a module's package, returning suggestions if not --- found. -getPackagesByModule :: DynFlags -> ModuleName -> IO (Either [Module] [PackageConfig]) -getPackagesByModule d m = - return (fmap (map fst) (lookupModuleWithSuggestions d m)) - --- | Get the Haddock interfaces of the given package. -getHaddockInterfacesByPackage :: PackageConfig -> IO [Either String InterfaceFile] -getHaddockInterfacesByPackage = - mapM (readInterfaceFile freshNameCache) . haddockInterfaces - --- | Run an action with an initialized GHC package set. -withInitializedPackages :: [String] -> (DynFlags -> Ghc a) -> IO a -withInitializedPackages ghcopts cont = - run (do dflags <- getSessionDynFlags - (dflags', _, _) <- parseDynamicFlags dflags (map SrcLoc.noLoc ghcopts) - _ <- setSessionDynFlags (dflags' { hscTarget = HscInterpreted - , ghcLink = LinkInMemory }) - (dflags'',_packageids) <- liftIO (initPackages dflags') - cont dflags'') - -#if __GLASGOW_HASKELL__ < 706 -run :: Ghc a -> IO a -run = defaultErrorHandler defaultLogAction . runGhc (Just libdir) -#else -run :: Ghc a -> IO a -run = defaultErrorHandler defaultFatalMessager defaultFlushOut . runGhc (Just libdir) -#endif - -showppr :: Outputable a => DynFlags -> a -> String -showppr dflags = Documentation.Haddock.Docs.showSDocForUser dflags neverQualify . ppr - -sdoc :: DynFlags -> SDoc -> String -sdoc dflags = Documentation.Haddock.Docs.showSDocForUser dflags neverQualify - --- | Wraps 'Outputable.showSDocForUser'. -#if __GLASGOW_HASKELL__ == 702 -showSDocForUser _ = Outputable.showSDocForUser -#endif -#if __GLASGOW_HASKELL__ == 704 -showSDocForUser _ = Outputable.showSDocForUser -#endif -#if __GLASGOW_HASKELL__ == 706 -showSDocForUser = Outputable.showSDocForUser -#endif -#if __GLASGOW_HASKELL__ == 708 -showSDocForUser = Outputable.showSDocForUser -#endif diff --git a/src/Haskell/Docs.hs b/src/Haskell/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Haskell/Docs.hs @@ -0,0 +1,30 @@ +-- | Lookup the documentation of a name in a module (and in a specific +-- package in the case of ambiguity). + +module Haskell.Docs + (module Haskell.Docs + ,Identifier(..) + ,PackageName(..)) + where + +import Haskell.Docs.Formatting +import Haskell.Docs.Haddock +import Haskell.Docs.Types + +import GHC hiding (verbosity) +import GhcMonad (liftIO) +import System.IO + +-- -- | Print the documentation of a name in the given module. +printDocForIdentInModule + :: Maybe PackageName -- ^ Package. + -> ModuleName -- ^ Module name. + -> Identifier -- ^ Identifier. + -> Ghc () +printDocForIdentInModule pname mname name = + do result <- search Nothing pname mname name + case result of + Left err -> + error (show err) + Right docs -> + mapM_ printIdentDoc docs diff --git a/src/Haskell/Docs/Formatting.hs b/src/Haskell/Docs/Formatting.hs new file mode 100644 --- /dev/null +++ b/src/Haskell/Docs/Formatting.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE CPP #-} + +-- | Formatting of Haddock documentation. + +module Haskell.Docs.Formatting where + +import Haskell.Docs.Types +import Haskell.Docs.Ghc + +import Data.Char +import Data.List +import Documentation.Haddock +import GHC hiding (verbosity) +import GhcMonad (liftIO) +import Name + +-- * Formatting + +-- | Print an identifier' documentation. +printIdentDoc :: IdentDoc -> Ghc () +printIdentDoc idoc = + do d <- getSessionDynFlags + liftIO (putStrLn ("Package: " ++ showPackageName (identDocPackageName idoc))) + case identDocIdent idoc of + Nothing -> return () + Just i -> liftIO (putStrLn (showppr d i ++ " :: " ++ showppr d (idType i))) + liftIO (putStrLn (formatDoc (identDocDocs idoc))) + case identDocArgDocs idoc of + Nothing -> return () + Just args -> liftIO (putStr (unlines (map (\(i,x) -> formatArg i x) args))) + +-- | Format some documentation to plain text. +formatDoc :: Doc String -> String +formatDoc = trim . doc where + +-- * Internal functions + +-- | 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 +formatArg i x = prefix ++ + indentAfter (length prefix) (formatDoc x) + where prefix = show i ++ ": " + +-- | Indent after the first line. +indentAfter :: Int -> String -> String +indentAfter i xs = intercalate "\n" (take 1 l ++ map (replicate (i-1) ' ' ++) (drop 1 l)) + where l = lines xs diff --git a/src/Haskell/Docs/Ghc.hs b/src/Haskell/Docs/Ghc.hs new file mode 100644 --- /dev/null +++ b/src/Haskell/Docs/Ghc.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS -Wall -fno-warn-missing-signatures #-} + +-- | Ghc compatibility layer. + +module Haskell.Docs.Ghc where + +import Haskell.Docs.Types + +import GHC hiding (verbosity) +import GHC.Paths (libdir) +import GhcMonad (liftIO) +import Outputable +import Packages +import qualified SrcLoc +import Name +import Module + +#if __GLASGOW_HASKELL__ < 706 +import DynFlags (defaultLogAction) +#else +import DynFlags (defaultFlushOut, defaultFatalMessager) +#endif + +-- * GHC actions + +-- | Run an action with an initialized GHC package set. +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) + +-- | 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 + +-- | Make a module name. +makeModuleName :: String -> ModuleName +makeModuleName = mkModuleName + +-- * Internal functions + +-- | Run the given GHC action. +#if __GLASGOW_HASKELL__ < 706 +run :: Ghc a -> IO a +run = defaultErrorHandler defaultLogAction . runGhc (Just libdir) +#else +run :: Ghc a -> IO a +run = defaultErrorHandler defaultFatalMessager defaultFlushOut . runGhc (Just libdir) +#endif + +-- | Pretty print something to string. +showppr dflags = Haskell.Docs.Ghc.showSDocForUser dflags neverQualify . ppr + +-- | Wraps 'Outputable.showSDocForUser'. +#if __GLASGOW_HASKELL__ == 702 +showSDocForUser _ = Outputable.showSDocForUser +#endif +#if __GLASGOW_HASKELL__ == 704 +showSDocForUser _ = Outputable.showSDocForUser +#endif +#if __GLASGOW_HASKELL__ == 706 +showSDocForUser = Outputable.showSDocForUser +#endif +#if __GLASGOW_HASKELL__ == 708 +showSDocForUser = Outputable.showSDocForUser +#endif + +-- | Set the import context. +setImportContext :: ModuleName -> Ghc () +#if __GLASGOW_HASKELL__ == 702 +setImportContext mname = setContext [] [simpleImportDecl mname] +#else +setImportContext mname = setContext [IIDecl (simpleImportDecl mname)] +#endif + +-- | Show the package name e.g. base. +showPackageName :: PackageIdentifier -> String +showPackageName = packageIdString . mkPackageId diff --git a/src/Haskell/Docs/Haddock.hs b/src/Haskell/Docs/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Haskell/Docs/Haddock.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS -Wall -fno-warn-missing-signatures #-} + +-- | Haddock compatibilty layer and query functions. + +module Haskell.Docs.Haddock where + +import Haskell.Docs.Ghc +import Haskell.Docs.Types + +import Control.Arrow +import Control.Monad +import Data.Either +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Documentation.Haddock +import GHC hiding (verbosity) +import GhcMonad (liftIO) +import Name +import PackageConfig +import Packages + +-- * 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 + +-- | Search for the given identifier in the given package. +searchWithPackage + :: PackageConfig + -> 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))))) + +-- | Search for the given identifier in the interface. +searchWithInterface + :: PackageConfig + -> ModuleName + -> Identifier + -> InstalledInterface + -> Ghc (Either DocsException [IdentDoc]) +searchWithInterface package mname name interface = + case find ((==name) . Identifier . getOccString) (instExports interface) of + Nothing -> + return (Left NoFindNameInExports) + Just{} -> + case M.lookup (unIdentifier name) (interfaceNameMap interface) of + Nothing -> + case lookup (unIdentifier name) (map (getOccString &&& id) (instExports interface)) of + Just subname + | moduleName (nameModule subname) /= moduleName (instMod interface) -> + descendSearch package name subname + _ -> + return (Left NoFindNameInInterface) + Just d -> + do mi <- findIdentifier mname name + margs <- lookupArgsDocs interface name + return + (Right + [IdentDoc (sourcePackageId package) + 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)]) +lookupArgsDocs interface name = do + case M.lookup (unIdentifier name) (interfaceArgMap interface) of + Nothing -> return Nothing + Just argMap -> + return (Just (map (second (fmap getOccString)) (M.toList argMap))) + +-- * Querying for packages and interfaces + +-- | Search for a module's package, returning suggestions if not +-- found. +getPackagesByModule :: ModuleName -> Ghc (Either [Module] [PackageConfig]) +getPackagesByModule m = + do df <- getSessionDynFlags + return (fmap (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) . + haddockInterfaces + +-- * Internal functions + +-- | The module symbol doesn't actually exist in the module we +-- intended, so we descend into the module that it does exist in and +-- 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 diff --git a/src/Haskell/Docs/Types.hs b/src/Haskell/Docs/Types.hs new file mode 100644 --- /dev/null +++ b/src/Haskell/Docs/Types.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | All types. + +module Haskell.Docs.Types + (IdentDoc(..) + ,DocsException(..) + ,Identifier(..) + ,PackageName(..)) + where + +import Control.Exception (Exception) +import Data.Typeable (Typeable) +import Documentation.Haddock (Doc) +import GHC (Id) +import PackageConfig (PackageIdentifier) + +-- | An identifier. +newtype Identifier = Identifier {unIdentifier :: String} + deriving (Show,Eq) + +-- | An package name. +newtype PackageName = PackageName String + deriving (Show,Eq) + +-- | Identier documentation along with argument docs and identifiers. +data IdentDoc = IdentDoc + { identDocPackageName :: !PackageIdentifier + , identDocDocs :: !(Doc String) + , identDocIdent :: !(Maybe Id) + , identDocArgDocs :: !(Maybe [(Int, Doc String)]) + } + +-- | An exception when doing lookups. +data DocsException + = NoFindModule + | NoModulePackageCombo + | NoInterfaceFiles + | NoParseInterfaceFiles [DocsException] + | NoFindNameInExports + | NoFindNameInInterface + | NoReadInterfaceFile String + deriving (Typeable,Show) +instance Exception DocsException diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -1,17 +1,23 @@ {-# OPTIONS -Wall #-} +-- | Main command-line interface. + module Main where -import Control.Monad -import Documentation.Haddock.Docs -import GHC (mkModuleName) +import Haskell.Docs +import Haskell.Docs.Ghc + import Options.Applicative +-- | Main entry point. main :: IO () -main = do - (mname, name, pname, ghcopts) <- execParser opts - withInitializedPackages ghcopts $ \d -> void $ - printDocumentation d name (mkModuleName mname) pname Nothing +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)) diff --git a/src/test/Main.hs b/src/test/Main.hs --- a/src/test/Main.hs +++ b/src/test/Main.hs @@ -4,7 +4,8 @@ import qualified Control.Exception as E import Control.Monad -import Documentation.Haddock.Docs +import Haskell.Docs +import Haskell.Docs.Ghc import System.Exit import System.IO @@ -25,7 +26,7 @@ initialization :: IO () initialization = do it "withInitializedPackages" - (withInitializedPackages [] (\dflags -> return ())) + (withInitializedPackages [] (return ())) -- | Test GHC docs. docs :: IO () @@ -33,13 +34,10 @@ do it "printDocumentation" (withInitializedPackages [] - (\d -> - void (printDocumentation - d - "hSetBuffering" - (mkModuleName "System.IO") - Nothing - Nothing))) + (void (printDocForIdentInModule + Nothing + (makeModuleName "System.IO") + (Identifier "hSetBuffering")))) -- | Test GHC types. types :: IO () @@ -47,16 +45,12 @@ do it "getType" (withInitializedPackages [] - (\d -> - do void (printDocumentation - d - "hSetBuffering" - (mkModuleName "System.IO") - Nothing - Nothing) - void (getType d - (mkModuleName "System.IO") - "hSetBuffering"))) + (do void (printDocForIdentInModule + Nothing + (makeModuleName "System.IO") + (Identifier "hSetBuffering")) + void (findIdentifier (makeModuleName "System.IO") + (Identifier "hSetBuffering")))) -- | Describe a test spec. describe :: String -> IO () -> IO ()