From 33b2e1540a16e45a1f144d0ac75799a549631b40 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 11 Dec 2014 18:46:27 +0200
Subject: [PATCH] Update Haddock file refs

---
 Stackage/Test.hs          |  1 +
 Stackage2/PerformBuild.hs | 20 +++++++++++++-------
 2 files changed, 14 insertions(+), 7 deletions(-)

diff --git a/Stackage/Test.hs b/Stackage/Test.hs
index 1fdd0a5a..19210abe 100644
--- a/Stackage/Test.hs
+++ b/Stackage/Test.hs
@@ -232,6 +232,7 @@ runTestSuite cabalVersion settings testdir docdir
                 : "--hyperlink-source"
                 : "--html"
                 : "--hoogle"
+                -- FIXME is this redundant with read-interface above?
                 : "--html-location=../$pkg-$version/"
                 : hfsOpts) dir
             let PackageName packageName' = packageName
diff --git a/Stackage2/PerformBuild.hs b/Stackage2/PerformBuild.hs
index 672ab5cc..ca170564 100644
--- a/Stackage2/PerformBuild.hs
+++ b/Stackage2/PerformBuild.hs
@@ -309,15 +309,16 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
                     (childDir </> "dist" </> "doc" </> "html" </> fpFromText name)
                     (pbDocDir pb </> fpFromText namever)
 
-                {-
                 enewPath <- tryIO
                           $ canonicalizePath
-                          $ docdir </> package </> packageName' <.> "haddock"
+                          $ pbDocDir pb
+                        </> fpFromText namever
+                        </> fpFromText name <.> "haddock"
                 case enewPath of
-                    Left _ -> return () -- print e
-                    Right newPath -> atomicModifyIORef haddockFilesRef $ \hfs'
-                        -> ((package, newPath) : hfs', ())
-                        -}
+                    Left e -> warn $ tshow e
+                    Right newPath -> atomically
+                                   $ modifyTVar sbHaddockFiles
+                                   $ insertMap namever newPath
 
             case (eres, pcHaddocks) of
                 (Left e, ExpectSuccess) -> throwM e
@@ -345,7 +346,12 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
 
     warn t = atomically $ modifyTVar sbWarningsVar (. (t:))
 
-    updateErrs exc =
+    updateErrs exc = do
+        log' $ concat
+            [ display (piName sbPackageInfo)
+            , ": "
+            , tshow exc
+            ]
         atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc'
       where
         exc' =