From 23281f787a412ebc54c3e3074ed49327f2942e6c Mon Sep 17 00:00:00 2001
From: ross <unknown>
Date: Wed, 18 May 2005 12:41:59 +0000
Subject: [haddock @ 2005-05-18 12:41:59 by ross] fix 3 bugs in --use-package,
 and document it.

---
 src/Main.hs | 40 +++++++++++++++++-----------------------
 1 file changed, 17 insertions(+), 23 deletions(-)

(limited to 'src/Main.hs')

diff --git a/src/Main.hs b/src/Main.hs
index 3599d6da..deda34ca 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -371,8 +371,21 @@ getPackageIfaces flags verbose =
 		  return Nothing)
 
   getPkgIface' pkg = do
+	html <- getPkgField pkg "haddock-html"
+	html_exists <- doesDirectoryExist html
+	when (not html_exists) $ do
+	   throwIO (ErrorCall ("HTML directory " ++ html ++ " does not exist."))
+
+	iface <- getPkgField pkg "haddock-interfaces"
+	iface_exists <- doesFileExist iface
+	when (not iface_exists) $ do
+	   throwIO (ErrorCall ("interface " ++ iface ++ " does not exist."))
+
+	return (Just (html, iface))
+
+  getPkgField pkg field = do
 	(hin,hout,herr,p) <- runInteractiveProcess hc_pkg 
-				["field", "haddock-interfaces", pkg]
+				["field", pkg, field]
 				Nothing Nothing
 	hClose hin
 	out <- hGetContents hout
@@ -380,29 +393,10 @@ getPackageIfaces flags verbose =
 	r <- waitForProcess p
 	when (r /= ExitSuccess) $
 	   throwIO (ErrorCall ("ghc-pkg failed"))
-	let iface = dropWhile isSpace (tail (dropWhile (/=':') out))
-
-	(hin,hout,herr,p) <- runInteractiveProcess hc_pkg
-	  			["field", "haddock-html", pkg]
-				Nothing Nothing
-	hClose hin
-	forkIO (hGetContents herr >> return ()) -- just sink the stderr
-	out <- hGetContents hout
-	r <- waitForProcess p
-	when (r /= ExitSuccess) $
-	   throwIO (ErrorCall ("ghc-pkg failed"))
-	let html = dropWhile isSpace (tail (dropWhile (/=':') out))
-
+	let value = dropWhile isSpace $ init $ tail $ dropWhile (/=':') out
 	when verbose $ 
-	   putStrLn ("   interface: " ++ iface ++ "\n   html: " ++ html)
-
-	iface_exists <- doesFileExist iface
-	when (not iface_exists) $ do
-	   throwIO (ErrorCall ("interface " ++ iface ++ " does not exist."))
-	html_exists <- doesDirectoryExist html
-	when (not html_exists) $ do
-	   throwIO (ErrorCall ("HTML directory " ++ html ++ " does not exist."))
-	return (Just (iface, html))
+	   putStrLn ("   " ++ field ++ ": " ++ value)
+	return value
 #endif
 
 -----------------------------------------------------------------------------
-- 
cgit v1.2.3