From d371bb27b70d71fd103dc954f2198cefacfbbffc Mon Sep 17 00:00:00 2001
From: Nathaniel Wesley Filardo <nwf@cs.jhu.edu>
Date: Sat, 18 May 2013 15:14:00 -0400
Subject: [PATCH] Try harder to build all haddocks at once

This is a pretty nasty hack which involves shell scripting and a small
program to go digging through Cabal internals.
---
 Makefile                     | 45 +++++++++++++++---------
 src/Dyna/XXX/HaddockPaths.hs | 68 ++++++++++++++++++++++++++++++++++++
 2 files changed, 97 insertions(+), 16 deletions(-)
 create mode 100644 src/Dyna/XXX/HaddockPaths.hs

diff --git a/Makefile b/Makefile
index c77e9cf..a74250d 100644
--- a/Makefile
+++ b/Makefile
@@ -17,6 +17,34 @@ build:
 	cabal build
 	cabal test
 
+tests:
+	dist/build/dyna-selftests/dyna-selftests
+
+.PHONY: clean veryclean
+clean:
+	rm -rf examples/*.dyna.plan  \
+           examples/*.dyna.*.out \
+           examples/*.dyna.d
+	rm -f tags TAGS
+veryclean: clean
+	rm -rf dist
+
+run-parser:
+	ghci -isrc Dyna.ParserHS.Parser
+
+# Cabal's haddock integration is sort of sad; since I want to have
+# everything we use in one place, run haddock by hand.  This still isn't
+# perfect, but it does OK.
+
+HADDOCK_HTML ?= "../\\$$pkgid/html"
+haddock:
+	mkdir -p dist/alldoc
+	haddock --html -o dist/alldoc \
+	 --ignore-all-exports -w --optghc=-isrc \
+	 -t "Dyna -- GIT `git describe --always`" \
+	 `runghc -isrc Dyna.XXX.HaddockPaths "$(HADDOCK_HTML)"` \
+	 `grep -ie '^\( \|\t\)*main-is:' dyna.cabal | sed -e "s/^.*Is: */src\//"`
+
 # If the cabal file doesn't do the right thing, this tries to work through
 # it all by hand.  Blech!  But it's better than nothing.
 ghcbuild:
@@ -35,7 +63,7 @@ ghcbuild:
 		-main-is Dyna.Main.TestsDriver Dyna.Main.TestsDriver
 
 # Every now and again we need to make a profiling build of some component
-# of the tree.  Se MAINMOD and MAINFILE and make this target.
+# of the tree.  Set MAINMOD and MAINFILE and make this target.
 profbuild:
 	mkdir -p dist/pb
 	ghc --make -isrc \
@@ -47,20 +75,5 @@ profbuild:
 		 -outputdir dist/pb \
 		 -main-is $(MAINMOD) $(MAINFILE)
 
-tests:
-	dist/build/dyna-selftests/dyna-selftests
-
-run-parser:
-	ghci -isrc Dyna.ParserHS.Parser
-
-.PHONY: clean veryclean
-clean:
-	rm -rf examples/*.dyna.plan  \
-           examples/*.dyna.*.out \
-           examples/*.dyna.d
-	rm -f tags TAGS
-veryclean: clean
-	rm -rf dist
-
 tags TAGS:
 	hasktags -b src
diff --git a/src/Dyna/XXX/HaddockPaths.hs b/src/Dyna/XXX/HaddockPaths.hs
new file mode 100644
index 0000000..62e36b0
--- /dev/null
+++ b/src/Dyna/XXX/HaddockPaths.hs
@@ -0,0 +1,68 @@
+-- | This is a little program which integrates with Cabal to extract the
+-- @--read-interface@ options that we should be passing to Haddock, based on
+-- our cabal configuration.
+--
+-- It expects to be called with one argument, the HTML path template for
+-- imported objects.  See the Makefile for an example.
+--
+-- Much of this file is lifted in whole or in part from Cabal's internals,
+-- especially Distribution.Simple.Haddock.  As such, it is placed under
+-- the same license as Cabal.
+
+{-# LANGUAGE ScopedTypeVariables #-}
+module Dyna.XXX.HaddockPaths where
+
+import           Control.Monad
+import           Data.Either
+import           Data.IORef
+import           Data.List
+import           Data.Maybe
+import qualified Data.Set as S
+import           Distribution.InstalledPackageInfo
+import           Distribution.Package
+import           Distribution.Simple.Configure
+import           Distribution.Simple.LocalBuildInfo
+import           Distribution.Simple.PackageIndex
+import           Distribution.Text
+import           System.Environment
+import           System.Directory
+import           System.IO
+
+main :: IO ()
+main = do
+  [hpt] <- getArgs
+  lbi <- getPersistBuildConfig "dist"
+  sr <- newIORef (S.empty)
+  withComponentsLBI (localPkgDescr lbi) lbi (cb (toPathTemplate hpt) lbi sr)
+  readIORef sr >>= mapM_ (putStrLn . showif) . S.toList
+ where
+  cb hpt lbi sr (_ :: Component) clbi = do
+    let directDeps = map fst (componentPackageDeps clbi)
+    let Left transitiveDeps = dependencyClosure (installedPkgs lbi) directDeps
+    interfaces <- sequence
+      [ case interfaceAndHtmlPath lbi hpt ipkg of
+          Nothing -> return (Left (packageId ipkg))
+          Just (interface, html) -> do
+            exists <- doesFileExist interface
+            if exists
+              then return (Right (interface, html))
+              else return (Left (packageId ipkg))
+      | ipkg <- allPackages transitiveDeps
+      ]
+    let (missing,found) = partitionEithers interfaces
+
+    when (not $ null missing) $ do
+      hPutStrLn stderr $ "MISSING: [" ++ intercalate "," (map display missing) ++ "]"
+
+    mapM_ (modifyIORef sr . S.insert) found
+
+  showif (i,mh) = "--read-interface=" ++ mh ++"," ++ i
+
+  interfaceAndHtmlPath :: LocalBuildInfo 
+                       -> PathTemplate
+                       -> InstalledPackageInfo
+                       -> Maybe (FilePath, FilePath)
+  interfaceAndHtmlPath lbi hpt pkg = do
+    interface <- listToMaybe (haddockInterfaces pkg)
+    let html = substPathTemplate (packageId pkg) lbi hpt
+    return (interface, html)
-- 
2.50.1