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: 4.1.2 +version: 4.1.3 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 @@ -85,7 +85,8 @@ hs-source-dirs: src/main main-is: Main.hs build-depends: base > 4 && < 5, - haskell-docs + haskell-docs, + ghc test-suite test type: exitcode-stdio-1.0 diff --git a/src/Haskell/Docs.hs b/src/Haskell/Docs.hs --- a/src/Haskell/Docs.hs +++ b/src/Haskell/Docs.hs @@ -23,21 +23,24 @@ -- -- | Print the documentation of a name in the given module. searchAndPrintDoc :: Bool -- ^ Print modules only. + -> Bool -- ^ S-expression format. -> Maybe PackageName -- ^ Package. -> Maybe ModuleName -- ^ Module name. -> Identifier -- ^ Identifier. -> Ghc () -searchAndPrintDoc ms pname mname ident = +searchAndPrintDoc ms ss pname mname ident = do (result,printPkg,printModule) <- search case result of Left err -> error (show err) Right (sortBy (comparing identDocPackageName) -> docs) -> - mapM_ (\(i,doc') -> - do when (not ms && i > 0) - (liftIO (putStrLn "")) - printIdentDoc ms printPkg printModule doc') - (zip [0::Int ..] (nub docs)) + if ss + then printSexp (nub docs) + else mapM_ (\(i,doc') -> + do when (not ms && i > 0) + (liftIO (putStrLn "")) + printIdentDoc ms printPkg printModule doc') + (zip [0::Int ..] (nub docs)) where search = case (pname,mname) of (Just p,Just m) -> fmap (,False,False) (searchPackageModuleIdent Nothing p m ident) diff --git a/src/Haskell/Docs/Formatting.hs b/src/Haskell/Docs/Formatting.hs --- a/src/Haskell/Docs/Formatting.hs +++ b/src/Haskell/Docs/Formatting.hs @@ -17,6 +17,10 @@ -- * Formatting +-- | Print docs as s-expressions. +printSexp :: [IdentDoc] -> Ghc () +printSexp = mapM toSexp >=> liftIO . putStrLn . renderSexp . List + -- | Print an identifier' documentation. printIdentDoc :: Bool -- ^ Print modules only? -> Bool -- ^ Print package? @@ -50,6 +54,34 @@ formatDoc = trim . doc where -- * Internal functions + +-- | S-expression type. +data Sexp + = Atom String + | String String + | List [Sexp] + +-- | Render an s-expression to string. +renderSexp :: Sexp -> String +renderSexp (Atom string) = string +renderSexp (String string) = show string +renderSexp (List sexps) = "(" ++ intercalate " " (map renderSexp sexps) ++ ")" + +-- | Convert docs to an s-expression. +toSexp :: IdentDoc -> Ghc Sexp +toSexp idoc = + do d <- getSessionDynFlags + return (List (concat (object d))) + where + object d = + [[List [Atom "package",String (showPackageName (identDocPackageName idoc))]] + ,[List [Atom "module",String (showppr d (moduleName (nameModule (getName i))))] + |Just i <- [identDocIdent idoc]] + ,[List [Atom "type",String (showppr d (idType i))] + |Just i <- [identDocIdent idoc]] + ,[List [Atom "arguments",List ((map (\(i,x) -> String (formatArg i x)) args))] + |Just args <- [identDocArgDocs idoc]] + ,[List [Atom "documentation",String (formatDoc (identDocDocs idoc))]]] -- | Render the doc. doc :: Doc String -> String diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -1,53 +1,83 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -- | Main command-line interface. module Main where -import Haskell.Docs -import Haskell.Docs.Types -import Haskell.Docs.Ghc +import Haskell.Docs +import Haskell.Docs.Ghc +import Haskell.Docs.Types +import Control.Exception +import Control.Exception (IOException) import qualified Control.Exception as E -import System.Environment +import GHC +import GhcMonad +import System.Environment +import System.Exit +import System.IO -- | Main entry point. main :: IO () main = do args <- getArgs - E.catch - (app args) - (error . printEx) + app args -- | Do the printing. app :: [String] -> IO () -app (extract -> (gs,ms,as)) = +app (extract -> (gs,ms,as,ss)) = withInitializedPackages gs - (case as of - [name] -> - searchAndPrintDoc ms - Nothing - Nothing - (Identifier name) - [mname,name,pname] -> - searchAndPrintDoc ms - (Just (PackageName pname)) - (Just (makeModuleName mname)) - (Identifier name) - [mname,name] -> - searchAndPrintDoc ms - Nothing - (Just (makeModuleName mname)) - (Identifier name) - _ -> error " [] | ") + (catchErrors + (case as of + [name] -> + searchAndPrintDoc ms + ss + Nothing + Nothing + (Identifier name) + [mname,name,pname] -> + searchAndPrintDoc ms + ss + (Just (PackageName pname)) + (Just (makeModuleName mname)) + (Identifier name) + [mname,name] -> + searchAndPrintDoc ms + ss + Nothing + (Just (makeModuleName mname)) + (Identifier name) + _ -> bail " [] | \n\ + \\n\ + \Options: --g Specify GHC options.\n\ + \ --sexp Output s-expressions.\n\ + \ --modules Only output modules.")) -- | Extract arguments. -extract :: [String] -> ([String],Bool,[String]) -extract = go ([],False,[]) - where go (gs,ms,as) ("-g":arg:ys) = go (arg:gs,ms,as) ys - go (gs,ms,as) ("--modules":ys) = go (gs,True,as) ys - go (gs,ms,as) (y:ys) = go (gs,ms,y:as) ys - go (gs,ms,as) [] = (gs,ms,as) +extract :: [String] -> ([String],Bool,[String],Bool) +extract = go ([],False,[],False) + where + go (gs,ms,as,ss) ("-g":arg:ys) = go (arg:gs,ms,as,ss) ys + go (gs,ms,as,ss) ("--modules":ys) = go (gs,True,as,ss) ys + go (gs,ms,as,ss) ("--sexp":ys) = go (gs,ms,as,True) ys + go (gs,ms,as,ss) (y:ys) = go (gs,ms,y:as,ss) ys + go (gs,ms,as,ss) [] = (gs,ms,as,ss) + +-- | Catch errors and print 'em out. +catchErrors :: Ghc () -> Ghc () +catchErrors m = + gcatch (gcatch m + (\x -> + do bail (printEx x) + liftIO exitFailure)) + (\(e::SomeException) -> + bail (show e)) + +-- | Print an error and bail out. +bail :: String -> Ghc () +bail e = + liftIO (hPutStrLn stderr e) -- | Print an exception for humans. printEx :: DocsException -> String diff --git a/src/test/Main.hs b/src/test/Main.hs --- a/src/test/Main.hs +++ b/src/test/Main.hs @@ -36,6 +36,7 @@ [] (void (searchAndPrintDoc False + False Nothing (Just (makeModuleName "System.IO")) (Identifier "hSetBuffering")))) @@ -44,6 +45,7 @@ [] (void (searchAndPrintDoc False + False Nothing Nothing (Identifier "hSetBuffering")))) @@ -55,6 +57,7 @@ (withInitializedPackages [] (do void (searchAndPrintDoc + False False Nothing (Just (makeModuleName "System.IO"))