From c2d2c481da18310053396bb0d2a9d070335eb865 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 14 Aug 2015 20:53:34 +0200 Subject: Adapt `hypsrc-test` module to work with new testing framework. --- hypsrc-test/Main.hs | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 hypsrc-test/Main.hs (limited to 'hypsrc-test') diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs new file mode 100644 index 00000000..b1b48ca4 --- /dev/null +++ b/hypsrc-test/Main.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} + + +import Data.List + +import System.Environment +import System.FilePath + +import Test.Haddock +import Test.Haddock.Xhtml + + +checkConfig :: CheckConfig Xhtml +checkConfig = CheckConfig + { ccfgRead = \_ input -> strip <$> parseXhtml input + , ccfgDump = dumpXhtml + , ccfgEqual = (==) + } + where + strip = stripAnchors' . stripLinks' . stripFooter + stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href + stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name + + +dirConfig :: DirConfig +dirConfig = defaultDirConfig $ takeDirectory __FILE__ + + +main :: IO () +main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs -- cgit v1.2.3 From 9ff514d4da431955db26cf4e64b68a8e219161b9 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 21:57:54 +0200 Subject: Specify ignored files for hyperlinker source test runner. --- hypsrc-test/Main.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'hypsrc-test') diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index b1b48ca4..7fa4a705 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} +import Data.Char import Data.List import System.Environment @@ -23,8 +24,20 @@ checkConfig = CheckConfig dirConfig :: DirConfig -dirConfig = defaultDirConfig $ takeDirectory __FILE__ +dirConfig = (defaultDirConfig $ takeDirectory __FILE__) + { dcfgCheckIgnore = checkIgnore + } main :: IO () main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs + + +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 -- cgit v1.2.3 From f7337b12cc3c198a3827c31cbc2854501f360595 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 21:58:37 +0200 Subject: Copy test runner script for hyperlinked source case. --- hypsrc-test/run | 5 +++++ 1 file changed, 5 insertions(+) create mode 100755 hypsrc-test/run (limited to 'hypsrc-test') diff --git a/hypsrc-test/run b/hypsrc-test/run new file mode 100755 index 00000000..5e17ad0f --- /dev/null +++ b/hypsrc-test/run @@ -0,0 +1,5 @@ +#!/bin/bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +runhaskell -i:"$LIB_PATH" "Main.hs" $@ -- cgit v1.2.3 From ebf06f31c1eaf0e9d045f8472548196d47d53431 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 22:30:06 +0200 Subject: Fix bug with test runner invoking Haddock in incorrect mode. --- haddock-test/src/Test/Haddock/Config.hs | 2 -- html-test/Main.hs | 6 +++++- hypsrc-test/Main.hs | 9 ++++++++- 3 files changed, 13 insertions(+), 4 deletions(-) (limited to 'hypsrc-test') diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 256e9a93..9fca3348 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -177,8 +177,6 @@ loadConfig ccfg dcfg flags files = do cfgHaddockArgs <- liftM concat . sequence $ [ pure ["--no-warnings"] , pure ["--odir=" ++ dcfgOutDir dcfg] - , pure ["--pretty-html"] - , pure ["--html"] , pure ["--optghc=-w"] , pure $ flagsHaddockOptions flags , baseDependencies ghcPath diff --git a/html-test/Main.hs b/html-test/Main.hs index 49e769f5..724d35ec 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -25,7 +25,11 @@ dirConfig = (defaultDirConfig $ takeDirectory __FILE__) main :: IO () -main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--pretty-html", "--html"] + } stripIfRequired :: String -> Xhtml -> Xhtml diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index 7fa4a705..06cf8546 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -30,7 +30,14 @@ dirConfig = (defaultDirConfig $ takeDirectory __FILE__) main :: IO () -main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ + [ "--pretty-html" + , "--hyperlinked-source" + ] + } checkIgnore :: FilePath -> Bool -- cgit v1.2.3 From 2555cc37c9e9c0eeb9f7fbddb9599bb6fae3e982 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 21 Aug 2015 19:51:24 +0200 Subject: Refactor existing code to use XHTML printer instead of XML one. --- haddock-test/src/Test/Haddock/Xhtml.hs | 41 +++++++++++++++++----------------- html-test/Main.hs | 8 +++---- hypsrc-test/Main.hs | 6 ++--- 3 files changed, 28 insertions(+), 27 deletions(-) (limited to 'hypsrc-test') diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs index 21fda36d..69361f7c 100644 --- a/haddock-test/src/Test/Haddock/Xhtml.hs +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -3,8 +3,8 @@ module Test.Haddock.Xhtml - ( Xhtml(..) - , parseXhtml, dumpXhtml + ( Xml(..) + , parseXml, dumpXml , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter ) where @@ -13,11 +13,12 @@ import Data.Generics.Aliases import Data.Generics.Schemes import Text.XML.Light -import Text.XHtml +import Text.XHtml (Html, HtmlAttr, (!)) +import qualified Text.XHtml as Xhtml -newtype Xhtml = Xhtml - { xhtmlElement :: Element +newtype Xml = Xml + { xmlElement :: Element } deriving Eq @@ -27,19 +28,19 @@ deriving instance Eq Content deriving instance Eq CData -parseXhtml :: String -> Maybe Xhtml -parseXhtml = fmap Xhtml . parseXMLDoc +parseXml :: String -> Maybe Xml +parseXml = fmap Xml . parseXMLDoc -dumpXhtml :: Xhtml -> String -dumpXhtml = ppElement . xhtmlElement +dumpXml :: Xml -> String +dumpXml = Xhtml.renderHtmlFragment. xmlElementToXhtml . xmlElement -stripLinks :: Xhtml -> Xhtml +stripLinks :: Xml -> Xml stripLinks = stripLinksWhen (const True) -stripLinksWhen :: (String -> Bool) -> Xhtml -> Xhtml +stripLinksWhen :: (String -> Bool) -> Xml -> Xml stripLinksWhen p = processAnchors unlink where @@ -48,7 +49,7 @@ stripLinksWhen p = | otherwise = attr -stripAnchorsWhen :: (String -> Bool) -> Xhtml -> Xhtml +stripAnchorsWhen :: (String -> Bool) -> Xml -> Xml stripAnchorsWhen p = processAnchors unname where @@ -57,13 +58,13 @@ stripAnchorsWhen p = | otherwise = attr -processAnchors :: (Attr -> Attr) -> Xhtml -> Xhtml -processAnchors f = Xhtml . everywhere (mkT f) . xhtmlElement +processAnchors :: (Attr -> Attr) -> Xml -> Xml +processAnchors f = Xml . everywhere (mkT f) . xmlElement -stripFooter :: Xhtml -> Xhtml +stripFooter :: Xml -> Xml stripFooter = - Xhtml . everywhere (mkT defoot) . xhtmlElement + Xml . everywhere (mkT defoot) . xmlElement where defoot el | isFooter el = el { elContent = [] } @@ -77,7 +78,7 @@ stripFooter = xmlElementToXhtml :: Element -> Html xmlElementToXhtml (Element { .. }) = - tag (qName elName) contents ! attrs + Xhtml.tag (qName elName) contents ! attrs where contents = mconcat $ map xmlContentToXhtml elContent attrs = map xmlAttrToXhtml elAttribs @@ -85,9 +86,9 @@ xmlElementToXhtml (Element { .. }) = xmlContentToXhtml :: Content -> Html xmlContentToXhtml (Elem el) = xmlElementToXhtml el -xmlContentToXhtml (Text text) = toHtml $ cdData text -xmlContentToXhtml (CRef cref) = noHtml +xmlContentToXhtml (Text text) = Xhtml.toHtml $ cdData text +xmlContentToXhtml (CRef _) = Xhtml.noHtml xmlAttrToXhtml :: Attr -> HtmlAttr -xmlAttrToXhtml (Attr { .. }) = strAttr (qName attrKey) attrVal +xmlAttrToXhtml (Attr { .. }) = Xhtml.strAttr (qName attrKey) attrVal diff --git a/html-test/Main.hs b/html-test/Main.hs index 724d35ec..3880fc3c 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -10,10 +10,10 @@ import Test.Haddock import Test.Haddock.Xhtml -checkConfig :: CheckConfig Xhtml +checkConfig :: CheckConfig Xml checkConfig = CheckConfig - { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXhtml input - , ccfgDump = dumpXhtml + { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXml input + , ccfgDump = dumpXml , ccfgEqual = (==) } @@ -32,7 +32,7 @@ main = do } -stripIfRequired :: String -> Xhtml -> Xhtml +stripIfRequired :: String -> Xml -> Xml stripIfRequired mdl = stripLinks' . stripFooter where diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index 06cf8546..0490be47 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -11,10 +11,10 @@ import Test.Haddock import Test.Haddock.Xhtml -checkConfig :: CheckConfig Xhtml +checkConfig :: CheckConfig Xml checkConfig = CheckConfig - { ccfgRead = \_ input -> strip <$> parseXhtml input - , ccfgDump = dumpXhtml + { ccfgRead = \_ input -> strip <$> parseXml input + , ccfgDump = dumpXml , ccfgEqual = (==) } where -- cgit v1.2.3 From f2b7e4d0b7be232841e86edabf5152f242976105 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 22 Aug 2015 23:28:19 +0200 Subject: Improve portability of test runner scripts. --- hoogle-test/run | 5 +++-- html-test/run | 5 +++-- hypsrc-test/run | 5 +++-- latex-test/run | 5 +++-- 4 files changed, 12 insertions(+), 8 deletions(-) (limited to 'hypsrc-test') diff --git a/hoogle-test/run b/hoogle-test/run index 5e17ad0f..3e72be80 100755 --- a/hoogle-test/run +++ b/hoogle-test/run @@ -1,5 +1,6 @@ -#!/bin/bash +#!/usr/bin/env bash export HADDOCK_PATH=$(which haddock) LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" -runhaskell -i:"$LIB_PATH" "Main.hs" $@ +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ diff --git a/html-test/run b/html-test/run index 5e17ad0f..3e72be80 100755 --- a/html-test/run +++ b/html-test/run @@ -1,5 +1,6 @@ -#!/bin/bash +#!/usr/bin/env bash export HADDOCK_PATH=$(which haddock) LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" -runhaskell -i:"$LIB_PATH" "Main.hs" $@ +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ diff --git a/hypsrc-test/run b/hypsrc-test/run index 5e17ad0f..3e72be80 100755 --- a/hypsrc-test/run +++ b/hypsrc-test/run @@ -1,5 +1,6 @@ -#!/bin/bash +#!/usr/bin/env bash export HADDOCK_PATH=$(which haddock) LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" -runhaskell -i:"$LIB_PATH" "Main.hs" $@ +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ diff --git a/latex-test/run b/latex-test/run index 5e17ad0f..3e72be80 100755 --- a/latex-test/run +++ b/latex-test/run @@ -1,5 +1,6 @@ -#!/bin/bash +#!/usr/bin/env bash export HADDOCK_PATH=$(which haddock) LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" -runhaskell -i:"$LIB_PATH" "Main.hs" $@ +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ -- cgit v1.2.3 From 3c88a8a3336b26939738d481a60233821b926adb Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 24 Aug 2015 23:14:18 +0200 Subject: Get rid of obsolete testing utilities. --- html-test/README.markdown | 27 ------- html-test/accept.lhs | 49 ------------ html-test/run.lhs | 191 ---------------------------------------------- hypsrc-test/Utils.hs | 47 ------------ hypsrc-test/accept.hs | 27 ------- hypsrc-test/run.hs | 122 ----------------------------- latex-test/accept.lhs | 46 ----------- latex-test/run.lhs | 162 --------------------------------------- 8 files changed, 671 deletions(-) delete mode 100644 html-test/README.markdown delete mode 100755 html-test/accept.lhs delete mode 100755 html-test/run.lhs delete mode 100644 hypsrc-test/Utils.hs delete mode 100755 hypsrc-test/accept.hs delete mode 100755 hypsrc-test/run.hs delete mode 100755 latex-test/accept.lhs delete mode 100755 latex-test/run.lhs (limited to 'hypsrc-test') diff --git a/html-test/README.markdown b/html-test/README.markdown deleted file mode 100644 index 717bac5c..00000000 --- a/html-test/README.markdown +++ /dev/null @@ -1,27 +0,0 @@ -This is a testsuite for Haddock that uses the concept of "golden files". That -is, it compares output files against a set of reference files. - -To add a new test: - - 1. Create a module in the `html-test/src` directory. - - 2. Run `cabal test`. You should now have `html-test/out/.html`. - The test passes since there is no reference file to compare with. - - 3. To make a reference file from the output file, run - - html-test/accept.lhs - -Tips and tricks: - -To "accept" all output files (copy them to reference files), run - - runhaskell accept.lhs - -You can run all tests despite failing tests, like so - - cabal test --test-option=all - -You can pass extra options to haddock like so - - cabal test --test-options='all --title="All Tests"' diff --git a/html-test/accept.lhs b/html-test/accept.lhs deleted file mode 100755 index f6dfc4cd..00000000 --- a/html-test/accept.lhs +++ /dev/null @@ -1,49 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# LANGUAGE CPP #-} -import System.Cmd -import System.Environment -import System.FilePath -import System.Directory -import Data.List -import Control.Applicative - -baseDir = takeDirectory __FILE__ - -main :: IO () -main = do - contents <- filter (not . ignore) <$> getDirectoryContents (baseDir "out") - args <- getArgs - if not $ null args then - mapM_ copy [ baseDir "out" file | file <- contents, ".html" `isSuffixOf` file, takeBaseName file `elem` args ] - else - mapM_ copy [ baseDir "out" file | file <- contents] - where - ignore = - foldr (liftA2 (||)) (const False) [ - (== ".") - , (== "..") - , (isPrefixOf "index") - , (isPrefixOf "doc-index") - ] - -copy :: FilePath -> IO () -copy file = do - let new = baseDir "ref" takeFileName file - if ".html" `isSuffixOf` file then do - putStrLn (file ++ " -> " ++ new) - stripLinks <$> readFile file >>= writeFile new - else do - -- copy css, images, etc. - copyFile file new - -stripLinks :: String -> String -stripLinks str = - let prefix = " prefix ++ stripLinks (dropWhile (/= '"') str') - Nothing -> - case str of - [] -> [] - x : xs -> x : stripLinks xs -\end{code} diff --git a/html-test/run.lhs b/html-test/run.lhs deleted file mode 100755 index 1f19b723..00000000 --- a/html-test/run.lhs +++ /dev/null @@ -1,191 +0,0 @@ -#!/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 = " 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 = " 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} 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 " String -stripLocalLinks = replaceBetween " 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 diff --git a/latex-test/accept.lhs b/latex-test/accept.lhs deleted file mode 100755 index 4d0b0127..00000000 --- a/latex-test/accept.lhs +++ /dev/null @@ -1,46 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# LANGUAGE CPP #-} -import System.Environment -import System.FilePath -import System.Directory -import Data.List -import Control.Applicative -import Control.Monad - -baseDir :: FilePath -baseDir = takeDirectory __FILE__ - -main :: IO () -main = do - contents <- filter (not . ignore) <$> getDirectoryContents (baseDir "out") - args <- getArgs - mapM_ copyDir $ if not (null args) - then filter ((`elem` args) . takeBaseName) contents - else contents - where - ignore = - foldr (liftA2 (||)) (const False) [ - (== ".") - , (== "..") - , isPrefixOf "index" - , isPrefixOf "doc-index" - ] - --- | Copy a directory to ref, one level deep. -copyDir :: FilePath -> IO () -copyDir dir = do - let old = baseDir "out" dir - new = baseDir "ref" dir - alreadyExists <- doesDirectoryExist new - unless alreadyExists $ do - putStrLn (old ++ " -> " ++ new) - createDirectoryIfMissing True new - files <- getDirectoryContents old >>= filterM (liftM not . doesDirectoryExist) - let files' = filter (\x -> x /= "." && x /= "..") files - mapM_ (\f -> copyFile' (old f) (new f)) files' - where - copyFile' o n = do - putStrLn $ o ++ " -> " ++ n - copyFile o n -\end{code} diff --git a/latex-test/run.lhs b/latex-test/run.lhs deleted file mode 100755 index d3e39e90..00000000 --- a/latex-test/run.lhs +++ /dev/null @@ -1,162 +0,0 @@ -#!/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 hiding (dataDir) -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 $ System.Exit.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} -- cgit v1.2.3