aboutsummaryrefslogtreecommitdiff
path: root/html-test/run.lhs
blob: 1f19b723d7bb5666182f675620f0253cb86874aa (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
#!/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 :: 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 $ System.Exit.die "you need to run 'cabal build' successfully first"

  contents <- getDirectoryContents testDir
  args <- getArgs
  let (opts, spec) = span ("-" `isPrefixOf`) args
  let mods =
        case spec of
          y:_ | y /= "all" -> [y ++ ".hs"]
          _ -> filter ((==) ".hs" . takeExtension) contents

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

  -- add haddock_datadir to environment for subprocesses
  env <- Just . (:) ("haddock_datadir", Main.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..."
  handle <- runProcess haddockPath
                       (["-w", "-o", outDir, "-h", "--pretty-html"
                        , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods')
                       Nothing env Nothing
                       Nothing Nothing

  wait handle "*** Haddock run failed! Exiting."
  check mods (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 modules strict = do
  forM_ modules $ \mod -> do
    let outfile = outDir </> dropExtension mod ++ ".html"
    let reffile = refDir </> dropExtension mod ++ ".html"
    b <- doesFileExist reffile
    if b
      then do
        out <- readFile outfile
        ref <- readFile reffile
        if not $ haddockEq (outfile, out) (reffile, ref)
          then do
            putStrLn $ "Output for " ++ mod ++ " has changed! Exiting with diff:"
            let ref' = maybeStripLinks outfile ref
                out' = maybeStripLinks reffile out
            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: " ++ mod
      else do
        putStrLn $ "Pass: " ++ mod ++ " (no .ref file)"

-- | List of modules in which we don't 'stripLinks'
preserveLinksModules :: [String]
preserveLinksModules = map (++ ".html") ["Bug253"]

-- | A rather nasty way to drop the Haddock version string from the
-- end of the generated HTML files so that we don't have to change
-- every single test every time we change versions. We rely on the the
-- last paragraph of the document to be the version. We end up with
-- malformed HTML but we don't care as we never look at it ourselves.
dropVersion :: String -> String
dropVersion = reverse . dropTillP . reverse
  where
    dropTillP [] = []
    dropTillP ('p':'<':xs) = xs
    dropTillP (_:xs) = dropTillP xs

haddockEq :: (FilePath, String) -> (FilePath, String) -> Bool
haddockEq (fn1, file1) (fn2, file2) =
  maybeStripLinks fn1 (dropVersion file1)
  == maybeStripLinks fn2 (dropVersion file2)

maybeStripLinks :: String -- ^ Module we're considering for stripping
                -> String -> String
maybeStripLinks m = if any (`isSuffixOf` m) preserveLinksModules
                    then id
                    else stripLinks

stripLinks :: String -> String
stripLinks str =
  let prefix = "<a href=\"" in
  case stripPrefix prefix str of
    Just str' -> case dropWhile (/= '>') (dropWhile (/= '"') str') of
      [] -> []
      x:xs -> stripLinks (stripHrefEnd xs)
    Nothing ->
      case str of
        [] -> []
        x : xs -> x : stripLinks xs

stripHrefEnd :: String -> String
stripHrefEnd s =
  let pref = "</a" in
  case stripPrefix pref s of
    Just str' -> case dropWhile (/= '>') str' of
      [] -> []
      x:xs -> xs
    Nothing ->
      case s of
        [] -> []
        x : xs -> x : stripHrefEnd xs

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