From 4ca12fff14afffc61d80ca0edd2106bd5d3d738e Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 4 Aug 2015 19:18:08 +0200
Subject: Make it possible to choose alternative diff tool.

---
 html-test/run.hs | 34 +++++++++++++++++++++++++++++-----
 1 file 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
-- 
cgit v1.2.3