aboutsummaryrefslogtreecommitdiff
path: root/html-test/run.hs
diff options
context:
space:
mode:
authorŁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-08-04 19:18:08 +0200
committerŁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-08-22 23:40:26 +0200
commit4ca12fff14afffc61d80ca0edd2106bd5d3d738e (patch)
tree9f1b36c64f5083d9c19777c887661f5cccac2466 /html-test/run.hs
parent9048548dc9dbdf129b16e4c9ac22ca1343261378 (diff)
Make it possible to choose alternative diff tool.
Diffstat (limited to 'html-test/run.hs')
-rwxr-xr-xhtml-test/run.hs34
1 files changed, 29 insertions, 5 deletions
diff --git a/html-test/run.hs b/html-test/run.hs
index d1a134f8..ee2d0829 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE RecordWildCards #-}
+import Control.Applicative
import Control.Monad
import Data.Maybe
@@ -45,6 +46,7 @@ data Config = Config
, cfgFiles :: [FilePath]
, cfgHaddockArgs :: [String]
, cfgHaddockStdOut :: FilePath
+ , cfgDiffTool :: Maybe FilePath
, cfgEnv :: Environment
}
@@ -80,11 +82,17 @@ checkFiles (Config { .. }) = do
putStrLn "All tests passed!"
exitSuccess
else do
- putStrLn "Diffing failed cases..."
- forM_ failed diffModule
+ maybeDiff cfgDiffTool failed
exitFailure
+maybeDiff :: Maybe FilePath -> [String] -> IO ()
+maybeDiff Nothing _ = pure ()
+maybeDiff (Just diff) mdls = do
+ putStrLn "Diffing failed cases..."
+ forM_ mdls $ diffModule diff
+
+
runHaddock :: Config -> IO ()
runHaddock (Config { .. }) = do
putStrLn "Running Haddock process..."
@@ -139,6 +147,8 @@ loadConfig flags files = do
let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags)
+ cfgDiffTool <- (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool
+
return $ Config { .. }
@@ -155,8 +165,8 @@ checkModule mdl = do
else return NoRef
-diffModule :: String -> IO ()
-diffModule mdl = do
+diffModule :: FilePath -> String -> IO ()
+diffModule diff mdl = do
out <- readFile $ outFile mdl
ref <- readFile $ refFile mdl
let out' = stripLinks . dropVersion $ out
@@ -165,7 +175,7 @@ diffModule mdl = do
writeFile refFile' ref'
putStrLn $ "Diff for module " ++ show mdl ++ ":"
- handle <- runProcess' "diff" $ processConfig
+ handle <- runProcess' diff $ processConfig
{ pcArgs = [outFile', refFile']
}
waitForProcess handle >> return ()
@@ -215,6 +225,13 @@ baseDependencies ghcPath = do
iface file html = "--read-interface=" ++ html ++ "," ++ file
+defaultDiffTool :: IO (Maybe FilePath)
+defaultDiffTool =
+ liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"]
+ where
+ isAvailable = liftM isJust . findProgramLocation silent
+
+
processFileArgs :: [String] -> IO [FilePath]
processFileArgs [] =
map toModulePath . filter isSourceFile <$> getDirectoryContents srcDir
@@ -241,6 +258,7 @@ data Flag
| FlagGhcPath FilePath
| FlagHaddockOptions String
| FlagHaddockStdOut FilePath
+ | FlagDiffTool FilePath
| FlagHelp
deriving Eq
@@ -255,6 +273,8 @@ options =
"additional options to run Haddock with"
, Option [] ["haddock-stdout"] (ReqArg FlagHaddockStdOut "FILE")
"where to redirect Haddock output"
+ , Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH")
+ "diff tool to use when printing failed cases"
, Option ['h'] ["help"] (NoArg FlagHelp)
"display this help end exit"
]
@@ -277,6 +297,10 @@ flagsHaddockStdOut :: [Flag] -> Maybe FilePath
flagsHaddockStdOut flags = mlast [ path | FlagHaddockStdOut path <- flags ]
+flagsDiffTool :: [Flag] -> Maybe FilePath
+flagsDiffTool flags = mlast [ path | FlagDiffTool path <- flags ]
+
+
type Environment = [(String, String)]
data ProcessConfig = ProcessConfig