1 files changed, 19 insertions, 6 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 554cb416..44dfb7b2 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -42,7 +42,7 @@ import Haddock.Utils
 
 import Control.Monad hiding (forM_)
 import Control.Applicative
-import Data.Foldable (forM_)
+import Data.Foldable (forM_, foldl')
 import Data.List (isPrefixOf)
 import Control.Exception
 import Data.Maybe
@@ -163,7 +163,6 @@ haddockWithGhc ghc args = handleTopExceptions $ do
       hPutStrLn stderr warning
 
   ghc flags' $ do
-
     dflags <- getDynFlags
 
     forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
@@ -404,8 +403,11 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
     ghcMode   = CompManager,
     ghcLink   = NoLink
     }
-  let dynflags'' = updOptLevel 0 $ gopt_unset dynflags' Opt_SplitObjs
-
+  -- We disable pattern match warnings because than can be very
+  -- expensive to check
+  let dynflags'' = unsetPatternMatchWarnings $
+        updOptLevel 0 $
+        gopt_unset dynflags' Opt_SplitObjs
   -- ignore the following return-value, which is a list of packages
   -- that may need to be re-linked: Haddock doesn't do any
   -- dynamic or static linking at all!
@@ -421,6 +423,17 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
         then throwE ("Couldn't parse GHC options: " ++ unwords flags)
         else return dynflags'
 
+unsetPatternMatchWarnings :: DynFlags -> DynFlags
+unsetPatternMatchWarnings dflags =
+  foldl' wopt_unset dflags pattern_match_warnings
+  where
+    pattern_match_warnings =
+      [ Opt_WarnIncompletePatterns
+      , Opt_WarnIncompleteUniPatterns
+      , Opt_WarnIncompletePatternsRecUpd
+      , Opt_WarnOverlappingPatterns
+      ]
+
 -------------------------------------------------------------------------------
 -- * Misc
 -------------------------------------------------------------------------------
@@ -445,9 +458,9 @@ getHaddockLibDir flags =
             exists <- doesDirectoryExist p
             pure $ if exists then Just p else Nothing
 
-      dirs <- mapM check res_dirs  
+      dirs <- mapM check res_dirs
       case [p | Just p <- dirs] of
-        (p : _) -> return p 
+        (p : _) -> return p
         _       -> die "Haddock's resource directory does not exist!\n"
 #endif
     fs -> return (last fs)