{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module Test.Haddock.Config ( TestPackage(..), CheckConfig(..), DirConfig(..), Config(..) , defaultDirConfig , cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir , parseArgs, checkOpt, loadConfig ) where import Control.Applicative import Control.Monad import qualified Data.List as List import Data.Maybe import Distribution.Text import Distribution.Types.PackageName import Distribution.InstalledPackageInfo import Distribution.Simple.Compiler 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 data TestPackage = TestPackage { tpkgName :: String , tpkgFiles :: [FilePath] } data CheckConfig c = CheckConfig { ccfgRead :: String -> Maybe c -- ^ @f contents@ parses file contents @contents@ to -- produce a thing to be compared. , ccfgClean :: String -> c -> c -- ^ @f fname x@ cleans @x@ to such that it can be compared , ccfgDump :: c -> String , ccfgEqual :: c -> c -> Bool } data DirConfig = DirConfig { dcfgSrcDir :: FilePath , dcfgRefDir :: FilePath , dcfgOutDir :: FilePath , dcfgResDir :: FilePath , dcfgCheckIgnore :: FilePath -> Bool } defaultDirConfig :: FilePath -> DirConfig defaultDirConfig baseDir = DirConfig { dcfgSrcDir = baseDir </> "src" , dcfgRefDir = baseDir </> "ref" , dcfgOutDir = baseDir </> "out" , dcfgResDir = rootDir </> "resources" , dcfgCheckIgnore = const False } where rootDir = baseDir </> ".." data Config c = Config { cfgHaddockPath :: FilePath , cfgPackages :: [TestPackage] , cfgHaddockArgs :: [String] , cfgHaddockStdOut :: FilePath , cfgDiffTool :: Maybe FilePath , cfgEnv :: Environment , cfgAccept :: Bool , cfgCheckConfig :: CheckConfig c , cfgDirConfig :: DirConfig } cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config c -> FilePath cfgSrcDir = dcfgSrcDir . cfgDirConfig cfgRefDir = dcfgRefDir . cfgDirConfig cfgOutDir = dcfgOutDir . cfgDirConfig cfgResDir = dcfgResDir . cfgDirConfig data Flag = FlagHaddockPath FilePath | FlagHaddockOptions String | FlagHaddockStdOut FilePath | FlagGhcPath FilePath | FlagDiffTool FilePath | FlagNoDiff | FlagAccept | FlagHelp deriving Eq flagsHaddockPath :: [Flag] -> Maybe FilePath flagsHaddockPath flags = mlast [ path | FlagHaddockPath path <- flags ] flagsGhcPath :: [Flag] -> Maybe FilePath flagsGhcPath flags = mlast [ path | FlagGhcPath path <- flags ] flagsHaddockOptions :: [Flag] -> [String] flagsHaddockOptions flags = concat [ words opts | FlagHaddockOptions opts <- flags ] flagsHaddockStdOut :: [Flag] -> Maybe FilePath flagsHaddockStdOut flags = mlast [ path | FlagHaddockStdOut path <- flags ] flagsDiffTool :: [Flag] -> Maybe FilePath flagsDiffTool flags = mlast [ path | FlagDiffTool path <- flags ] options :: [OptDescr Flag] options = [ Option [] ["haddock-path"] (ReqArg FlagHaddockPath "FILE") "path to Haddock executable to exectue tests with" , Option [] ["haddock-options"] (ReqArg FlagHaddockOptions "OPTS") "additional options to run Haddock with" , Option [] ["haddock-stdout"] (ReqArg FlagHaddockStdOut "FILE") "where to redirect Haddock output" , Option [] ["ghc-path"] (ReqArg FlagGhcPath "FILE") "path ghc executable" , Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH") "diff tool to use when printing failed cases" , Option ['a'] ["accept"] (NoArg FlagAccept) "accept generated output" , Option [] ["no-diff"] (NoArg FlagNoDiff) "do not print diff for failed cases" , Option ['h'] ["help"] (NoArg FlagHelp) "display this help end exit" ] parseArgs :: CheckConfig c -> DirConfig -> [String] -> IO (Config c) parseArgs ccfg dcfg args = uncurry (loadConfig ccfg dcfg) =<< checkOpt args 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 :: CheckConfig c -> DirConfig -> [Flag] -> [String] -> IO (Config c) loadConfig ccfg dcfg flags files = do cfgEnv <- (:) ("haddock_datadir", dcfgResDir dcfg) <$> getEnvironment -- Find Haddock executable systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment haddockOnPath <- findExecutable "haddock" let haddock_path = msum [ flagsHaddockPath flags , systemHaddockPath , haddockOnPath ] cfgHaddockPath <- case haddock_path of Just path -> pure path Nothing -> do hPutStrLn stderr "Haddock executable not found; consider using the `--haddock-path` flag." exitFailure -- Perhaps Haddock knows where you can find GHC? queriedGhcPath <- do p <- init <$> rawSystemStdout normal cfgHaddockPath ["--print-ghc-path"] exists <- doesFileExist p pure $ if exists then Just p else Nothing let ghc_path = msum [ flagsGhcPath flags , queriedGhcPath ] ghcPath <- case ghc_path of Just path -> pure path Nothing -> do hPutStrLn stderr "GHC executable not found; consider using the `--ghc-path` flag." exitFailure printVersions cfgEnv cfgHaddockPath cfgPackages <- processFileArgs dcfg files cfgHaddockArgs <- liftM concat . sequence $ [ pure ["--no-warnings"] , pure ["--bypass-interface-version-check"] , pure ["--odir=" ++ dcfgOutDir dcfg] , pure ["--optghc=-w"] , pure ["--optghc=-hide-all-packages"] , pure $ flagsHaddockOptions flags , baseDependencies ghcPath ] let cfgHaddockStdOut = fromMaybe defaultStdOut (flagsHaddockStdOut flags) cfgDiffTool <- if FlagNoDiff `elem` flags then pure Nothing else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool let cfgAccept = FlagAccept `elem` flags let cfgCheckConfig = ccfg let cfgDirConfig = dcfg return $ Config { .. } printVersions :: Environment -> FilePath -> IO () printVersions env haddockPath = do handleHaddock <- runProcess' haddockPath $ processConfig { pcEnv = Just env , pcArgs = ["--version"] } void $ waitForSuccess "Failed to run `haddock --version`" stderr handleHaddock handleGhc <- runProcess' haddockPath $ processConfig { pcEnv = Just env , pcArgs = ["--ghc-version"] } void $ waitForSuccess "Failed to run `haddock --ghc-version`" stderr handleGhc baseDependencies :: FilePath -> IO [String] baseDependencies ghcPath = do -- The 'getInstalledPackages' crashes if used when "GHC_PACKAGE_PATH" is -- set to some value. I am not sure why is that happening and what are the -- consequences of unsetting it - but looks like it works (for now). unsetEnv "GHC_PACKAGE_PATH" (comp, _, cfg) <- configure normal (Just ghcPath) Nothing defaultProgramDb #if MIN_VERSION_Cabal(1,23,0) pkgIndex <- getInstalledPackages normal comp [GlobalPackageDB] cfg #else pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg #endif let pkgs = [ "array" , "base" , "ghc-prim" , "process" , "template-haskell" ] concat `fmap` mapM (getDependency pkgIndex) pkgs where getDependency pkgIndex name = case ifaces pkgIndex name of [] -> do hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name exitFailure (unit, ifaceOpt, htmlOpt) : alts -> do when (not . null $ alts) $ hPutStr stderr $ unlines [ "Multiple options found for base test dependency: " ++ name , "Choosing the first of these, which has unit id: " ++ unit ] case (ifaceOpt, htmlOpt) of (Nothing, _) -> do hPutStr stderr $ "No '.haddock' file found for base test dependency: " ++ name exitFailure (Just iface, Nothing) -> do hPutStrLn stderr $ "No HTML directory found for base test dependency: " ++ name pure [ "--optghc=-package" ++ name , "--read-interface=" ++ iface ] (Just iface, Just html) -> pure [ "--optghc=-package" ++ name , "--read-interface=" ++ html ++ "," ++ iface ] ifaces pkgIndex name = do pkg <- join $ snd <$> lookupPackageName pkgIndex (mkPackageName name) let unitId = display (installedUnitId pkg) ifaceOpt = listToMaybe (haddockInterfaces pkg) htmlDirOpt = listToMaybe (haddockHTMLs pkg) pure (unitId, ifaceOpt, htmlDirOpt) defaultDiffTool :: IO (Maybe FilePath) defaultDiffTool = liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"] where isAvailable = liftM isJust . findExecutable defaultStdOut :: FilePath #ifdef mingw32_HOST_OS defaultStdOut = "nul" #else defaultStdOut = "/dev/null" #endif processFileArgs :: DirConfig -> [String] -> IO [TestPackage] processFileArgs dcfg [] = processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir where isValidEntry entry | hasExtension entry = isSourceFile entry | otherwise = isRealDir entry srcDir = dcfgSrcDir dcfg processFileArgs dcfg args = processFileArgs' dcfg args processFileArgs' :: DirConfig -> [String] -> IO [TestPackage] processFileArgs' dcfg args = do (dirs, mdls) <- partitionM doesDirectoryExist' . map takeBaseName $ args rootPkg <- pure $ TestPackage { tpkgName = "" , tpkgFiles = map (srcDir </>) mdls } otherPkgs <- forM dirs $ \dir -> do let srcDir' = srcDir </> dir files <- filterM (isModule dir) =<< getDirectoryContents srcDir' pure $ TestPackage { tpkgName = dir , tpkgFiles = map (srcDir' </>) files } pure . filter (not . null . tpkgFiles) $ rootPkg:otherPkgs where doesDirectoryExist' path = doesDirectoryExist (srcDir </> path) isModule dir file = (isSourceFile file &&) <$> doesFileExist (srcDir </> dir </> file) srcDir = dcfgSrcDir dcfg isSourceFile :: FilePath -> Bool isSourceFile file = takeExtension file `elem` [".hs", ".lhs"] isRealDir :: FilePath -> Bool isRealDir dir = not $ dir `elem` [".", ".."]