hdocs (empty) → 0.1.0.0
raw patch · 6 files changed
+379/−0 lines, 6 filesdep +MonadCatchIO-transformersdep +aesondep +basesetup-changed
Dependencies added: MonadCatchIO-transformers, aeson, base, bytestring, containers, filepath, ghc, ghc-paths, haddock, hdocs, mtl, network, process, text, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- hdocs.cabal +68/−0
- src/HDocs/Module.hs +190/−0
- tests/Test.hs +15/−0
- tools/hdocs.hs +74/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Alexandr `Voidex` Ruchkin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexandr `Voidex` Ruchkin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hdocs.cabal view
@@ -0,0 +1,68 @@+-- Initial hdocs.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: hdocs +version: 0.1.0.0 +synopsis: Haskell docs daemon +description: + Tool and library to get docs for installed packages and source files. + Can return result in JSON format. + . + @Usage: + hdocs docs <module> - get docs for module/file + hdocs docs <module> <name> - get docs for name in module/file + flags + -j --json output json + -g GHC_OPT --ghc=GHC_OPT option to pass to GHC + @ +homepage: https://github.com/mvoidex/hdocs +license: BSD3 +license-file: LICENSE +author: Alexandr `Voidex` Ruchkin +maintainer: voidex@live.com +-- copyright: +category: Development +build-type: Simple +cabal-version: >=1.8 + +library + hs-source-dirs: src + exposed-modules: + HDocs.Module + build-depends: + base == 4.6.*, + aeson == 0.6.*, + bytestring == 0.10.*, + filepath == 1.3.*, + ghc == 7.6.*, + ghc-paths == 0.1.*, + haddock == 2.13.*, + containers == 0.5.*, + transformers == 0.3.*, + MonadCatchIO-transformers == 0.3.*, + network == 2.4.*, + process == 1.1.*, + text == 0.11.*, + mtl == 2.1.* + +executable hdocs + main-is: hdocs.hs + hs-source-dirs: tools + build-depends: + base == 4.6.*, + hdocs, + aeson == 0.6.*, + bytestring == 0.10.*, + containers == 0.5.*, + filepath == 1.3.*, + network == 2.4.*, + text == 0.11.* + +test-suite test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: tests + build-depends: + base == 4.6.*, + hdocs, + containers == 0.5.*
+ src/HDocs/Module.hs view
@@ -0,0 +1,190 @@+module HDocs.Module ( + -- * Types + ModuleDocMap, + DocsM, + runDocsM, + + -- * Helpers + withInitializedPackages, + configSession, + moduleInterface, + packageInterface, + formatDoc, + + -- * Get module docs + moduleDocs, + fileDocs, + docs + ) where + +import Control.Arrow +import Control.Monad.State +import Control.Monad.Error + +import Data.Either +import Data.Char (isSpace) +import Data.Map (Map) +import qualified Data.Map as M + +import Documentation.Haddock + +import System.FilePath (takeExtension) + +import DynFlags +import GHC +import GHC.Paths (libdir) +import Module +import Name (getOccString, occNameString) +import Packages + +-- | Documentations in module +type ModuleDocMap = Map String (Doc String) + +withInitializedPackages :: (DynFlags -> IO a) -> IO a +withInitializedPackages cont = do + fs <- defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do + fs <- getSessionDynFlags + setSessionDynFlags fs + return fs + (fs', _) <- initPackages fs + cont fs' + +configSession :: [String] -> IO DynFlags +configSession ghcOpts = do + f <- defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do + fs <- getSessionDynFlags + (fs', _, _) <- parseDynamicFlags fs (map noLoc ghcOpts) + setSessionDynFlags fs' + return fs' + (result, _) <- initPackages f + return result + +-- | Docs state +type DocsM a = ErrorT String (StateT (Map String ModuleDocMap) IO) a + +-- | Run docs monad +runDocsM :: DocsM a -> IO (Either String a) +runDocsM act = evalStateT (runErrorT act) M.empty + +class DocInterface a where + getModule :: a -> Module + getDocMap :: a -> DocMap Name + getExports :: a -> [Name] + loadInterfaces :: [String] -> String -> IO [a] + +instance DocInterface InstalledInterface where + getModule = instMod + getDocMap = instDocMap + getExports = instExports + loadInterfaces opts m = do + d <- configSession opts + liftM (map snd) $ moduleInterface d (mkModuleName m) + +instance DocInterface Interface where + getModule = ifaceMod + getDocMap = ifaceDocMap + getExports = const [] -- ifaceExports + loadInterfaces opts m = createInterfaces (noOutput ++ map Flag_OptGhc opts) [m] 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) + +-- | 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 + +-- | 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 + +-- | Trim string +trim :: String -> String +trim = p . p where + p = reverse . dropWhile isSpace + +-- | Show the package name +showPackageName :: PackageIdentifier -> String +showPackageName = packageIdString . mkPackageId + +-- | Get the Haddock interfaces of the given package. +getHaddockInterfaceByPackage :: PackageConfig -> IO [Either String InterfaceFile] +getHaddockInterfaceByPackage = mapM (readInterfaceFile freshNameCache) . haddockInterfaces +
+ tests/Test.hs view
@@ -0,0 +1,15 @@+module Main ( + main + ) where + +import qualified Data.Map as M + +import System.Exit + +import HDocs.Module + +main :: IO () +main = do + edocs <- runDocsM (moduleDocs [] "Prelude") + mdocs <- either (\e -> putStrLn e >> exitFailure) (return . M.lookup "null") edocs + if fmap formatDoc mdocs == Just "Test whether a list is empty." then exitSuccess else exitFailure
+ tools/hdocs.hs view
@@ -0,0 +1,74 @@+module Main ( + main + ) where + +import Data.Aeson +import Data.ByteString.Lazy (ByteString, toStrict) +import Data.Maybe +import Data.Map (Map) +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 HDocs.Module + +import System.Console.GetOpt +import System.Environment +import System.FilePath +import System.IO + +data HDocsOptions = HDocsOptions { + optionJson :: Bool, + optionGHC :: [String] } + +instance Monoid HDocsOptions where + mempty = HDocsOptions False [] + mappend l r = HDocsOptions (optionJson l || optionJson r) (optionGHC l ++ optionGHC r) + +opts :: [OptDescr HDocsOptions] +opts = [ + Option ['j'] ["json"] (NoArg $ HDocsOptions True []) "output json", + Option ['g'] ["ghc"] (ReqArg (\s -> HDocsOptions False [s]) "GHC_OPT") "option to pass to GHC"] + +main :: IO () +main = do + hSetEncoding stdout utf8 + + (cfgs, cmds, _) <- fmap (getOpt Permute opts) getArgs + + let + cfg = mconcat cfgs + + toStr :: ByteString -> String + toStr = T.unpack . T.decodeUtf8 . toStrict + + showError :: Bool -> String -> String + showError False err = "Error: " ++ err + showError True err = toStr $ encode [ + T.pack "error" .= err] + showResult :: Bool -> Map String String -> String + showResult False rs = unlines $ concatMap (uncurry showResult') (M.toList rs) where + showResult' nm d = [nm ++ ":", d, ""] + showResult True rs = toStr $ encode rs + + loadDocs m f = do + docs <- runDocsM (docs (optionGHC cfg) m) + putStrLn $ either (showError isJson) (showResult isJson) (fmap (M.map formatDoc) docs >>= f) + where + isJson = optionJson cfg + + case cmds of + ["docs", m] -> loadDocs m return + ["docs", m, n] -> loadDocs m $ maybe (Left $ "Symbol '" ++ n ++ "' not found") (return . M.singleton n) . M.lookup n + _ -> printUsage + +printUsage :: IO () +printUsage = mapM_ putStrLn [ + "Usage:", + " hdocs docs <module> - get docs for module/file", + " hdocs docs <module> <name> - get docs for name in module/file", + "", + usageInfo "flags" opts]