diff --git a/src/Path/IO.hs b/src/Path/IO.hs index 7996b3d4b6..c3600fc74f 100644 --- a/src/Path/IO.hs +++ b/src/Path/IO.hs @@ -72,33 +72,35 @@ resolveFile x y = where fp = toFilePath x FP. y Just fp -> return fp +-- Internal helper to define resolveDirMaybe and resolveFileMaybe in one +resolveCheckParse :: (Functor m, MonadIO m) + => (FilePath -> IO Bool) -- check if file/dir does exist + -> (FilePath -> m a) -- parse into absolute file/dir + -> Path Abs Dir + -> FilePath + -> m (Maybe a) +resolveCheckParse check parse x y = do + let fp = toFilePath x FP. y + exists <- liftIO $ check fp + if exists + then do + canonic <- liftIO $ canonicalizePath fp + fmap Just (parse canonic) + else return Nothing + -- | Appends a stringly-typed relative path to an absolute path, and then -- canonicalizes it. If the path doesn't exist (and therefore cannot -- be canonicalized, 'Nothing' is returned). resolveDirMaybe :: (MonadIO m,MonadThrow m) => Path Abs Dir -> FilePath -> m (Maybe (Path Abs Dir)) -resolveDirMaybe x y = do - let fp = toFilePath x FP. y - exists <- liftIO $ doesDirectoryExist fp - if exists - then do - dir <- liftIO $ canonicalizePath fp - liftM Just (parseAbsDir dir) - else return Nothing +resolveDirMaybe = resolveCheckParse doesDirectoryExist parseAbsDir -- | Appends a stringly-typed relative path to an absolute path, and then -- canonicalizes it. If the path doesn't exist (and therefore cannot -- be canonicalized, 'Nothing' is returned). resolveFileMaybe :: (MonadIO m,MonadThrow m) => Path Abs Dir -> FilePath -> m (Maybe (Path Abs File)) -resolveFileMaybe x y = do - let fp = toFilePath x FP. y - exists <- liftIO $ doesFileExist fp - if exists - then do - file <- liftIO $ canonicalizePath fp - liftM Just (parseAbsFile file) - else return Nothing +resolveFileMaybe = resolveCheckParse doesFileExist parseAbsFile -- | List objects in a directory, excluding "@.@" and "@..@". Entries are not sorted. listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File]) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index a2346f9daf..ac841c71c0 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -724,40 +724,34 @@ buildLogPath package' = do ] return $ stack $(mkRelDir "logs") fp +-- Internal helper to define resolveFileOrWarn and resolveDirOrWarn +resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File) m) + => Text + -> (Path Abs Dir -> String -> m (Maybe a)) + -> FilePath.FilePath + -> m (Maybe a) +resolveOrWarn subject resolver path = + do cwd <- getWorkingDir + file <- ask + dir <- asks parent + result <- resolver dir path + when (isNothing result) $ + $logWarn ("Warning: " <> subject <> " listed in " <> + T.pack (maybe (FL.toFilePath file) FL.toFilePath (stripDir cwd file)) <> + " file does not exist: " <> + T.pack path) + return result + -- | Resolve the file, if it can't be resolved, warn for the user -- (purely to be helpful). resolveFileOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File) m) => FilePath.FilePath -> m (Maybe (Path Abs File)) -resolveFileOrWarn y = - do cwd <- getWorkingDir - file <- ask - dir <- asks parent - result <- resolveFileMaybe dir y - case result of - Nothing -> - $logWarn ("Warning: File listed in " <> - T.pack (maybe (FL.toFilePath file) FL.toFilePath (stripDir cwd file)) <> - " file does not exist: " <> - T.pack y) - _ -> return () - return result +resolveFileOrWarn = resolveOrWarn "File" resolveFileMaybe -- | Resolve the directory, if it can't be resolved, warn for the user -- (purely to be helpful). resolveDirOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File) m) => FilePath.FilePath -> m (Maybe (Path Abs Dir)) -resolveDirOrWarn y = - do cwd <- getWorkingDir - file <- ask - dir <- asks parent - result <- resolveDirMaybe dir y - case result of - Nothing -> - $logWarn ("Warning: Directory listed in " <> - T.pack (maybe (FL.toFilePath file) FL.toFilePath (stripDir cwd file)) <> - " file does not exist: " <> - T.pack y) - _ -> return () - return result +resolveDirOrWarn = resolveOrWarn "Directory" resolveDirMaybe