From 6a2c16a0b0790ca0f3a30be8a6e96c7818514ff6 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 14:33:29 +0200
Subject: Move IO-dependent config of HTML test suite to test package.

---
 haddock-test/src/Test/Haddock/Config.hs | 145 +++++++++++++++++++++++++++++++-
 1 file changed, 143 insertions(+), 2 deletions(-)

(limited to 'haddock-test/src')

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"
-- 
cgit v1.2.3