Move IO-dependent config of HTML test suite to test package.

2 files changed, 145 insertions, 121 deletions

diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index af2a460b..b9444c3e 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -1,8 +1,30 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
 module Test.Haddock.Config where
 
 
+import Control.Applicative
+import Control.Monad
+
+import qualified Data.List as List
+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
+
 import System.Console.GetOpt
+import System.Directory
+import System.Exit
+import System.Environment
 import System.FilePath
+import System.IO
 
 import Test.Haddock.Process
 import Test.Haddock.Utils
@@ -12,6 +34,7 @@ data DirConfig = DirConfig
     { dcfgSrcDir :: FilePath
     , dcfgRefDir :: FilePath
     , dcfgOutDir :: FilePath
+    , dcfgResDir :: FilePath
     }
 
 
@@ -20,12 +43,14 @@ defaultDirConfig baseDir = DirConfig
     { dcfgSrcDir = baseDir </> "src"
     , dcfgRefDir = baseDir </> "ref"
     , dcfgOutDir = baseDir </> "out"
+    , dcfgResDir = rootDir </> "resources"
     }
+  where
+    rootDir = baseDir </> ".."
 
 
 data Config = Config
     { cfgHaddockPath :: FilePath
-    , cfgGhcPath :: FilePath
     , cfgFiles :: [FilePath]
     , cfgHaddockArgs :: [String]
     , cfgHaddockStdOut :: FilePath
@@ -35,10 +60,11 @@ data Config = Config
     }
 
 
-cfgSrcDir, cfgRefDir, cfgOutDir :: Config -> FilePath
+cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config -> FilePath
 cfgSrcDir = dcfgSrcDir . cfgDirConfig
 cfgRefDir = dcfgRefDir . cfgDirConfig
 cfgOutDir = dcfgOutDir . cfgDirConfig
+cfgResDir = dcfgResDir . cfgDirConfig
 
 
 data Flag
@@ -90,3 +116,118 @@ options =
     , Option ['h'] ["help"] (NoArg FlagHelp)
         "display this help end exit"
     ]
+
+
+checkOpt :: [String] -> IO ([Flag], [String])
+checkOpt args = do
+    let (flags, files, errors) = getOpt Permute options args
+
+    unless (null errors) $ do
+        hPutStr stderr $ concat errors
+        exitFailure
+
+    when (FlagHelp `elem` flags) $ do
+        hPutStrLn stderr $ usageInfo "" options
+        exitSuccess
+
+    return (flags, files)
+
+
+loadConfig :: DirConfig -> [Flag] -> [String] -> IO Config
+loadConfig cfgDirConfig@(DirConfig { .. }) flags files = do
+    cfgEnv <- (:) ("haddock_datadir", dcfgResDir) <$> getEnvironment
+
+    systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment
+    cfgHaddockPath <- case flagsHaddockPath flags <|> systemHaddockPath of
+        Just path -> pure path
+        Nothing -> do
+            hPutStrLn stderr $ "Haddock executable not specified"
+            exitFailure
+
+    ghcPath <- init <$> rawSystemStdout normal cfgHaddockPath
+        ["--print-ghc-path"]
+
+    printVersions cfgEnv cfgHaddockPath
+
+    cfgFiles <- processFileArgs cfgDirConfig files
+
+    cfgHaddockArgs <- liftM concat . sequence $
+        [ pure ["--no-warnings"]
+        , pure ["--odir=" ++ dcfgOutDir]
+        , pure ["--pretty-html"]
+        , pure ["--html"]
+        , pure ["--optghc=-w"]
+        , pure $ flagsHaddockOptions flags
+        , baseDependencies ghcPath
+        ]
+
+    let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags)
+
+    cfgDiffTool <- if FlagNoDiff `elem` flags
+        then pure Nothing
+        else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool
+
+    return $ Config { .. }
+
+
+printVersions :: Environment -> FilePath -> IO ()
+printVersions env haddockPath = do
+    handleHaddock <- runProcess' haddockPath $ processConfig
+        { pcEnv = Just env
+        , pcArgs = ["--version"]
+        }
+    waitForSuccess "Failed to run `haddock --version`" handleHaddock
+
+    handleGhc <- runProcess' haddockPath $ processConfig
+        { pcEnv = Just env
+        , pcArgs = ["--ghc-version"]
+        }
+    waitForSuccess "Failed to run `haddock --ghc-version`" handleGhc
+
+
+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
+
+
+defaultDiffTool :: IO (Maybe FilePath)
+defaultDiffTool =
+    liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"]
+  where
+    isAvailable = liftM isJust . findProgramLocation silent
+
+
+processFileArgs :: DirConfig -> [String] -> IO [FilePath]
+processFileArgs dcfg [] =
+    map toModulePath . filter isSourceFile <$> getDirectoryContents srcDir
+  where
+    srcDir = dcfgSrcDir dcfg
+    toModulePath = modulePath dcfg . takeBaseName
+processFileArgs dcfg args = pure $ map (processFileArg dcfg) args
+
+
+processFileArg :: DirConfig -> String -> FilePath
+processFileArg dcfg arg
+    | isSourceFile arg = arg
+    | otherwise = modulePath dcfg arg
+
+
+isSourceFile :: FilePath -> Bool
+isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
+
+
+modulePath :: DirConfig -> String -> FilePath
+modulePath dcfg mdl = dcfgSrcDir dcfg </> mdl <.> "hs"
diff --git a/html-test/run.hs b/html-test/run.hs
index e96943a0..5a2944f9 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -9,15 +9,6 @@ import Control.Monad
 import Data.Maybe
 import Data.List
 
-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
-
 import System.Console.GetOpt
 import System.Directory
 import System.Environment
@@ -54,7 +45,8 @@ data CheckResult
 
 main :: IO ()
 main = do
-    cfg <- uncurry loadConfig =<< checkOpt =<< getArgs
+    let dcfg = defaultDirConfig baseDir
+    cfg <- uncurry (loadConfig dcfg) =<< checkOpt =<< getArgs
     runHaddock cfg
     checkFiles cfg
 
@@ -101,54 +93,6 @@ runHaddock (Config { .. }) = do
     waitForSuccess "Failed to run Haddock on specified test files" handle
 
 
-checkOpt :: [String] -> IO ([Flag], [String])
-checkOpt args = do
-    let (flags, files, errors) = getOpt Permute options args
-
-    unless (null errors) $ do
-        hPutStr stderr $ concat errors
-        exitFailure
-
-    when (FlagHelp `elem` flags) $ do
-        hPutStrLn stderr $ usageInfo "" options
-        exitSuccess
-
-    return (flags, files)
-
-
-loadConfig :: [Flag] -> [String] -> IO Config
-loadConfig flags files = do
-    cfgEnv <- (:) ("haddock_datadir", resDir) <$> getEnvironment
-
-    cfgHaddockPath <- pure $ flip fromMaybe (flagsHaddockPath flags) $
-        rootDir </> "dist" </> "build" </> "haddock" </> "haddock"
-
-    printVersions cfgEnv cfgHaddockPath
-
-    cfgGhcPath <- flip fromMaybe (flagsGhcPath flags) <$>
-         init <$> rawSystemStdout normal cfgHaddockPath ["--print-ghc-path"]
-
-    cfgFiles <- processFileArgs files
-
-    cfgHaddockArgs <- liftM concat . sequence $
-        [ pure ["--no-warnings"]
-        , pure ["--odir=" ++ outDir]
-        , pure ["--pretty-html"]
-        , pure ["--html"]
-        , pure ["--optghc=-w"]
-        , pure $ flagsHaddockOptions flags
-        , baseDependencies cfgGhcPath
-        ]
-
-    let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags)
-
-    cfgDiffTool <- if FlagNoDiff `elem` flags
-        then pure Nothing
-        else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool
-
-    return $ Config { .. }
-
-
 checkModule :: String -> IO CheckResult
 checkModule mdl = do
     hasRef <- doesFileExist $ refFile mdl
@@ -191,67 +135,6 @@ refFile :: String -> FilePath
 refFile mdl = refDir </> mdl <.> "html"
 
 
-printVersions :: Environment -> FilePath -> IO ()
-printVersions env haddockPath = do
-    handle <- runProcess' haddockPath $ processConfig
-        { pcEnv = Just env
-        , pcArgs = ["--version"]
-        }
-    waitForSuccess "Failed to run `haddock --version`" handle
-
-    handle <- runProcess' haddockPath $ processConfig
-        { pcEnv = Just env
-        , pcArgs = ["--ghc-version"]
-        }
-    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
-
-
-defaultDiffTool :: IO (Maybe FilePath)
-defaultDiffTool =
-    liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"]
-  where
-    isAvailable = liftM isJust . findProgramLocation silent
-
-
-processFileArgs :: [String] -> IO [FilePath]
-processFileArgs [] =
-    map toModulePath . filter isSourceFile <$> getDirectoryContents srcDir
-  where
-    toModulePath = modulePath . takeBaseName
-processFileArgs args = pure $ map processFileArg args
-
-
-processFileArg :: String -> FilePath
-processFileArg arg
-    | isSourceFile arg = arg
-    | otherwise = modulePath arg
-
-
-isSourceFile :: FilePath -> Bool
-isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
-
-modulePath :: String -> FilePath
-modulePath mdl = srcDir </> mdl <.> "hs"
-
-
 -- *** OLD TEST RUNNER UTILITY FUNCTIONS ***
 -- These are considered bad and should be replaced as soon as possible.