Create simple script for accepting hyperlinker test case references.

3 files changed, 55 insertions, 24 deletions

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