[commit: haddock] master: Make Haddock generate warnings about potential misuse of hyperlinker. (cab1191)

[git at git.haskell.org]

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

On branch  : master
Link       : http://git.haskell.org/haddock.git/commitdiff/cab1191dfb7738c020a1eef9e9d4efe6c4f27a51

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

commit cab1191dfb7738c020a1eef9e9d4efe6c4f27a51
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Sat Jul 4 17:40:10 2015 +0200

    Make Haddock generate warnings about potential misuse of hyperlinker.


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

cab1191dfb7738c020a1eef9e9d4efe6c4f27a51
 haddock-api/src/Haddock.hs | 30 ++++++++++++++++++++++++++++++
 1 file changed, 30 insertions(+)

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 02e1953..5a1c6ab 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -159,6 +159,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
           _ -> return flags
 
   unless (Flag_NoWarnings `elem` flags) $ do
+    hypSrcWarnings flags
     forM_ (warnings args) $ \warning -> do
       hPutStrLn stderr warning
 
@@ -491,6 +492,35 @@ shortcutFlags flags = do
       ++ "Ported to use the GHC API by David Waern 2006-2008\n"
 
 
+-- | Generate some warnings about potential misuse of @--hyperlinked-source at .
+hypSrcWarnings :: [Flag] -> IO ()
+hypSrcWarnings flags = do
+
+    when (hypSrc && any isSourceUrlFlag flags) $
+        hPutStrLn stderr $ concat
+            [ "Warning: "
+            , "--source-* options are ignored when "
+            , "--hyperlinked-source is enabled."
+            ]
+
+    when (not hypSrc && any isSourceCssFlag flags) $
+        hPutStrLn stderr $ concat
+            [ "Warning: "
+            , "source CSS file is specified but "
+            , "--hyperlinked-source is disabled."
+            ]
+
+  where
+    hypSrc = Flag_HyperlinkedSource `elem` flags
+    isSourceUrlFlag (Flag_SourceBaseURL _) = True
+    isSourceUrlFlag (Flag_SourceModuleURL _) = True
+    isSourceUrlFlag (Flag_SourceEntityURL _) = True
+    isSourceUrlFlag (Flag_SourceLEntityURL _) = True
+    isSourceUrlFlag _ = False
+    isSourceCssFlag (Flag_SourceCss _) = True
+    isSourceCssFlag _ = False
+
+
 updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
 updateHTMLXRefs packages = do
   writeIORef html_xrefs_ref (Map.fromList mapping)