Created
December 26, 2012 23:52
-
-
Save chrisdone/4384163 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# OPTIONS -Wall -fno-warn-orphans #-} | |
{-# LANGUAGE FlexibleInstances #-} | |
{-# LANGUAGE StandaloneDeriving #-} | |
-- | 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 | |
import DynFlags (defaultLogAction) | |
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: <modulename> <name> [<package name>]" | |
-- | 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 d printPackage package name interface = do | |
case M.lookup name docMap of | |
Nothing -> | |
case lookup name (map (getOccString &&& id) (instExports interface)) of | |
Just subname -> descendSearch d name subname package | |
Nothing -> 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" | |
go (DocURL url) = url | |
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 | |
dflags <- defaultErrorHandler defaultLogAction $ runGhc (Just libdir) $ do | |
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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment