Tue Nov 28 11:37:20 UTC 2017

Repository : ssh://git@git.haskell.org/haddock

On branches: 2.17.3.1-spanfix,alexbiehl-patch-1,ghc-8.0,ghc-8.0-facebook,ghc-head,ghc-head1,haddock-quick,headdock-library-1.4.5,ie_avails,issue-303,issue-475,master,pr-filter-maps,pr/cabal-desc,travis,v2.17,v2.17.3,v2.18,wip-located-module-as,wip/D2418,wip/T11080-open-data-kinds,wip/T11430,wip/T12105,wip/T12105-2,wip/T12942,wip/T13163,wip/T14529,wip/T3384,wip/embelleshed-rdr,wip/new-tree-one-param,wip/rae,wip/remove-frames,wip/remove-frames1,wip/revert-ttg-2017-11-20,wip/ttg-2017-10-13,wip/ttg-2017-10-31,wip/ttg-2017-11-06,wip/ttg2-2017-11-10,wip/ttg3-2017-11-12,wip/ttg4-constraints-2017-11-13,wip/ttg6-unrevert-2017-11-22
Link       : http://git.haskell.org/haddock.git/commitdiff/4ca12fff14afffc61d80ca0edd2106bd5d3d738e

>---------------------------------------------------------------

commit 4ca12fff14afffc61d80ca0edd2106bd5d3d738e
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Tue Aug 4 19:18:08 2015 +0200

    Make it possible to choose alternative diff tool.


>---------------------------------------------------------------

4ca12fff14afffc61d80ca0edd2106bd5d3d738e
 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 d1a134f..ee2d082 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

