diff options
| -rw-r--r-- | haddock-test/src/Test/Haddock/Config.hs | 145 | ||||
| -rwxr-xr-x | html-test/run.hs | 121 |
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. |