Introduce `MaybeValidated` type to remove invalid states

The old return type `(RecompRequired, Maybe _)`, was confusing
because it was inhabited by values like `(UpToDate, Nothing)` that made
no sense.

The new type ensures:

 - you must provide a value if it is up to date.

 - you must provide a reason if you don't provide a value.

it is used as the return value of:

 - `checkOldIface`
 - `checkByteCode`
 - `checkObjects`

2 files changed, 88 insertions, 63 deletions

diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 8fd8dad634..2ec37e3b10 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -751,41 +751,45 @@ hscRecompStatus
     -- Save the interface that comes back from checkOldIface.
     -- In one-shot mode we don't have the old iface until this
     -- point, when checkOldIface reads it from the disk.
-    (recomp_iface_reqd, mb_checked_iface)
+    recomp_if_result
           <- {-# SCC "checkOldIface" #-}
              liftIO $ checkOldIface hsc_env mod_summary mb_old_iface
-    let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface
-    case recomp_iface_reqd of
-      NeedsRecompile _ -> do
-        msg recomp_iface_reqd
-        return $ HscRecompNeeded mb_old_hash
-      UpToDate -> do
-        -- Check to see whether the expected build products already exist.
-        -- If they don't exists then we trigger recompilation.
+    case recomp_if_result of
+      OutOfDateItem reason mb_checked_iface -> do
+        msg $ NeedsRecompile reason
+        return $ HscRecompNeeded $ fmap (mi_iface_hash . mi_final_exts) mb_checked_iface
+      UpToDateItem checked_iface -> do
         let lcl_dflags = ms_hspp_opts mod_summary
-        (recomp_obj_reqd, mb_linkable) <-
-          case () of
-            -- No need for a linkable, we're good to go
-            _ | NoBackend <- backend lcl_dflags   -> return (UpToDate, Nothing)
-              -- Interpreter can use either already loaded bytecode or loaded object code
-              | not (backendProducesObject (backend lcl_dflags)) -> do
-                  let res = checkByteCode old_linkable
-                  case res of
-                    (_, Just{}) -> return res
-                    _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary
-              -- Need object files for making object files
-              | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary
-              | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)
-        msg recomp_obj_reqd
-        case (mb_checked_iface, recomp_obj_reqd) of
-            (Just iface, UpToDate) ->
-              return $ HscUpToDate iface mb_linkable
-            _ ->
-              return $ HscRecompNeeded mb_old_hash
+        case backend lcl_dflags of
+          -- No need for a linkable, we're good to go
+          NoBackend -> do
+            msg $ UpToDate
+            return $ HscUpToDate checked_iface Nothing
+          -- Do need linkable
+          _ -> do
+            -- Check to see whether the expected build products already exist.
+            -- If they don't exists then we trigger recompilation.
+            recomp_linkable_result <- case () of
+               -- Interpreter can use either already loaded bytecode or loaded object code
+               _ | Interpreter <- backend lcl_dflags -> do
+                     let res = checkByteCode old_linkable
+                     case res of
+                       UpToDateItem _ -> pure res
+                       _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary
+                 -- Need object files for making object files
+                 | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary
+                 | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)
+            case recomp_linkable_result of
+              UpToDateItem linkable -> do
+                msg $ UpToDate
+                return $ HscUpToDate checked_iface $ Just linkable
+              OutOfDateItem reason _ -> do
+                msg $ NeedsRecompile reason
+                return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface
 
 -- | Check that the .o files produced by compilation are already up-to-date
 -- or not.
-checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (RecompileRequired, Maybe Linkable)
+checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)
 checkObjects dflags mb_old_linkable summary = do
   let
     dt_enabled  = gopt Opt_BuildDynamicToo dflags
@@ -798,11 +802,11 @@ checkObjects dflags mb_old_linkable summary = do
     -- that's there, and if it's not, regenerate both .o and
     -- .dyn_o
     checkDynamicObj k = if dt_enabled
-                          then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of
-                                      Just True -> k
-                                      _ -> return (needsRecompileBecause MissingDynObjectFile, Nothing)
-                          -- Not in dynamic-too mode
-                          else k
+      then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of
+        Just True -> k
+        _ -> return $ outOfDateItemBecause MissingDynObjectFile Nothing
+      -- Not in dynamic-too mode
+      else k
 
   checkDynamicObj $
     case (,) <$> mb_obj_date <*> mb_if_date of
@@ -811,20 +815,20 @@ checkObjects dflags mb_old_linkable summary = do
             case mb_old_linkable of
               Just old_linkable
                 | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date
-                -> return $ (UpToDate, Just old_linkable)
-              _ -> (UpToDate,) . Just <$> findObjectLinkable this_mod obj_fn obj_date
-      _ -> return (needsRecompileBecause MissingObjectFile, Nothing)
+                -> return $ UpToDateItem old_linkable
+              _ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date
+      _ -> return $ outOfDateItemBecause MissingObjectFile Nothing
 
 -- | Check to see if we can reuse the old linkable, by this point we will
 -- have just checked that the old interface matches up with the source hash, so
 -- no need to check that again here
-checkByteCode :: Maybe Linkable -> (RecompileRequired, Maybe Linkable)
+checkByteCode :: Maybe Linkable -> MaybeValidated Linkable
 checkByteCode mb_old_linkable =
   case mb_old_linkable of
     Just old_linkable
       | not (isObjectLinkable old_linkable)
-      -> (UpToDate, Just old_linkable)
-    _ -> (needsRecompileBecause MissingBytecode, Nothing)
+      -> UpToDateItem old_linkable
+    _ -> outOfDateItemBecause MissingBytecode Nothing
 
 --------------------------------------------------------------
 -- Compilers
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 542901bad1..6d09892fdf 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE TupleSections #-}
@@ -9,6 +10,8 @@ module GHC.Iface.Recomp
    , RecompileRequired(..)
    , needsRecompileBecause
    , recompThen
+   , MaybeValidated(..)
+   , outOfDateItemBecause
    , RecompReason (..)
    , CompileReason(..)
    , recompileRequired
@@ -124,6 +127,20 @@ data RecompileRequired
 needsRecompileBecause :: RecompReason -> RecompileRequired
 needsRecompileBecause = NeedsRecompile . RecompBecause
 
+data MaybeValidated a
+  -- | The item contained is validated to be up to date
+  = UpToDateItem a
+  -- | The item is are absent altogether or out of date, for the reason given.
+  | OutOfDateItem
+      !CompileReason
+      -- ^ the reason we need to recompile.
+      (Maybe a)
+      -- ^ The old item, if it exists
+  deriving (Functor)
+
+outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a
+outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item
+
 data CompileReason
   -- | The .hs file has been touched, or the .o/.hi file does not exist
   = MustCompile
@@ -227,15 +244,18 @@ checkList = \case
 
 -- | Top level function to check if the version of an old interface file
 -- is equivalent to the current source file the user asked us to compile.
--- If the same, we can avoid recompilation. We return a tuple where the
--- first element is a bool saying if we should recompile the object file
--- and the second is maybe the interface file, where Nothing means to
--- rebuild the interface file and not use the existing one.
+-- If the same, we can avoid recompilation.
+--
+-- We return on the outside whether the interface file is up to date, providing
+-- evidence that is with a `ModIface`. In the case that it isn't, we may also
+-- return a found or provided `ModIface`. Why we don't always return the old
+-- one, if it exists, is unclear to me, except that I tried it and some tests
+-- failed (see #18205).
 checkOldIface
   :: HscEnv
   -> ModSummary
   -> Maybe ModIface         -- Old interface from compilation manager, if any
-  -> IO (RecompileRequired, Maybe ModIface)
+  -> IO (MaybeValidated ModIface)
 
 checkOldIface hsc_env mod_summary maybe_iface
   = do  let dflags = hsc_dflags hsc_env
@@ -251,7 +271,7 @@ check_old_iface
   :: HscEnv
   -> ModSummary
   -> Maybe ModIface
-  -> IfG (RecompileRequired, Maybe ModIface)
+  -> IfG (MaybeValidated ModIface)
 
 check_old_iface hsc_env mod_summary maybe_iface
   = let dflags = hsc_dflags hsc_env
@@ -276,18 +296,18 @@ check_old_iface hsc_env mod_summary maybe_iface
                      trace_if logger (text "Read the interface file" <+> text iface_path)
                      return $ Just iface
         check_dyn_hi :: ModIface
-                  -> IfG (RecompileRequired, Maybe a)
-                  -> IfG (RecompileRequired, Maybe a)
+                  -> IfG (MaybeValidated ModIface)
+                  -> IfG (MaybeValidated ModIface)
         check_dyn_hi normal_iface recomp_check | gopt Opt_BuildDynamicToo dflags = do
           res <- recomp_check
-          case fst res of
-            UpToDate -> do
+          case res of
+            UpToDateItem _ -> do
               maybe_dyn_iface <- liftIO $ loadIface (setDynamicNow dflags) (msDynHiFilePath mod_summary)
               case maybe_dyn_iface of
-                Nothing -> return (needsRecompileBecause MissingDynHiFile, Nothing)
+                Nothing -> return $ outOfDateItemBecause MissingDynHiFile Nothing
                 Just dyn_iface | mi_iface_hash (mi_final_exts dyn_iface)
                                     /= mi_iface_hash (mi_final_exts normal_iface)
-                  -> return (needsRecompileBecause MismatchedDynHiFile, Nothing)
+                  -> return $ outOfDateItemBecause MismatchedDynHiFile Nothing
                 Just {} -> return res
             _ -> return res
         check_dyn_hi _ recomp_check = recomp_check
@@ -305,19 +325,19 @@ check_old_iface hsc_env mod_summary maybe_iface
             -- avoid reading an interface; just return the one we might
             -- have been supplied with.
             True | not (backendProducesObject $ backend dflags) ->
-                return (NeedsRecompile MustCompile, maybe_iface)
+                return $ OutOfDateItem MustCompile maybe_iface
 
             -- Try and read the old interface for the current module
             -- from the .hi file left from the last time we compiled it
             True -> do
                 maybe_iface' <- liftIO $ getIface
-                return (NeedsRecompile MustCompile, maybe_iface')
+                return $ OutOfDateItem MustCompile maybe_iface'
 
             False -> do
                 maybe_iface' <- liftIO $ getIface
                 case maybe_iface' of
                     -- We can't retrieve the iface
-                    Nothing    -> return (NeedsRecompile MustCompile, Nothing)
+                    Nothing    -> return $ OutOfDateItem MustCompile Nothing
 
                     -- We have got the old iface; check its versions
                     -- even in the SourceUnmodifiedAndStable case we
@@ -340,7 +360,7 @@ check_old_iface hsc_env mod_summary maybe_iface
 checkVersions :: HscEnv
               -> ModSummary
               -> ModIface       -- Old interface
-              -> IfG (RecompileRequired, Maybe ModIface)
+              -> IfG (MaybeValidated ModIface)
 checkVersions hsc_env mod_summary iface
   = do { liftIO $ trace_hi_diffs logger
                         (text "Considering whether compilation is required for" <+>
@@ -351,20 +371,20 @@ checkVersions hsc_env mod_summary iface
        -- test case bkpcabal04!
        ; hsc_env <- getTopEnv
        ; if mi_src_hash iface /= ms_hs_hash mod_summary
-            then return (needsRecompileBecause SourceFileChanged, Nothing) else do {
+            then return $ outOfDateItemBecause SourceFileChanged Nothing else do {
        ; if not (isHomeModule home_unit (mi_module iface))
-            then return (needsRecompileBecause ThisUnitIdChanged, Nothing) else do {
+            then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do {
        ; recomp <- liftIO $ checkFlagHash hsc_env iface
                              `recompThen` checkOptimHash hsc_env iface
                              `recompThen` checkHpcHash hsc_env iface
                              `recompThen` checkMergedSignatures hsc_env mod_summary iface
                              `recompThen` checkHsig logger home_unit mod_summary iface
                              `recompThen` pure (checkHie dflags mod_summary)
-       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {
        ; recomp <- checkDependencies hsc_env mod_summary iface
-       ; if recompileRequired recomp then return (recomp, Just iface) else do {
+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {
        ; recomp <- checkPlugins (hsc_plugins hsc_env) iface
-       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {
 
 
        -- Source code unchanged and no errors yet... carry on
@@ -382,8 +402,9 @@ checkVersions hsc_env mod_summary iface
        }
        ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) (homeUnitAsUnit home_unit) u
                              | u <- mi_usages iface]
-       ; return (recomp, Just iface)
-    }}}}}}
+       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {
+       ; return $ UpToDateItem iface
+    }}}}}}}
   where
     logger = hsc_logger hsc_env
     dflags = hsc_dflags hsc_env