From 767569881732c59378fb577d1a2b57b51bc454d0 Mon Sep 17 00:00:00 2001 From: Ɓukasz Hanuszczak Date: Wed, 1 Jul 2015 01:14:59 +0200 Subject: Create simple script for accepting hyperlinker test case references. --- haddock.cabal | 1 + hypsrc-test/Utils.hs | 27 ++++++++++++++++++++++++--- hypsrc-test/accept.hs | 27 +++++++++++++++++++++++++++ hypsrc-test/run.hs | 25 ++++--------------------- 4 files changed, 56 insertions(+), 24 deletions(-) create mode 100755 hypsrc-test/accept.hs diff --git a/haddock.cabal b/haddock.cabal index 01e6a558..2a1caee7 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -128,6 +128,7 @@ test-suite hypsrc-test main-is: run.hs hs-source-dirs: hypsrc-test build-depends: base, directory, process, filepath, Cabal + ghc-options: -Wall -fwarn-tabs test-suite latex-test type: exitcode-stdio-1.0 diff --git a/hypsrc-test/Utils.hs b/hypsrc-test/Utils.hs index cf3e94ea..e15fabee 100644 --- a/hypsrc-test/Utils.hs +++ b/hypsrc-test/Utils.hs @@ -1,12 +1,33 @@ +{-# LANGUAGE CPP #-} + + module Utils - ( stripLocalAnchors - , stripLocalLinks - , stripLocalReferences + ( 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 _ _ _ [] = [] diff --git a/hypsrc-test/accept.hs b/hypsrc-test/accept.hs new file mode 100755 index 00000000..4606b2df --- /dev/null +++ b/hypsrc-test/accept.hs @@ -0,0 +1,27 @@ +#!/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 index 5b6b6548..10b6c257 100755 --- a/hypsrc-test/run.hs +++ b/hypsrc-test/run.hs @@ -2,13 +2,11 @@ {-# LANGUAGE CPP #-} -import Control.Applicative import Control.Monad import Data.List import Data.Maybe -import System.IO import System.Directory import System.Environment import System.Exit @@ -21,21 +19,6 @@ import Distribution.Simple.Utils hiding (die) import Utils -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" - - main :: IO () main = do haddockAvailable <- doesFileExist haddockPath @@ -107,9 +90,9 @@ diff mdl ref out = do getAllSrcModules :: IO [FilePath] getAllSrcModules = - filter isValid <$> getDirectoryContents srcDir + filter isHaskellFile <$> getDirectoryContents srcDir where - isValid = (== ".hs") . takeExtension + isHaskellFile = (== ".hs") . takeExtension putHaddockVersion :: IO () @@ -128,8 +111,8 @@ putGhcVersion = do runHaddock :: [String] -> IO () runHaddock args = do - env <- Just <$> getEnvironment - handle <- runProcess haddockPath args Nothing env Nothing Nothing Nothing + menv <- Just <$> getEnvironment + handle <- runProcess haddockPath args Nothing menv Nothing Nothing Nothing waitForSuccess handle $ "Failed to invoke haddock with " ++ show args -- cgit v1.2.3