aboutsummaryrefslogtreecommitdiff
path: root/hypsrc-test
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2015-12-20 00:54:11 +0100
committerBen Gamari <ben@smart-cactus.org>2015-12-20 00:54:11 +0100
commit1555134703d5b1bb832361abf276fd651eff398c (patch)
tree237e485858d3d62b23ffcc6d2e04cee614c301ee /hypsrc-test
parentfa03f80d76f1511a811a0209ea7a6a8b6c58704f (diff)
parent27ffb2c24b8204d1a06bd509c49d3e3d7d2d7aba (diff)
Merge remote-tracking branch 'mrhania/testing-framework-improvements' into ghc-head
Diffstat (limited to 'hypsrc-test')
-rw-r--r--hypsrc-test/Main.hs50
-rw-r--r--hypsrc-test/Utils.hs47
-rwxr-xr-xhypsrc-test/accept.hs27
-rwxr-xr-xhypsrc-test/run6
-rwxr-xr-xhypsrc-test/run.hs122
5 files changed, 56 insertions, 196 deletions
diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs
new file mode 100644
index 00000000..0490be47
--- /dev/null
+++ b/hypsrc-test/Main.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE CPP #-}
+
+
+import Data.Char
+import Data.List
+
+import System.Environment
+import System.FilePath
+
+import Test.Haddock
+import Test.Haddock.Xhtml
+
+
+checkConfig :: CheckConfig Xml
+checkConfig = CheckConfig
+ { ccfgRead = \_ input -> strip <$> parseXml input
+ , ccfgDump = dumpXml
+ , ccfgEqual = (==)
+ }
+ where
+ strip = stripAnchors' . stripLinks' . stripFooter
+ stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href
+ stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name
+
+
+dirConfig :: DirConfig
+dirConfig = (defaultDirConfig $ takeDirectory __FILE__)
+ { dcfgCheckIgnore = checkIgnore
+ }
+
+
+main :: IO ()
+main = do
+ cfg <- parseArgs checkConfig dirConfig =<< getArgs
+ runAndCheck $ cfg
+ { cfgHaddockArgs = cfgHaddockArgs cfg ++
+ [ "--pretty-html"
+ , "--hyperlinked-source"
+ ]
+ }
+
+
+checkIgnore :: FilePath -> Bool
+checkIgnore file
+ | and . map ($ file) $ [isHtmlFile, isSourceFile, isModuleFile] = False
+ where
+ isHtmlFile = (== ".html") . takeExtension
+ isSourceFile = (== "src") . takeDirectory
+ isModuleFile = isUpper . head . takeBaseName
+checkIgnore _ = True
diff --git a/hypsrc-test/Utils.hs b/hypsrc-test/Utils.hs
deleted file mode 100644
index e15fabee..00000000
--- a/hypsrc-test/Utils.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-
-module Utils
- ( baseDir, rootDir
- , srcDir, refDir, outDir, refDir', outDir'
- , haddockPath
- , stripLocalAnchors, stripLocalLinks, stripLocalReferences
- ) where
-
-
-import Data.List
-
-import System.FilePath
-
-
-baseDir, rootDir :: FilePath
-baseDir = takeDirectory __FILE__
-rootDir = baseDir </> ".."
-
-srcDir, refDir, outDir, refDir', outDir' :: FilePath
-srcDir = baseDir </> "src"
-refDir = baseDir </> "ref"
-outDir = baseDir </> "out"
-refDir' = refDir </> "src"
-outDir' = outDir </> "src"
-
-haddockPath :: FilePath
-haddockPath = rootDir </> "dist" </> "build" </> "haddock" </> "haddock"
-
-
-replaceBetween :: Eq a => [a] -> a -> [a] -> [a] -> [a]
-replaceBetween _ _ _ [] = []
-replaceBetween pref end val html@(x:xs') = case stripPrefix pref html of
- Just strip -> pref ++ val ++ (replaceBetween' . dropWhile (/= end)) strip
- Nothing -> x:(replaceBetween' xs')
- where
- replaceBetween' = replaceBetween pref end val
-
-stripLocalAnchors :: String -> String
-stripLocalAnchors = replaceBetween "<a name=\"local-" '\"' "0"
-
-stripLocalLinks :: String -> String
-stripLocalLinks = replaceBetween "<a href=\"#local-" '\"' "0"
-
-stripLocalReferences :: String -> String
-stripLocalReferences = stripLocalLinks . stripLocalAnchors
diff --git a/hypsrc-test/accept.hs b/hypsrc-test/accept.hs
deleted file mode 100755
index 4606b2df..00000000
--- a/hypsrc-test/accept.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-#!/usr/bin/env runhaskell
-{-# LANGUAGE CPP #-}
-
-
-import System.Directory
-import System.FilePath
-import System.Environment
-
-import Utils
-
-
-main :: IO ()
-main = do
- args <- getArgs
- files <- filter isHtmlFile <$> getDirectoryContents outDir'
- let files' = if args == ["--all"] || args == ["-a"]
- then files
- else filter ((`elem` args) . takeBaseName) files
- mapM_ copy files'
- where
- isHtmlFile = (== ".html") . takeExtension
-
-
-copy :: FilePath -> IO ()
-copy file = do
- content <- stripLocalReferences <$> readFile (outDir' </> file)
- writeFile (refDir' </> file) content
diff --git a/hypsrc-test/run b/hypsrc-test/run
new file mode 100755
index 00000000..3e72be80
--- /dev/null
+++ b/hypsrc-test/run
@@ -0,0 +1,6 @@
+#!/usr/bin/env bash
+
+export HADDOCK_PATH=$(which haddock)
+LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/"
+MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs"
+runhaskell -i:"$LIB_PATH" $MAIN_PATH $@
diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs
deleted file mode 100755
index 853c4f09..00000000
--- a/hypsrc-test/run.hs
+++ /dev/null
@@ -1,122 +0,0 @@
-#!/usr/bin/env runhaskell
-{-# LANGUAGE CPP #-}
-
-
-import Control.Monad
-
-import Data.List
-import Data.Maybe
-
-import System.Directory
-import System.Environment
-import System.Exit
-import System.FilePath
-import System.Process
-
-import Distribution.Verbosity
-import Distribution.Simple.Utils hiding (die)
-
-import Utils
-
-
-main :: IO ()
-main = do
- haddockAvailable <- doesFileExist haddockPath
- unless haddockAvailable $ die "Haddock exectuable not available"
-
- (args, mods) <- partition ("-" `isPrefixOf`) <$> getArgs
- let args' = filter (\arg -> not $ arg == "--all" || arg == "-a") args
- mods' <- map (srcDir </>) <$> case args of
- [] -> getAllSrcModules
- _ -> return $ map (++ ".hs") mods
-
- putHaddockVersion
- putGhcVersion
-
- putStrLn "Running tests..."
- runHaddock $
- [ "--odir=" ++ outDir
- , "--no-warnings"
- , "--hyperlinked-source"
- , "--pretty-html"
- ] ++ args' ++ mods'
-
- forM_ mods' $ check True
-
-
-check :: Bool -> FilePath -> IO ()
-check strict mdl = do
- hasReference <- doesFileExist refFile
- if hasReference
- then do
- ref <- readFile refFile
- out <- readFile outFile
- compareOutput strict mdl ref out
- else do
- putStrLn $ "Pass: " ++ mdl ++ " (no reference file)"
- where
- refFile = refDir' </> takeBaseName mdl ++ ".html"
- outFile = outDir' </> takeBaseName mdl ++ ".html"
-
-
-compareOutput :: Bool -> FilePath -> String -> String -> IO ()
-compareOutput strict mdl ref out = do
- if ref' == out'
- then putStrLn $ "Pass: " ++ mdl
- else do
- putStrLn $ "Fail: " ++ mdl
- diff mdl ref' out'
- when strict $ die "Aborting further tests."
- where
- ref' = stripLocalReferences ref
- out' = stripLocalReferences out
-
-
-diff :: FilePath -> String -> String -> IO ()
-diff mdl ref out = do
- colorDiffPath <- findProgramLocation silent "colordiff"
- let cmd = fromMaybe "diff" colorDiffPath
-
- writeFile refFile ref
- writeFile outFile out
-
- result <- system $ cmd ++ " " ++ refFile ++ " " ++ outFile
- unless (result == ExitSuccess) $ die "Failed to run `diff` command."
- where
- refFile = outDir </> takeBaseName mdl ++ ".ref.nolinks"
- outFile = outDir </> takeBaseName mdl ++ ".nolinks"
-
-
-
-getAllSrcModules :: IO [FilePath]
-getAllSrcModules =
- filter isHaskellFile <$> getDirectoryContents srcDir
- where
- isHaskellFile = (== ".hs") . takeExtension
-
-
-putHaddockVersion :: IO ()
-putHaddockVersion = do
- putStrLn "Haddock version:"
- runHaddock ["--version"]
- putStrLn ""
-
-
-putGhcVersion :: IO ()
-putGhcVersion = do
- putStrLn "GHC version:"
- runHaddock ["--ghc-version"]
- putStrLn ""
-
-
-runHaddock :: [String] -> IO ()
-runHaddock args = do
- menv <- Just <$> getEnvironment
- handle <- runProcess haddockPath args Nothing menv Nothing Nothing Nothing
- waitForSuccess handle $ "Failed to invoke haddock with " ++ show args
-
-
-waitForSuccess :: ProcessHandle -> String -> IO ()
-waitForSuccess handle msg = do
- result <- waitForProcess handle
- unless (result == ExitSuccess) $ die msg