Reduce duplication in file resolver functions

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])

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