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.

diff --git a/Makefile b/Makefile
index c77e9cf13da617e8f9cc02dbca159ffd11956340..a74250d0064139507bde63ca503213ea2d9744f1 100644 (file)
--- 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 (file)
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)