Merge pull request #6028 from commercialhaskell/fix5866

Fix #5866 Replace duff `forgivingAbsence $ resolveFile ...`

Author: mpilgrem

src/Path/Extra.hs

@@ -14,21 +14,27 @@ module Path.Extra
   , pathToLazyByteString
   , pathToText
   , tryGetModificationTime
+  , forgivingResolveFile
+  , forgivingResolveFile'
   ) where
 
 import           Data.Time ( UTCTime )
 import           Path
-                   ( Abs, Dir, File, Rel, parseAbsDir, parseAbsFile
-                   , toFilePath
+                   ( Abs, Dir, File, PathException (..), Rel, parseAbsDir
+                   , parseAbsFile, toFilePath
                    )
 import           Path.Internal ( Path (Path) )
-import           Path.IO ( doesDirExist, doesFileExist, getModificationTime )
+import           Path.IO
+                   ( doesDirExist, doesFileExist, getCurrentDir
+                   , getModificationTime
+                   )
 import           RIO
 import           System.IO.Error ( isDoesNotExistError )
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as BSL
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
+import qualified System.Directory as D
 import qualified System.FilePath as FP
 
 -- | Convert to FilePath but don't add a trailing slash.
@@ -131,3 +137,30 @@ pathToText = T.pack . toFilePath
 tryGetModificationTime :: MonadIO m => Path Abs File -> m (Either () UTCTime)
 tryGetModificationTime =
   liftIO . tryJust (guard . isDoesNotExistError) . getModificationTime
+
+-- | 'Path.IO.resolveFile' (@path-io@ package) throws 'InvalidAbsFile' (@path@
+-- package) if the file does not exist; this function yields 'Nothing'.
+forgivingResolveFile ::
+     MonadIO m
+  => Path Abs Dir
+     -- ^ Base directory
+  -> FilePath
+     -- ^ Path to resolve
+  -> m (Maybe (Path Abs File))
+forgivingResolveFile b p = liftIO $
+  D.canonicalizePath (toFilePath b FP.</> p) >>= \cp ->
+    catch
+      (Just <$> parseAbsFile cp)
+      ( \e -> case e of
+          InvalidAbsFile _ -> pure Nothing
+          _ -> throwIO e
+      )
+
+-- | 'Path.IO.resolveFile'' (@path-io@ package) throws 'InvalidAbsFile' (@path@
+-- package) if the file does not exist; this function yields 'Nothing'.
+forgivingResolveFile' ::
+     MonadIO m
+  => FilePath
+     -- ^ Path to resolve
+  -> m (Maybe (Path Abs File))
+forgivingResolveFile' p = getCurrentDir >>= flip forgivingResolveFile p

src/Stack/Build/Execute.hs

@@ -70,11 +70,14 @@ import           Path
                    , stripProperPrefix
                    )
 import           Path.CheckInstall ( warnInstallSearchPathIssues )
-import           Path.Extra ( toFilePathNoTrailingSep, rejectMissingFile )
+import           Path.Extra
+                   ( forgivingResolveFile, rejectMissingFile
+                   , toFilePathNoTrailingSep
+                   )
 import           Path.IO
                    ( copyFile, doesDirExist, doesFileExist, ensureDir
-                   , forgivingAbsence, ignoringAbsence, removeDirRecur
-                   , removeFile, renameDir, renameFile, resolveFile
+                   , ignoringAbsence, removeDirRecur, removeFile, renameDir
+                   , renameFile
                    )
 import           RIO.Process
                    ( HasProcessContext, byteStringInput, doesExecutableExist
@@ -648,7 +651,7 @@ copyExecutables exes = do
             case loc of
                 Snap -> snapBin
                 Local -> localBin
-    mfp <- liftIO $ forgivingAbsence (resolveFile bindir $ T.unpack name ++ ext)
+    mfp <- liftIO $ forgivingResolveFile bindir (T.unpack name ++ ext)
       >>= rejectMissingFile
     case mfp of
       Nothing -> do
@@ -2528,7 +2531,7 @@ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $
       if isValidSuffix y
         then liftIO $
           fmap (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $
-            forgivingAbsence (resolveFile pkgDir (T.unpack $ T.dropWhile isSpace x)) `catch`
+            forgivingResolveFile pkgDir (T.unpack $ T.dropWhile isSpace x) `catch`
               \(_ :: PathException) -> pure Nothing
         else pure Nothing
     case mabs of

src/Stack/ComponentFile.hs

@@ -39,11 +39,12 @@ import           Path
                    , stripProperPrefix
                    )
 import           Path.Extra
-                   ( parseCollapsedAbsFile, rejectMissingDir, rejectMissingFile
+                   ( forgivingResolveFile, parseCollapsedAbsFile
+                   , rejectMissingDir, rejectMissingFile
                    )
 import           Path.IO
                    ( doesDirExist, doesFileExist, forgivingAbsence
-                   , getCurrentDir, listDir, resolveDir, resolveFile
+                   , getCurrentDir, listDir, resolveDir
                    )
 import           Stack.Constants
                    ( haskellDefaultPreprocessorExts, haskellFileExts
@@ -290,7 +291,7 @@ parseHI hiPath = do
                         Iface.unList . Iface.dmods . Iface.deps
           resolveFileDependency file = do
             resolved <-
-              liftIO (forgivingAbsence (resolveFile dir file)) >>=
+              liftIO (forgivingResolveFile dir file) >>=
                 rejectMissingFile
             when (isNothing resolved) $
               prettyWarnL

src/Stack/Ghci.hs

@@ -26,7 +26,7 @@ import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TLE
 import qualified Distribution.PackageDescription as C
 import           Path
-import           Path.Extra ( toFilePathNoTrailingSep )
+import           Path.Extra ( forgivingResolveFile', toFilePathNoTrailingSep )
 import           Path.IO hiding ( withSystemTempDir )
 import           RIO.Process
                    ( HasProcessContext, exec, proc, readProcess_
@@ -235,7 +235,7 @@ preprocessTargets buildOptsCLI sma rawTargets = do
         then do
             fileTargets <- forM fileTargetsRaw $ \fp0 -> do
                 let fp = T.unpack fp0
-                mpath <- liftIO $ forgivingAbsence (resolveFile' fp)
+                mpath <- liftIO $ forgivingResolveFile' fp
                 case mpath of
                     Nothing -> throwM (MissingFileTarget fp)
                     Just path -> pure path

src/Stack/PackageFile.hs

@@ -15,8 +15,7 @@ import           Distribution.PackageDescription hiding ( FlagName )
 import           Distribution.Simple.Glob ( matchDirFileGlob )
 import qualified Distribution.Types.UnqualComponentName as Cabal
 import           Path ( parent )
-import           Path.Extra ( rejectMissingFile )
-import           Path.IO ( forgivingAbsence, resolveFile )
+import           Path.Extra ( forgivingResolveFile, rejectMissingFile )
 import           Stack.ComponentFile
                    ( benchmarkFiles, executableFiles, libraryFiles
                    , resolveOrWarn, testFiles
@@ -36,7 +35,7 @@ resolveFileOrWarn :: FilePath.FilePath
                   -> RIO GetPackageFileContext (Maybe (Path Abs File))
 resolveFileOrWarn = resolveOrWarn "File" f
  where
-  f p x = liftIO (forgivingAbsence (resolveFile p x)) >>= rejectMissingFile
+  f p x = liftIO (forgivingResolveFile p x) >>= rejectMissingFile
 
 -- | Get all files referenced by the package.
 packageDescModulesAndFiles ::