Merge pull request #6045 from commercialhaskell/forgivingResolveDir

Add forgivingResolveDir

Author: mpilgrem

src/Path/Extra.hs

@@ -14,6 +14,7 @@ module Path.Extra
   , pathToLazyByteString
   , pathToText
   , tryGetModificationTime
+  , forgivingResolveDir
   , forgivingResolveFile
   , forgivingResolveFile'
   ) where
@@ -138,6 +139,24 @@ tryGetModificationTime :: MonadIO m => Path Abs File -> m (Either () UTCTime)
 tryGetModificationTime =
   liftIO . tryJust (guard . isDoesNotExistError) . getModificationTime
 
+-- | 'Path.IO.resolveDir' (@path-io@ package) throws 'InvalidAbsDir' (@path@
+-- package) if the directory does not exist; this function yields 'Nothing'.
+forgivingResolveDir ::
+     MonadIO m
+  => Path Abs Dir
+     -- ^ Base directory
+  -> FilePath
+     -- ^ Path to resolve
+  -> m (Maybe (Path Abs Dir))
+forgivingResolveDir b p = liftIO $
+  D.canonicalizePath (toFilePath b FP.</> p) >>= \cp ->
+    catch
+      (Just <$> parseAbsDir cp)
+      ( \e -> case e of
+          InvalidAbsDir _ -> 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 ::

src/Stack/Build/Execute.hs

@@ -651,7 +651,7 @@ copyExecutables exes = do
             case loc of
                 Snap -> snapBin
                 Local -> localBin
-    mfp <- liftIO $ forgivingResolveFile bindir (T.unpack name ++ ext)
+    mfp <- forgivingResolveFile bindir (T.unpack name ++ ext)
       >>= rejectMissingFile
     case mfp of
       Nothing -> do
@@ -2482,12 +2482,13 @@ data KeepOutputOpen
   deriving Eq
 
 -- | Strip Template Haskell "Loading package" lines and making paths absolute.
-mungeBuildOutput :: forall m. MonadIO m
-                 => ExcludeTHLoading       -- ^ exclude TH loading?
-                 -> ConvertPathsToAbsolute -- ^ convert paths to absolute?
-                 -> Path Abs Dir           -- ^ package's root directory
-                 -> ActualCompiler         -- ^ compiler we're building with
-                 -> ConduitM Text Text m ()
+mungeBuildOutput ::
+     forall m. (MonadIO m, MonadUnliftIO m)
+  => ExcludeTHLoading       -- ^ exclude TH loading?
+  -> ConvertPathsToAbsolute -- ^ convert paths to absolute?
+  -> Path Abs Dir           -- ^ package's root directory
+  -> ActualCompiler         -- ^ compiler we're building with
+  -> ConduitM Text Text m ()
 mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $
   CT.lines
   .| CL.map stripCR
@@ -2529,7 +2530,7 @@ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $
     let (x, y) = T.break (== ':') bs
     mabs <-
       if isValidSuffix y
-        then liftIO $
+        then
           fmap (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $
             forgivingResolveFile pkgDir (T.unpack $ T.dropWhile isSpace x) `catch`
               \(_ :: PathException) -> pure Nothing

src/Stack/Build/Target.hs

@@ -68,8 +68,8 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as T
 import           Path ( isProperPrefixOf )
-import           Path.Extra ( rejectMissingDir )
-import           Path.IO ( forgivingAbsence, getCurrentDir, resolveDir )
+import           Path.Extra ( forgivingResolveDir, rejectMissingDir )
+import           Path.IO ( getCurrentDir )
 import           RIO.Process ( HasProcessContext )
 import           Stack.SourceMap ( additionalDepPackage )
 import           Stack.Prelude
@@ -150,8 +150,7 @@ parseRawTargetDirs root locals ri =
   case parseRawTarget t of
     Just rt -> pure $ Right [(ri, rt)]
     Nothing -> do
-      mdir <- liftIO $ forgivingAbsence (resolveDir root (T.unpack t))
-        >>= rejectMissingDir
+      mdir <- forgivingResolveDir root (T.unpack t) >>= rejectMissingDir
       case mdir of
         Nothing -> pure $ Left $
           fillSep

src/Stack/ComponentFile.hs

@@ -39,13 +39,11 @@ import           Path
                    , stripProperPrefix
                    )
 import           Path.Extra
-                   ( forgivingResolveFile, parseCollapsedAbsFile
-                   , rejectMissingDir, rejectMissingFile
+                   ( forgivingResolveDir, forgivingResolveFile
+                   , parseCollapsedAbsFile, rejectMissingDir, rejectMissingFile
                    )
 import           Path.IO
-                   ( doesDirExist, doesFileExist, forgivingAbsence
-                   , getCurrentDir, listDir, resolveDir
-                   )
+                   ( doesDirExist, doesFileExist, getCurrentDir, listDir )
 import           Stack.Constants
                    ( haskellDefaultPreprocessorExts, haskellFileExts
                    , relDirAutogen, relDirBuild, relDirGlobalAutogen
@@ -290,9 +288,7 @@ parseHI hiPath = do
       let moduleNames = fmap (fromString . T.unpack . decodeUtf8Lenient . fst) .
                         Iface.unList . Iface.dmods . Iface.deps
           resolveFileDependency file = do
-            resolved <-
-              liftIO (forgivingResolveFile dir file) >>=
-                rejectMissingFile
+            resolved <- forgivingResolveFile dir file >>= rejectMissingFile
             when (isNothing resolved) $
               prettyWarnL
               [ flow "Dependent file listed in:"
@@ -500,7 +496,7 @@ resolveDirOrWarn :: FilePath.FilePath
                  -> RIO GetPackageFileContext (Maybe (Path Abs Dir))
 resolveDirOrWarn = resolveOrWarn "Directory" f
  where
-  f p x = liftIO (forgivingAbsence (resolveDir p x)) >>= rejectMissingDir
+  f p x = forgivingResolveDir p x >>= rejectMissingDir
 
 -- | Make the global autogen dir if Cabal version is new enough.
 packageAutogenDir :: Version -> Path Abs Dir -> Maybe (Path Abs Dir)

src/Stack/Ghci.hs

@@ -235,7 +235,7 @@ preprocessTargets buildOptsCLI sma rawTargets = do
         then do
             fileTargets <- forM fileTargetsRaw $ \fp0 -> do
                 let fp = T.unpack fp0
-                mpath <- liftIO $ forgivingResolveFile' fp
+                mpath <- forgivingResolveFile' fp
                 case mpath of
                     Nothing -> throwM (MissingFileTarget fp)
                     Just path -> pure path

src/Stack/PackageFile.hs

@@ -35,7 +35,7 @@ resolveFileOrWarn :: FilePath.FilePath
                   -> RIO GetPackageFileContext (Maybe (Path Abs File))
 resolveFileOrWarn = resolveOrWarn "File" f
  where
-  f p x = liftIO (forgivingResolveFile p x) >>= rejectMissingFile
+  f p x = forgivingResolveFile p x >>= rejectMissingFile
 
 -- | Get all files referenced by the package.
 packageDescModulesAndFiles ::