hdocs 0.2.0.0 → 0.3.0.0

raw patch · 6 files changed

+274/−194 lines, 6 files

Files

hdocs.cabal +6/−2
src/HDocs/Base.hs +80/−0
src/HDocs/Haddock.hs +97/−0
src/HDocs/Module.hs +55/−169
tests/Test.hs +14/−8
tools/hdocs.hs +22/−15

hdocs.cabal view

@@ -1,5 +1,5 @@ name:                hdocs
-version:             0.2.0.0
+version:             0.3.0.0
 synopsis:            Haskell docs tool
 description:
   Tool and library to get docs for installed packages and source files.
@@ -24,6 +24,8 @@ library
   hs-source-dirs: src
   exposed-modules:
+    HDocs.Base
+    HDocs.Haddock
     HDocs.Module
   build-depends:
     base == 4.6.*,
@@ -52,6 +54,7 @@     bytestring == 0.10.*,
     containers == 0.5.*,
     filepath == 1.3.*,
+    mtl == 2.1.*,
     network == 2.4.*,
     text == 0.11.*
 
@@ -62,4 +65,5 @@   build-depends:
     base == 4.6.*,
     hdocs,
-    containers == 0.5.*
+    containers == 0.5.*,
+    mtl == 2.1.*

+ src/HDocs/Base.hs view

@@ -0,0 +1,80 @@+module HDocs.Base (
+	ModuleDocMap,
+	withInitializedPackages, configSession,
+	formatDoc, formatDocs
+	) where
+
+import Data.Char (isSpace)
+import Data.Map (Map)
+import qualified Data.Map as M
+
+import Documentation.Haddock
+
+import DynFlags
+import GHC
+import GHC.Paths
+import qualified GhcMonad as GHC (liftIO)
+import Name (occNameString)
+import Packages
+
+-- | Documentation in module
+type ModuleDocMap = Map String (Doc String)
+
+-- | Run action with initialized packages
+withInitializedPackages :: [String] -> (DynFlags -> IO a) -> IO a
+withInitializedPackages ghcOpts cont = do
+	runGhc (Just libdir) $ do
+		fs <- getSessionDynFlags
+		defaultCleanupHandler fs $ do
+			(fs', _, _) <- parseDynamicFlags fs (map noLoc ghcOpts)
+			setSessionDynFlags fs'
+			(result, _) <- GHC.liftIO $ initPackages fs'
+			GHC.liftIO $ cont result
+
+-- | Config GHC session
+configSession :: [String] -> IO DynFlags
+configSession ghcOpts = do
+	runGhc (Just libdir) $ do
+		fs <- getSessionDynFlags
+		defaultCleanupHandler fs $ do
+			(fs', _, _) <- parseDynamicFlags fs (map noLoc ghcOpts)
+			setSessionDynFlags fs'
+			(result, _) <- GHC.liftIO $ initPackages fs'
+			return result
+
+-- | Format 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) = trimSpaces 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..] :: [Integer]) i)
+	go (DocDefList xs) = unlines (map (\(i,x) -> go i ++ ". " ++ go x) xs)
+	go (DocCodeBlock block) = unlines (map ("    " ++) (lines (go block))) ++ "\n"
+	go (DocHyperlink (Hyperlink url label)) = maybe url (\l -> l ++ "[" ++ url ++ "]") label
+	go (DocPic pic) = pic
+	go (DocAName name) = name
+	go (DocExamples exs) = unlines (map formatExample exs)
+
+	formatExample :: Example -> String
+	formatExample (Example expr result) = "    > " ++ expr ++ unlines (map ("    " ++) result)
+
+	trimSpaces [] = []
+	trimSpaces [s] = [s]
+	trimSpaces (' ':' ':ss) = trimSpaces (' ':ss)
+	trimSpaces (x:y:ss) = x : trimSpaces(y:ss)
+
+	trim :: String -> String
+	trim = p . p where
+		p = reverse . dropWhile isSpace
+
+-- | Format docs to plain text
+formatDocs :: ModuleDocMap -> Map String String
+formatDocs = M.map formatDoc

+ src/HDocs/Haddock.hs view

@@ -0,0 +1,97 @@+module HDocs.Haddock (
+	-- * Documentation functions
+	readInstalledDocs,
+	readHaddock,
+	readSource,
+
+	-- * Extract docs
+	installedInterfaceDocs, installedInterfacesDocs,
+	interfaceDocs,	
+
+	-- * Utility functions
+	haddockFiles,
+	readInstalledInterfaces, readPackageInterfaces,
+	lookupDoc, lookupNameDoc,
+
+	module HDocs.Base
+	) where
+
+import Control.Applicative
+import Control.Arrow
+import Control.Exception
+import Control.Monad.Error
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (listToMaybe)
+
+import Documentation.Haddock
+
+import DynFlags
+import Module
+import Name
+import PackageConfig
+
+import HDocs.Base
+
+-- | Read all installed docs
+readInstalledDocs :: [String] -> ErrorT String IO (Map String ModuleDocMap)
+readInstalledDocs opts = do
+	fs <- haddockFiles opts
+	liftM M.unions $ forM fs $ \f -> (readHaddock f) `mplus` (return M.empty)
+
+-- | Read docs from .haddock file
+readHaddock :: FilePath -> ErrorT String IO (Map String ModuleDocMap)
+readHaddock f = M.fromList . map installedInterfaceDocs <$> readInstalledInterfaces f
+
+-- | Read docs for haskell module
+readSource :: [String] -> FilePath -> ErrorT String IO (String, ModuleDocMap)
+readSource opts f = do
+	ifaces <- liftIO $ createInterfaces ([Flag_Verbosity "0", Flag_NoWarnings] ++ map Flag_OptGhc opts) [f]
+	iface <- maybe (throwError $ "Failed to load docs for " ++ f) return $ listToMaybe ifaces
+	return $ interfaceDocs iface
+
+-- | Get docs for 'InstalledInterface'
+installedInterfaceDocs :: InstalledInterface -> (String, ModuleDocMap)
+installedInterfaceDocs = stringize . (instMod &&& instDocMap)
+
+-- | Get docs for 'InstalledInterface's
+installedInterfacesDocs :: [InstalledInterface] -> Map String ModuleDocMap
+installedInterfacesDocs = M.fromList . map installedInterfaceDocs
+
+-- | Get docs for 'Interface'
+interfaceDocs :: Interface -> (String, ModuleDocMap)
+interfaceDocs = stringize . (ifaceMod &&& ifaceDocMap)
+
+-- | Get list of haddock files in package db
+haddockFiles :: [String] -> ErrorT String IO [FilePath]
+haddockFiles opts = ErrorT $ withInitializedPackages opts $ return . maybe
+	(Left "Package database empty")
+	(Right . concatMap haddockInterfaces) .
+	pkgDatabase
+
+-- | Read installed interface
+readInstalledInterfaces :: FilePath -> ErrorT String IO [InstalledInterface]
+readInstalledInterfaces f = do
+	ifile <- liftError $ ErrorT $ readInterfaceFile freshNameCache f
+	return $ ifInstalledIfaces ifile
+
+-- | Read installed interfaces for package
+readPackageInterfaces :: PackageConfig -> ErrorT String IO [InstalledInterface]
+readPackageInterfaces = liftM concat . mapM readInstalledInterfaces . haddockInterfaces
+
+-- | Lookup doc
+lookupDoc :: String -> String -> Map String ModuleDocMap -> Maybe (Doc String)
+lookupDoc m n = M.lookup m >=> M.lookup n
+
+-- | Lookup doc for Name
+lookupNameDoc :: Name -> Map String ModuleDocMap -> Maybe (Doc String)
+lookupNameDoc n = lookupDoc (moduleNameString $ moduleName $ nameModule n) (getOccString n)
+
+stringize :: (Module, Map Name (Doc Name)) -> (String, ModuleDocMap)
+stringize = moduleNameString . moduleName *** strDoc where
+	strDoc = M.mapKeys getOccString . M.map (fmap getOccString)
+
+liftError :: ErrorT String IO a -> ErrorT String IO a
+liftError = ErrorT . handle onErr . runErrorT where
+	onErr :: SomeException -> IO (Either String a)
+	onErr = return . Left . show

src/HDocs/Module.hs view

@@ -1,196 +1,82 @@ module HDocs.Module (
-	-- * Types
-	ModuleDocMap,
-	DocsM,
-	runDocsM,
+	-- * Get module docs
+	moduleDocs, installedDocs,
 
-	-- * Helpers
-	withInitializedPackages,
-	configSession,
-	moduleInterface,
-	packageInterface,
-	formatDoc,
+	-- * Utility
+	exportsDocs,
 
-	-- * Get module docs
-	moduleDocs,
-	fileDocs,
-	docs
+	module HDocs.Base
 	) where
 
-import Control.Arrow
-import Control.Exception
-import Control.Monad.State
+import Control.Applicative
 import Control.Monad.Error
 
-import Data.Either
-import Data.Char (isSpace)
+import Data.List
 import Data.Map (Map)
 import qualified Data.Map as M
+import Data.Maybe
 
 import Documentation.Haddock
 
-import System.FilePath (takeExtension)
-
 import DynFlags
-import GHC
-import GHC.Paths (libdir)
-import qualified GhcMonad as GHC (liftIO)
 import Module
-import Name (getOccString, occNameString)
 import Packages
-
--- | Documentations in module
-type ModuleDocMap = Map String (Doc String)
-
-withInitializedPackages :: [String] -> (DynFlags -> IO a) -> IO a
-withInitializedPackages ghcOpts cont = do
-	runGhc (Just libdir) $ do
-		fs <- getSessionDynFlags
-		defaultCleanupHandler fs $ do
-			(fs', _, _) <- parseDynamicFlags fs (map noLoc ghcOpts)
-			setSessionDynFlags fs'
-			(result, _) <- GHC.liftIO $ initPackages fs
-			GHC.liftIO $ cont result
-
-configSession :: [String] -> IO DynFlags
-configSession ghcOpts = do
-	runGhc (Just libdir) $ do
-		fs <- getSessionDynFlags
-		defaultCleanupHandler fs $ do
-			(fs', _, _) <- parseDynamicFlags fs (map noLoc ghcOpts)
-			setSessionDynFlags fs'
-			(result, _) <- GHC.liftIO $ initPackages fs'
-			return result
+import Name
 
--- | Docs state
-type DocsM a = ErrorT String (StateT (Map String ModuleDocMap) IO) a
+import HDocs.Base
+import qualified HDocs.Haddock as H
 
--- | Run docs monad
-runDocsM :: DocsM a -> IO (Either String a)
-runDocsM act = catch (evalStateT (runErrorT act) M.empty) onError where
-	onError :: SomeException -> IO (Either String a)
-	onError = return . Left . show
+-- | Load docs for all exported module symbols
+moduleDocs :: [String] -> String -> ErrorT String IO ModuleDocMap
+moduleDocs opts mname = ErrorT $ withInitializedPackages opts (runErrorT . moduleDocs') where
+	moduleDocs' :: DynFlags -> ErrorT String IO ModuleDocMap
+	moduleDocs' d = do
+		pkg <- case pkgs of
+			[] -> throwError $ "Module " ++ mname ++ " not found"
+			[pkg] -> return pkg
+			_ -> throwError $ "Module " ++ mname ++ " found in several packages: " ++ intercalate ", " (map pkgId pkgs)
+		ifaces <- H.readPackageInterfaces pkg
+		iface <- maybe
+			(throwError $ "Module " ++ mname ++ " not found in package " ++ pkgId pkg)
+			return
+			(find ((== mname) . moduleNameString . moduleName . instMod) ifaces)
 
-class DocInterface a where
-	getModule :: a -> Module
-	getDocMap :: a -> DocMap Name
-	getExports :: a -> [Name]
-	loadInterfaces :: [String] -> String -> IO [a]
+		depsfaces <- liftM concat $ mapM H.readPackageInterfaces $
+			map (getPackageDetails (pkgState d)) $ ifacePackageDeps iface
 
-instance DocInterface InstalledInterface where
-	getModule = instMod
-	getDocMap = instDocMap
-	getExports = instExports
-	loadInterfaces opts m = withInitializedPackages opts $ \d ->
-		liftM (map snd) $ moduleInterface d (mkModuleName m)
+		let
+			deps = filter (ifaceDep iface) $ ifaces ++ depsfaces
 
-instance DocInterface Interface where
-	getModule = ifaceMod
-	getDocMap = ifaceDocMap
-	getExports = const [] -- ifaceExports
-	loadInterfaces opts m = do
-		createInterfaces (noOutput ++ map Flag_OptGhc opts) [m]
+		return $ snd $ exportsDocs (H.installedInterfacesDocs deps) iface
 		where
-			noOutput = [
-				Flag_Verbosity "0",
-				Flag_NoWarnings]
-
--- | Load docs from interface
-interfaceDocs :: DocInterface a => a -> [String] -> String -> DocsM ModuleDocMap
-interfaceDocs h opts m = do
-	loaded <- gets (M.lookup m)
-	case loaded of
-		Just d' -> return d'
-		Nothing -> do
-			ifaces <- liftM (`asTypeOf` [h]) $ liftIO $ loadInterfaces opts m
-			when (null ifaces) $ throwError $ "Unable to load interface for module: " ++ m
-			modify $ M.insert m $ M.unions $ map interfaceNameMap ifaces
-			let
-				reexports = filter ((/= m) . moduleNameString . moduleName . nameModule) $ concatMap getExports ifaces
-			docs' <- liftM M.unions $ forM reexports $ \nm -> do
-				doc <- liftM (M.lookup (getOccString nm)) $ interfaceDocs h opts (moduleNameString . moduleName . nameModule $ nm)
-				return $ maybe M.empty (M.singleton (getOccString nm)) doc
-			modify $ M.update (Just . M.union docs') m
-			result <- gets $ M.lookup m
-			maybe (throwError $ "Error loading module " ++ m) return result
-
--- | Load module documentation
-moduleDocs :: [String] -> String -> DocsM ModuleDocMap
-moduleDocs = interfaceDocs (undefined :: InstalledInterface)
-
--- | Load file documentation
-fileDocs :: [String] -> FilePath -> DocsM ModuleDocMap
-fileDocs = interfaceDocs (undefined :: Interface)
-
--- | Load docs for file or module
-docs :: [String] -> String -> DocsM ModuleDocMap
-docs opts m
-	| takeExtension m `elem` [".hs", ".lhs"] = fileDocs opts m
-	| otherwise = moduleDocs opts m
-
--- | Load installed interface
-moduleInterface :: DynFlags -> ModuleName -> IO [(PackageConfig, InstalledInterface)]
-moduleInterface d mname = do
-	result <- liftIO $ getPackagesByModule d mname
-	liftM concat $ mapM packageInterface' $ either (const []) id result
-	where
-		packageInterface' p = liftM (zip (repeat p)) $ packageInterface d mname p
-
-packageInterface :: DynFlags -> ModuleName -> PackageConfig -> IO [InstalledInterface]
-packageInterface _ mname package = do
-	files <- getHaddockInterfaceByPackage package
-	case partitionEithers files of
-		([], []) -> return []
-		(_:_, _) -> return []
-		(_, files') -> return $ concatMap (filter ((== mname) . moduleName . instMod) . ifInstalledIfaces) files'
-
--- | Format 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) = trimSpaces 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..] :: [Integer]) i)
-	go (DocDefList xs) = unlines (map (\(i,x) -> go i ++ ". " ++ go x) xs)
-	go (DocCodeBlock block) = unlines (map ("    " ++) (lines (go block))) ++ "\n"
-	go (DocHyperlink (Hyperlink url label)) = maybe url (\l -> l ++ "[" ++ url ++ "]") label
-	go (DocPic pic) = pic
-	go (DocAName name) = name
-	go (DocExamples exs) = unlines (map formatExample exs)
-
-	formatExample :: Example -> String
-	formatExample (Example expr result) = "    > " ++ expr ++ unlines (map ("    " ++) result)
-
-	trimSpaces [] = []
-	trimSpaces [s] = [s]
-	trimSpaces (' ':' ':ss) = trimSpaces (' ':ss)
-	trimSpaces (x:y:ss) = x : trimSpaces(y:ss)
+			pkgs = filter exposed $ map fst $ lookupModuleInAllPackages d (mkModuleName mname)
 
--- | Get a map from names to doc string
-interfaceNameMap :: DocInterface a => a -> Map String (Doc String)
-interfaceNameMap = M.fromList . map (getOccString *** fmap getOccString) . M.toList . getDocMap
+	namePackage :: Name -> PackageId
+	namePackage = modulePackageId . nameModule
 
--- | Search for a module's package with suggestions if not found
-getPackagesByModule :: DynFlags -> ModuleName -> IO (Either [Module] [PackageConfig])
-getPackagesByModule d m = return $ fmap (map fst) $ lookupModuleWithSuggestions d m
+	ifacePackageDeps :: InstalledInterface -> [PackageId]
+	ifacePackageDeps i = (modulePackageId $ instMod i) `delete` (nub . map namePackage . instExports $ i)
 
--- | Trim string
-trim :: String -> String
-trim = p . p where
-	p = reverse . dropWhile isSpace
+	ifaceDep :: InstalledInterface -> InstalledInterface -> Bool
+	ifaceDep i idep = instMod i /= instMod idep && instMod idep `elem` map nameModule (instExports i)
 
--- | Show the package name
-showPackageName :: PackageIdentifier -> String
-showPackageName = packageIdString . mkPackageId
+	pkgId :: PackageConfig -> String
+	pkgId = display . installedPackageId
 
--- | Get the Haddock interfaces of the given package.
-getHaddockInterfaceByPackage :: PackageConfig -> IO [Either String InterfaceFile]
-getHaddockInterfaceByPackage = mapM (readInterfaceFile freshNameCache) . haddockInterfaces
+-- | Load docs for all installed modules
+installedDocs :: [String] -> ErrorT String IO (Map String ModuleDocMap)
+installedDocs opts = ErrorT $ withInitializedPackages opts (runErrorT . installedDocs') where
+	installedDocs' :: DynFlags -> ErrorT String IO (Map String ModuleDocMap)
+	installedDocs' d = do
+		fs <- maybe (throwError "Package database empty") (return . concatMap haddockInterfaces) $ pkgDatabase d
+		ifaces <- liftM concat $ mapM ((`mplus` return []) . H.readInstalledInterfaces) fs
+		let
+			idocs = H.installedInterfacesDocs ifaces
+		return $ M.fromList $ map (exportsDocs idocs) ifaces
 
+-- | Get docs for 'InstalledInterface' with its exports docs
+exportsDocs :: Map String ModuleDocMap -> InstalledInterface -> (String, ModuleDocMap)
+exportsDocs docs iface = (iname, snd (H.installedInterfaceDocs iface) `M.union` edocs) where
+	iname = moduleNameString $ moduleName $ instMod iface
+	edocs = M.fromList $ mapMaybe findDoc (instExports iface)
+	findDoc n = ((,) (getOccString n)) <$> (H.lookupNameDoc n docs)

tests/Test.hs view

@@ -3,19 +3,25 @@ 	) where
 
 import Control.Monad
+import Control.Monad.Error
 import qualified Data.Map as M
 
 import System.Exit
 
 import HDocs.Module
+import HDocs.Haddock
 
 -- | This is main function
 main :: IO ()
-main = do
-	sdocs <- runDocsM (fileDocs [] "tests/Test.hs")
-	tdocs <- either (\e -> putStrLn e >> exitFailure) (return . M.lookup "main") sdocs
-	when (fmap formatDoc tdocs /= Just "This is main function") exitFailure
-	edocs <- runDocsM (moduleDocs [] "Prelude")
-	mdocs <- either (\e -> putStrLn e >> exitFailure) (return . M.lookup "null") edocs
-	when (fmap formatDoc mdocs /= Just "Test whether a list is empty.") exitFailure
-	exitSuccess
+main = runErrorT main' >>= either (\e -> putStrLn e >> exitFailure) (\_ -> exitSuccess) where
+	main' :: ErrorT String IO ()
+	main' = do
+		sdocs <- fmt $ liftM snd $ readSource [] "tests/Test.hs"
+		check "Documentation for main"
+			(M.lookup "main" sdocs == Just "This is main function")
+		edocs <- fmt $ moduleDocs [] "Prelude"
+		check "Documentation for Prelude.null"
+			(M.lookup "null" edocs == Just "Test whether a list is empty.")
+		where
+			check str p = if p then return () else throwError str
+			fmt = liftM formatDocs

tools/hdocs.hs view

@@ -2,23 +2,21 @@ 	main
 	) where
 
+import Control.Monad.Error
 import Data.Aeson
 import Data.Aeson.Encode.Pretty (encodePretty)
-import Data.ByteString.Lazy (ByteString, toStrict)
-import Data.Maybe
-import Data.Map (Map)
+import Data.ByteString.Lazy (toStrict)
 import qualified Data.Map as M
-import Data.Monoid
-import Data.String
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import Network (PortNumber)
+import Data.Monoid (Monoid(..))
+import qualified Data.Text as T (unpack, pack)
+import qualified Data.Text.Encoding as T (decodeUtf8)
 
+import HDocs.Haddock
 import HDocs.Module
 
 import System.Console.GetOpt
-import System.Environment
-import System.FilePath
+import System.Environment (getArgs)
+import System.FilePath (takeExtension)
 import System.IO
 
 data HDocsOptions = HDocsOptions {
@@ -54,13 +52,21 @@ 		jsonError err = object [
 			T.pack "error" .= err]
 
-		loadDocs m f = do
-			docs <- runDocsM (docs (optionGHC cfg) m)
-			putStrLn $ either (toStr . jsonError) toStr (fmap (M.map formatDoc) docs >>= f)
+		run :: ToJSON a => ErrorT String IO a -> IO ()
+		run act = runErrorT act >>= putStrLn . either (toStr . jsonError) toStr
 
+		loadDocs :: String -> ErrorT String IO ModuleDocMap
+		loadDocs m
+			| takeExtension m == ".hs" = liftM snd $ readSource (optionGHC cfg) m
+			| otherwise = moduleDocs (optionGHC cfg) m
+
 	case cmds of
-		[m] -> loadDocs m return
-		[m, n] -> loadDocs m $ maybe (Left $ "Symbol '" ++ n ++ "' not found") (return . M.singleton n) . M.lookup n
+		["dump", "r"] -> run $ liftM (M.map formatDocs) $ installedDocs (optionGHC cfg)
+		["dump"] -> run $ liftM (M.map formatDocs) $ readInstalledDocs (optionGHC cfg)
+		[m] -> run $ liftM formatDocs $ loadDocs m
+		[m, n] -> run $ liftM formatDocs $ do
+			docs <- loadDocs m
+			maybe (throwError $ "Symbol '" ++ n ++ "' not found") (return . M.singleton n) $ M.lookup n docs
 		_ -> printUsage
 
 printUsage :: IO ()
@@ -68,5 +74,6 @@ 	"Usage:",
 	"  hdocs <module> - get docs for module/file",
 	"  hdocs <module> <name> - get docs for name in module/file",
+	"  hdocs dump [r] - dump all installed docs, if [r], find docs for reexported declarations",
 	"",
 	usageInfo "flags" opts]