{-# 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 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
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` [".", ".."]