From da76b1b4ea86ad8b27f722ad803be40b512c9e00 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 4 Aug 2015 14:09:20 +0200
Subject: Extend test runner configuration with Haddock arguments.

---
 html-test/run.hs | 48 +++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 45 insertions(+), 3 deletions(-)

diff --git a/html-test/run.hs b/html-test/run.hs
index 829b5704..3a421be7 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -7,6 +7,12 @@ import Control.Monad
 
 import Data.Maybe
 
+import Distribution.InstalledPackageInfo
+import Distribution.Package
+import Distribution.Simple.Compiler hiding (Flag)
+import Distribution.Simple.GHC
+import Distribution.Simple.PackageIndex
+import Distribution.Simple.Program
 import Distribution.Simple.Utils
 import Distribution.Verbosity
 
@@ -36,13 +42,14 @@ data Config = Config
     { cfgHaddockPath :: FilePath
     , cfgGhcPath :: FilePath
     , cfgFiles :: [FilePath]
-    }
+    , cfgHaddockArgs :: [String]
+    } deriving Show
 
 
 main :: IO ()
 main = do
-    Config { .. } <- loadConfig =<< getArgs
-    return ()
+    cfg <- loadConfig =<< getArgs
+    putStrLn $ show cfg
 
 
 loadConfig :: [String] -> IO Config
@@ -69,6 +76,15 @@ loadConfig args = do
 
     cfgFiles <- processFileArgs files
 
+    cfgHaddockArgs <- liftM concat . sequence $
+        [ pure ["--no-warnings"]
+        , pure ["--odir=" ++ outDir]
+        , pure ["--pretty-html"]
+        , pure ["--optghc=--w"]
+        , pure $ flagsHaddockOptions flags
+        , baseDependencies cfgGhcPath
+        ]
+
     return $ Config { .. }
 
 
@@ -87,6 +103,24 @@ printVersions env haddockPath = do
     waitForSuccess "Failed to run `haddock --ghc-version`" handle
 
 
+baseDependencies :: FilePath -> IO [String]
+baseDependencies ghcPath = do
+    (_, _, cfg) <- configure normal (Just ghcPath) Nothing
+        defaultProgramConfiguration
+    pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg
+    mapM (getDependency pkgIndex) ["base", "process", "ghc-prim"]
+  where
+    getDependency pkgIndex name = case ifaces pkgIndex name of
+        [] -> do
+            hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name
+            exitFailure
+        (ifArg:_) -> pure ifArg
+    ifaces pkgIndex name = do
+        pkg <- join $ snd <$> lookupPackageName pkgIndex (PackageName name)
+        iface <$> haddockInterfaces pkg <*> haddockHTMLs pkg
+    iface file html = "--read-interface=" ++ html ++ "," ++ file
+
+
 processFileArgs :: [String] -> IO [FilePath]
 processFileArgs [] = filter isSourceFile <$> getDirectoryContents srcDir
 processFileArgs args = pure $ map processFileArg args
@@ -105,6 +139,7 @@ isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
 data Flag
     = FlagHaddockPath FilePath
     | FlagGhcPath FilePath
+    | FlagHaddockOptions String
     | FlagHelp
     deriving Eq
 
@@ -115,6 +150,8 @@ options =
         "path to Haddock executable to exectue tests with"
     , Option [] ["ghc-path"] (ReqArg FlagGhcPath "FILE")
         "path to GHC executable"
+    , Option [] ["haddock-options"] (ReqArg FlagHaddockOptions "OPTS")
+        "additional options to run Haddock with"
     , Option ['h'] ["help"] (NoArg FlagHelp)
         "display this help end exit"
     ]
@@ -128,6 +165,11 @@ flagsGhcPath :: [Flag] -> Maybe FilePath
 flagsGhcPath flags = mlast [ path | FlagGhcPath path <- flags ]
 
 
+flagsHaddockOptions :: [Flag] -> [String]
+flagsHaddockOptions flags = concat
+    [ words opts | FlagHaddockOptions opts <- flags ]
+
+
 data ProcessConfig = ProcessConfig
     { pcArgs :: [String]
     , pcWorkDir :: Maybe FilePath
-- 
cgit v1.2.3