Let `haddock-test` bypass interface version check (#890)

This means `haddock-test` might

  * crash during deserialization
  * deserialize incorrectly

Still - it means things _might_ work where they were previously sure
not to.

3 files changed, 23 insertions, 7 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 00eb50f6..40da7ceb 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -159,16 +159,21 @@ haddockWithGhc ghc args = handleTopExceptions $ do
           Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
           _ -> return flags
 
+  -- bypass the interface version check
+  let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
+
   unless (Flag_NoWarnings `elem` flags) $ do
     hypSrcWarnings flags
     forM_ (warnings args) $ \warning -> do
       hPutStrLn stderr warning
+    when noChecks $
+      hPutStrLn stderr noCheckWarning
 
   ghc flags' $ do
     dflags <- getDynFlags
 
     forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
-      mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)]
+      mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
       forM_ mIfaceFile $ \(_, ifaceFile) -> do
         putMsg dflags (renderJson (jsonInterfaceFile ifaceFile))
 
@@ -190,7 +195,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
         throwE "No input file(s)."
 
       -- Get packages supplied with --read-interface.
-      packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
+      packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
 
       -- Render even though there are no input files (usually contents/index).
       liftIO $ renderStep dflags flags sinceQual qual packages []
@@ -201,6 +206,10 @@ warnings = map format . filter (isPrefixOf "-optghc")
   where
     format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"]
 
+-- | Create a warning about bypassing the interface version check
+noCheckWarning :: String
+noCheckWarning = "Warning: `--bypass-interface-version-check' can cause " ++
+                 "Haddock to crash when reading Haddock interface files."
 
 withGhc :: [Flag] -> Ghc a -> IO a
 withGhc flags action = do
@@ -218,7 +227,8 @@ readPackagesAndProcessModules :: [Flag] -> [String]
                               -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
 readPackagesAndProcessModules flags files = do
     -- Get packages supplied with --read-interface.
-    packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
+    let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
+    packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks
 
     -- Create the interfaces -- this is the core part of Haddock.
     let ifaceFiles = map snd packages
@@ -398,13 +408,14 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
 readInterfaceFiles :: MonadIO m
                    => NameCacheAccessor m
                    -> [(DocPaths, FilePath)]
+                   -> Bool
                    -> m [(DocPaths, InterfaceFile)]
-readInterfaceFiles name_cache_accessor pairs = do
+readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
   catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
   where
     -- try to read an interface, warn if we can't
     tryReadIface (paths, file) =
-      readInterfaceFile name_cache_accessor file >>= \case
+      readInterfaceFile name_cache_accessor file bypass_version_check >>= \case
         Left err -> liftIO $ do
           putStrLn ("Warning: Cannot read " ++ file ++ ":")
           putStrLn ("   " ++ err)
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 57886999..30bd2b9a 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -190,8 +190,9 @@ readInterfaceFile :: forall m.
                      MonadIO m
                   => NameCacheAccessor m
                   -> FilePath
+                  -> Bool  -- ^ Disable version check. Can cause runtime crash.
                   -> m (Either String InterfaceFile)
-readInterfaceFile (get_name_cache, set_name_cache) filename = do
+readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do
   bh0 <- liftIO $ readBinMem filename
 
   magic   <- liftIO $ get bh0
@@ -200,7 +201,8 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do
   case () of
     _ | magic /= binaryInterfaceMagic -> return . Left $
       "Magic number mismatch: couldn't load interface file: " ++ filename
-      | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $
+      | not bypass_checks
+      , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $
       "Interface file is of wrong version: " ++ filename
       | otherwise -> with_name_cache $ \update_nc -> do
 
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index b5e987d8..e89fcbde 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -84,6 +84,7 @@ data Flag
   | Flag_Version
   | Flag_CompatibleInterfaceVersions
   | Flag_InterfaceVersion
+  | Flag_BypassInterfaceVersonCheck
   | Flag_UseContents String
   | Flag_GenContents
   | Flag_UseIndex String
@@ -175,6 +176,8 @@ options backwardsCompat =
       "output compatible interface file versions and exit",
     Option []  ["interface-version"]  (NoArg Flag_InterfaceVersion)
       "output interface file version and exit",
+    Option []  ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck)
+      "bypass the interface file version check (dangerous)",
     Option ['v']  ["verbosity"]  (ReqArg Flag_Verbosity "VERBOSITY")
       "set verbosity level",
     Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")