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: 0.2.0.0 +version: 3.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 @@ -21,16 +21,10 @@ in your .cabal/config so that the necessary .haddock files are generated. . - Haddock is very sensitive to the GHC version, and - so too will this program be, to GHC, and to Haddock. I suggest - installing like this: - . - > cabal install haskell-docs --constraint haddock==2.10.0 - . - But replace the 2.10.0 with the version that haddock --version gives you. - . - I could perhaps instead have a flag for each GHC - release back a few versions. + Haddock is very sensitive to the GHC version. This program tries not to be. If + you cannot install this package due to a version problem, open a Github issue. + If the versions match up but the build fails, open a Github issue. Neither + case should arise. . /USING WITH GHCI/ . @@ -57,16 +51,22 @@ Homepage: http://github.com/chrisdone/haskell-docs Bug-Reports: http://github.com/chrisdone/haskell-docs/issues - -executable haskell-docs +library hs-source-dirs: src - main-is: Main.hs + exposed-modules: Documentation.Haddock.Docs build-depends: base > 4 && < 5, - ghc, + ghc > 7.2 && < 7.9, ghc-paths, - haddock, + haddock >= 2.9 && < 2.15, containers, monad-loops + +executable haskell-docs + hs-source-dirs: src/main + main-is: Main.hs + build-depends: base > 4 && < 5, + ghc > 7.2 && < 7.9, + haskell-docs source-repository head type: git diff --git a/src/Documentation/Haddock/Docs.hs b/src/Documentation/Haddock/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Documentation/Haddock/Docs.hs @@ -0,0 +1,241 @@ +{-# OPTIONS -Wall #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} + +-- | Lookup the documentation of a name in a module (and in a specific +-- package in the case of ambiguity). + +module Documentation.Haddock.Docs where + +import Control.Arrow +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 Documentation.Haddock +import GHC hiding (verbosity) +import GHC.Paths (libdir) +import Module +import Name +import PackageConfig +import Packages + +#if __GLASGOW_HASKELL__ < 706 +import DynFlags (defaultLogAction) +#else +import DynFlags (defaultFlushOut, defaultFatalMessager) +#endif + +-- | Print documentation with an initialized package set. +printDocumentationInitialized :: String -> ModuleName -> Maybe String -> IO Bool +printDocumentationInitialized x y z = + withInitializedPackages $ \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 -> IO Bool +printDocumentation d name mname mpname previous = do + result <- 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 + 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 -> IO Bool +printWithPackage d printPackage name mname package = do + interfaceFiles <- 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) interfaces + +-- | Print the documentation from the given interface. +printWithInterface :: DynFlags -> Bool -> PackageConfig -> String -> InstalledInterface + -> IO Bool +printWithInterface df printPackage package name interface = do + 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 + _ -> do + putStrLn $ "Couldn't find name ``" ++ name ++ "'' in Haddock interface: " ++ + moduleNameString (moduleName (instMod interface)) + return False + Just d -> do when printPackage $ + putStrLn $ "Package: " ++ showPackageName (sourcePackageId package) + putStrLn (formatDoc d) + printArgs interface name + return True + + where docMap = interfaceNameMap interface + +-- | Print the documentation of the arguments. +printArgs :: InstalledInterface -> String -> IO () +printArgs interface name = do + case M.lookup name (interfaceArgMap interface) of + Nothing -> return () + Just argMap -> + 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 -> IO 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 :: (DynFlags -> IO a) -> IO a +withInitializedPackages cont = do + dflags <- run (do dflags <- getSessionDynFlags + _ <- setSessionDynFlags dflags + return dflags) + (dflags',_packageids) <- 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 diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,251 +0,0 @@ -{-# OPTIONS -Wall -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE CPP #-} - --- | Lookup the documentation of a name in a module (and in a specific --- package in the case of ambiguity). --- --- To build: --- --- $ ghc --make HaskellDocs.hs -package ghc -o haskell-docs --- --- Example usage: --- --- $ ./haskell-docs System.IO getContents base --- The “getContents” operation returns all user input as a single string, --- which is read lazily as it is needed --- (same as “hGetContents” “stdin”). --- --- Using with GHCi --- --- Move haskell-docs to ~/.cabal/bin. Then run the following in GHCi: --- --- λ> :def doc \input -> return (":!haskell-docs " ++ input) --- --- λ> :doc System.IO getContents base --- The “getContents” operation returns all user input as a single string, --- which is read lazily as it is needed --- (same as “hGetContents” “stdin”). --- --- Add the above :def to your ~/.ghci to have it on start-up. - -module Main where - -import Control.Arrow -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 Documentation.Haddock -#if __GLASGOW_HASKELL__ < 706 -import DynFlags (defaultLogAction) -#else -import DynFlags (defaultFlushOut, defaultFatalMessager) -#endif -import GHC hiding (flags, verbosity) -import GHC.Paths (libdir) -import Module -import Name -import PackageConfig -import Packages -import System.Environment - --- | Main entry point. -main :: IO () -main = do - args <- getArgs - case args of - [mname,name,pname] -> withInitializedPackages $ \d -> void $ - printDocumentation d name (mkModuleName mname) (Just pname) Nothing - [mname,name] -> withInitializedPackages $ \d -> void $ - printDocumentation d name (mkModuleName mname) Nothing Nothing - _ -> error "arguments: []" - --- | Print documentation with an initialized package set. -printDocumentationInitialized :: String -> ModuleName -> Maybe String -> IO Bool -printDocumentationInitialized x y z = - withInitializedPackages $ \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 -> IO Bool -printDocumentation d name mname mpname previous = do - result <- 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 - 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 -> IO Bool -printWithPackage d printPackage name mname package = do - interfaceFiles <- 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 - -> IO Bool -printWithInterface d printPackage package name mname interface = do - 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 d name subname package - _ -> do - putStrLn $ "Couldn't find name ``" ++ name ++ "'' in Haddock interface: " ++ - moduleNameString (moduleName (instMod interface)) - return False - Just doc -> do when printPackage $ - putStrLn $ "Package: " ++ showPackageName (sourcePackageId package) - putStrLn (formatDoc doc) - printArgs interface name - return True - - where docMap = interfaceNameMap interface - - printName x = moduleNameString (moduleName (nameModule x)) ++ "." ++ getOccString x - --- | Print the documentation of the arguments. -printArgs :: InstalledInterface -> String -> IO () -printArgs interface name = do - case M.lookup name (interfaceArgMap interface) of - Nothing -> return () - Just argMap -> - 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 -> IO 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 . go where - go DocEmpty = "" - go (DocAppend a b) = go a ++ go b - go (DocString str) = normalize str - go (DocParagraph p) = go p ++ "\n" - go (DocIdentifier i) = i - go (DocIdentifierUnchecked (mname,occname)) = - moduleNameString mname ++ "." ++ occNameString occname - go (DocModule m) = m - go (DocEmphasis e) = "*" ++ go e ++ "*" - go (DocMonospaced e) = "`" ++ go e ++ "`" - go (DocUnorderedList i) = unlines (map (("* " ++) . go) i) - go (DocOrderedList i) = unlines (zipWith (\i x -> show i ++ ". " ++ go x) [1..] i) - go (DocDefList xs) = unlines (map (\(i,x) -> go i ++ ". " ++ go x) xs) - go (DocCodeBlock block) = unlines (map (" " ++) (lines (go block))) ++ "\n" -#if MIN_VERSION_haddock(2,13,1) - go (DocHyperlink (Hyperlink url label)) = maybe url (\l -> l ++ "[" ++ url ++ "]") label -#else - go (DocURL url) = url -#endif - go (DocPic pic) = pic - go (DocAName name) = name - go (DocExamples exs) = unlines (map formatExample exs) - - 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) -interfaceNameMap iface = - M.fromList (map (second (fmap getOccString) . first getOccString) - (M.toList (instDocMap iface))) - --- | Get a mapping from names to doc string of that name from a --- Haddock interface. -interfaceArgMap :: InstalledInterface -> Map String (Map Int (Doc Name)) -interfaceArgMap iface = - M.fromList (map (first getOccString) (M.toList (instArgMap iface))) - --- | 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 :: (DynFlags -> IO a) -> IO a -withInitializedPackages cont = do -#if __GLASGOW_HASKELL__ < 706 - dflags <- defaultErrorHandler defaultLogAction $ runGhc (Just libdir) $ do -#else - dflags <- defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do -#endif - dflags <- getSessionDynFlags - setSessionDynFlags dflags - return dflags - (dflags,packageids) <- initPackages dflags - cont dflags - --------------------------------------------------------------------------------- --- Utilities and missing instances - -instance Show ModuleName where show = show . moduleNameString -instance Show OccName where show = show . occNameString -deriving instance Show (Doc String) diff --git a/src/main/Main.hs b/src/main/Main.hs new file mode 100644 --- /dev/null +++ b/src/main/Main.hs @@ -0,0 +1,19 @@ +{-# OPTIONS -Wall #-} + +module Main where + +import Control.Monad +import Documentation.Haddock.Docs +import GHC (mkModuleName) +import System.Environment + +-- | Main entry point. +main :: IO () +main = do + args <- getArgs + case args of + [mname,name,pname] -> withInitializedPackages $ \d -> void $ + printDocumentation d name (mkModuleName mname) (Just pname) Nothing + [mname,name] -> withInitializedPackages $ \d -> void $ + printDocumentation d name (mkModuleName mname) Nothing Nothing + _ -> error "arguments: []"