hdocs 0.1.0.0 → 0.2.0.0

raw patch · 4 files changed

+56/−49 lines, 4 filesdep +aeson-pretty

Dependencies added: aeson-pretty

Files

• hdocs.cabal +6/−9
• src/HDocs/Module.hs +26/−20
• tests/Test.hs +7/−1
• tools/hdocs.hs +17/−19

@@ -1,18 +1,15 @@--- 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
+version:             0.2.0.0
+synopsis:            Haskell docs tool
 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
+  hdocs <module> - get docs for module/file
+  hdocs <module> <name> - get docs for name in module/file
   flags
-  -j          --json         output json
+  --pretty          pretty JSON output
   -g GHC_OPT  --ghc=GHC_OPT  option to pass to GHC
   @
 homepage:            https://github.com/mvoidex/hdocs
@@ -20,7 +17,6 @@ license-file:        LICENSE
 author:              Alexandr `Voidex` Ruchkin
 maintainer:          voidex@live.com
--- copyright:           
 category:            Development
 build-type:          Simple
 cabal-version:       >=1.8
@@ -52,6 +48,7 @@     base == 4.6.*,
     hdocs,
     aeson == 0.6.*,
+    aeson-pretty == 0.7.*,
     bytestring == 0.10.*,
     containers == 0.5.*,
     filepath == 1.3.*,

@@ -18,6 +18,7 @@ 	) where
 
 import Control.Arrow
+import Control.Exception
 import Control.Monad.State
 import Control.Monad.Error
 
@@ -33,6 +34,7 @@ import DynFlags
 import GHC
 import GHC.Paths (libdir)
+import qualified GhcMonad as GHC (liftIO)
 import Module
 import Name (getOccString, occNameString)
 import Packages
@@ -40,31 +42,34 @@ -- | 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
+withInitializedPackages :: [String] -> (DynFlags -> IO a) -> IO a
+withInitializedPackages ghcOpts cont = do
+	runGhc (Just libdir) $ do
 		fs <- getSessionDynFlags
-		setSessionDynFlags fs
-		return fs
-	(fs', _) <- initPackages fs
-	cont fs'
+		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
-	f <- defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do
+	runGhc (Just libdir) $ do
 		fs <- getSessionDynFlags
-		(fs', _, _) <- parseDynamicFlags fs (map noLoc ghcOpts)
-		setSessionDynFlags fs'
-		return fs'
-	(result, _) <- initPackages f
-	return result
+		defaultCleanupHandler fs $ do
+			(fs', _, _) <- parseDynamicFlags fs (map noLoc ghcOpts)
+			setSessionDynFlags fs'
+			(result, _) <- GHC.liftIO $ initPackages fs'
+			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
+runDocsM act = catch (evalStateT (runErrorT act) M.empty) onError where
+	onError :: SomeException -> IO (Either String a)
+	onError = return . Left . show
 
 class DocInterface a where
 	getModule :: a -> Module
@@ -76,18 +81,19 @@ 	getModule = instMod
 	getDocMap = instDocMap
 	getExports = instExports
-	loadInterfaces opts m = do
-		d <- configSession opts
+	loadInterfaces opts m = withInitializedPackages opts $ \d ->
 		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]
+	loadInterfaces opts m = do
+		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

@@ -2,14 +2,20 @@ 	main
 	) where
 
+import Control.Monad
 import qualified Data.Map as M
 
 import System.Exit
 
 import HDocs.Module
 
+-- | 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
-	if fmap formatDoc mdocs == Just "Test whether a list is empty." then exitSuccess else exitFailure
+	when (fmap formatDoc mdocs /= Just "Test whether a list is empty.") exitFailure
+	exitSuccess

@@ -3,6 +3,7 @@ 	) where
 
 import Data.Aeson
+import Data.Aeson.Encode.Pretty (encodePretty)
 import Data.ByteString.Lazy (ByteString, toStrict)
 import Data.Maybe
 import Data.Map (Map)
@@ -21,16 +22,16 @@ import System.IO
 
 data HDocsOptions = HDocsOptions {
-	optionJson :: Bool,
+	optionPretty :: Bool,
 	optionGHC :: [String] }
 
 instance Monoid HDocsOptions where
 	mempty = HDocsOptions False []
-	mappend l r = HDocsOptions (optionJson l || optionJson r) (optionGHC l ++ optionGHC r)
+	mappend l r = HDocsOptions (optionPretty l || optionPretty r) (optionGHC l ++ optionGHC r)
 
 opts :: [OptDescr HDocsOptions]
 opts = [
-	Option ['j'] ["json"] (NoArg $ HDocsOptions True []) "output json",
+	Option [] ["pretty"] (NoArg $ HDocsOptions True []) "pretty JSON output",
 	Option ['g'] ["ghc"] (ReqArg (\s -> HDocsOptions False [s]) "GHC_OPT") "option to pass to GHC"]
 
 main :: IO ()
@@ -41,34 +42,31 @@ 
 	let
 		cfg = mconcat cfgs
+		isPretty = optionPretty cfg
 
-		toStr :: ByteString -> String
-		toStr = T.unpack . T.decodeUtf8 . toStrict
+		toStr :: ToJSON a => a -> String
+		toStr = T.unpack . T.decodeUtf8 . toStrict . encode' where
+			encode'
+				| isPretty = encodePretty
+				| otherwise = encode
 
-		showError :: Bool -> String -> String
-		showError False err = "Error: " ++ err
-		showError True err = toStr $ encode [
+		jsonError :: String -> Value
+		jsonError err = object [
 			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
+			putStrLn $ either (toStr . jsonError) toStr (fmap (M.map formatDoc) docs >>= f)
 
 	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
+		[m] -> loadDocs m return
+		[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",
+	"  hdocs <module> - get docs for module/file",
+	"  hdocs <module> <name> - get docs for name in module/file",
 	"",
 	usageInfo "flags" opts]