#!/usr/bin/env runhaskell
\begin{code}
{-# LANGUAGE CPP #-}
import Prelude hiding (mod)
import Control.Monad
import Control.Applicative
import Data.List
import Data.Maybe
import Distribution.InstalledPackageInfo
import Distribution.Package (PackageName (..))
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.IO
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.Process (ProcessHandle, runProcess, waitForProcess, system)


packageRoot, dataDir, haddockPath, baseDir, testDir, outDir, refDir :: FilePath
baseDir = takeDirectory __FILE__
testDir       = baseDir </> "src"
refDir        = baseDir </> "ref"
outDir        = baseDir </> "out"
packageRoot   = baseDir </> ".."
dataDir       = packageRoot </> "resources"
haddockPath   = packageRoot </> "dist" </> "build" </> "haddock" </> "haddock"


main :: IO ()
main = do
  test
  putStrLn "All tests passed!"


test :: IO ()
test = do
  x <- doesFileExist haddockPath
  unless x $ die "you need to run 'cabal build' successfully first"

  contents <- getDirectoryContents testDir

  args <- getArgs
  let (opts, spec) = span ("-" `isPrefixOf`) args
      isDir x' = liftM2 (&&) (doesDirectoryExist $ testDir </> x')
                             (return $ x' /= "." && x' /= "..")
  modDirs <- case spec of
    y:_ | y /= "all" -> return [y]
    _ -> filterM isDir contents

  let modDirs' = map (testDir </>) modDirs

  -- add haddock_datadir to environment for subprocesses
  env <- Just . (:) ("haddock_datadir", dataDir) <$> getEnvironment

  putStrLn ""
  putStrLn "Haddock version: "
  h1 <- runProcess haddockPath ["--version"] Nothing
                   env Nothing Nothing Nothing
  wait h1 "*** Running `haddock --version' failed!"
  putStrLn ""
  putStrLn "GHC version: "
  h2 <- runProcess haddockPath ["--ghc-version"] Nothing
                   env Nothing Nothing Nothing
  wait h2 "*** Running `haddock --ghc-version' failed!"
  putStrLn ""

  -- TODO: maybe do something more clever here using haddock.cabal
  ghcPath <- fmap init $ rawSystemStdout normal haddockPath ["--print-ghc-path"]
  (_, _, conf) <- configure normal (Just ghcPath) Nothing defaultProgramConfiguration
  pkgIndex <- getInstalledPackages normal [GlobalPackageDB] conf
  let mkDep pkgName =
        fromMaybe (error "Couldn't find test dependencies") $ do
          let pkgs = lookupPackageName pkgIndex (PackageName pkgName)
          (_, pkgs') <- listToMaybe pkgs
          pkg <- listToMaybe pkgs'
          ifacePath <- listToMaybe (haddockInterfaces pkg)
          htmlPath <- listToMaybe (haddockHTMLs pkg)
          return ("-i " ++ htmlPath ++ "," ++ ifacePath)

  let base    = mkDep "base"
      process = mkDep "process"
      ghcprim = mkDep "ghc-prim"

  putStrLn "Running tests..."

  forM_ modDirs' $ \modDir -> do
    testModules <- getDirectoryContents modDir

    let mods = filter ((==) ".hs" . takeExtension) testModules
        mods' = map (modDir </>) mods

    unless (null mods') $ do
      handle <- runProcess haddockPath
                (["-w", "-o", outDir </> last (splitPath modDir), "--latex"
                 , "--optghc=-fglasgow-exts"
                 , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods')
                Nothing env Nothing
                Nothing Nothing

      wait handle "*** Haddock run failed! Exiting."

  check modDirs (if not (null args) && args !! 0 == "all" then False else True)
  where
    wait :: ProcessHandle -> String -> IO ()
    wait h msg = do
      r <- waitForProcess h
      unless (r == ExitSuccess) $ do
        hPutStrLn stderr msg
        exitFailure

check :: [FilePath] -> Bool -> IO ()
check modDirs strict = do
  forM_ modDirs $ \modDir -> do
    let oDir = outDir </> modDir
        rDir = refDir </> modDir

    refDirExists <- doesDirectoryExist rDir
    when refDirExists $ do
      -- we're not creating sub-directories, I think.
      refFiles <- getDirectoryContents rDir >>= filterM doesFileExist

      forM_ refFiles $ \rFile -> do
        let refFile = rDir </> rFile
            outFile = oDir </> rFile
        oe <- doesFileExist outFile
        if oe
          then do
            out <- readFile outFile
            ref <- readFile refFile

            if out /= ref
               then do
                 putStrLn $ "Output for " ++ modDir ++ " has changed! Exiting with diff:"

                 let reffile' = outDir </> takeFileName refFile ++ ".nolinks"
                     outfile' = outDir </> takeFileName outFile ++ ".ref.nolinks"
                 writeFile reffile' ref
                 writeFile outfile' out
                 r <- programOnPath "colordiff"
                 code <- if r
                   then system $ "colordiff " ++ reffile' ++ " " ++ outfile'
                   else system $ "diff " ++ reffile' ++ " " ++ outfile'
                 if strict then exitFailure else return ()
                 unless (code == ExitSuccess) $ do
                   hPutStrLn stderr "*** Running diff failed!"
                   exitFailure
               else do
                 putStrLn $ "Pass: " ++ modDir
           else do
             putStrLn $ "Pass: " ++ modDir ++ " (no .ref file)"

programOnPath :: FilePath -> IO Bool
programOnPath p = do
  result <- findProgramLocation silent p
  return (isJust result)
\end{code}