diff options
Diffstat (limited to 'hypsrc-test')
-rw-r--r-- | hypsrc-test/Utils.hs | 47 | ||||
-rwxr-xr-x | hypsrc-test/accept.hs | 27 | ||||
-rwxr-xr-x | hypsrc-test/run.hs | 122 |
3 files changed, 0 insertions, 196 deletions
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.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 |