Parse work-dir argument to Path Rel Dir as soon as possible

src/Options/Applicative/Builder/Extra.hs

@@ -12,9 +12,11 @@ module Options.Applicative.Builder.Extra
   ,textOption
   ,textArgument
   ,optionalFirst
+  ,eitherReader'
   ) where
 
 import Control.Monad (when)
+import Data.Either.Combinators
 import Data.Monoid
 import Options.Applicative
 import Options.Applicative.Types (readerAsk)
@@ -136,3 +138,7 @@ textArgument = argument (T.pack <$> readerAsk)
 -- | Like 'optional', but returning a 'First'.
 optionalFirst :: Alternative f => f a -> f (First a)
 optionalFirst = fmap First . optional
+
+-- | Like 'eitherReader', but accepting any @'Show' e@ on the 'Left'.
+eitherReader' :: Show e => (String -> Either e a) -> ReadM a
+eitherReader' f = eitherReader (mapLeft show . f)

src/Stack/Config.hs

@@ -202,7 +202,7 @@ configFromConfigMonoid
     -> ConfigMonoid
     -> m Config
 configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject ConfigMonoid{..} = do
-     configWorkDir <- parseRelDir (fromFirst ".stack-work" configMonoidWorkDir)
+     let configWorkDir = fromFirst $(mkRelDir ".stack-work") configMonoidWorkDir
      -- This code is to handle the deprecation of latest-snapshot-url
      configUrls <- case (getFirst configMonoidLatestSnapshotUrl, getFirst (urlsMonoidLatestSnapshot configMonoidUrls)) of
          (Just url, Nothing) -> do

src/Stack/Options.hs

@@ -224,14 +224,14 @@ configOptsParser hide0 =
         , configMonoidModifyCodePage = modifyCodePage
         , configMonoidAllowDifferentUser = allowDifferentUser
         })
-    <$> optionalFirst (option readAbsDir
+    <$> optionalFirst (option (eitherReader' parseAbsDir)
             ( long stackRootOptionName
             <> metavar (map toUpper stackRootOptionName)
             <> help ("Absolute path to the global stack root directory " ++
                      "(Overrides any STACK_ROOT environment variable)")
             <> hide
             ))
-    <*> optionalFirst (strOption
+    <*> optionalFirst (option (eitherReader' parseRelDir)
             ( long "work-dir"
             <> metavar "WORK-DIR"
             <> help "Override work directory (default: .stack-work)"
@@ -311,15 +311,6 @@ configOptsParser hide0 =
             hide
   where hide = hideMods (hide0 /= OuterGlobalOpts)
 
-readAbsDir :: ReadM (Path Abs Dir)
-readAbsDir = do
-    s <- readerAsk
-    case parseAbsDir s of
-        Just p -> return p
-        Nothing ->
-            readerError
-                ("Failed to parse absolute path to directory: '" ++ s ++ "'")
-
 buildOptsMonoidParser :: Bool -> Parser BuildOptsMonoid
 buildOptsMonoidParser hide0 =
     transform <$> trace <*> profile <*> options

src/Stack/Types/Config.hs

@@ -149,7 +149,7 @@ module Stack.Types.Config
 import           Control.Applicative
 import           Control.Arrow ((&&&))
 import           Control.Exception
-import           Control.Monad (liftM, mzero, forM, join)
+import           Control.Monad (liftM, mzero, join)
 import           Control.Monad.Catch (MonadThrow, throwM)
 import           Control.Monad.Logger (LogLevel(..))
 import           Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)
@@ -810,7 +810,7 @@ data ConfigMonoid =
   ConfigMonoid
     { configMonoidStackRoot          :: !(First (Path Abs Dir))
     -- ^ See: 'configStackRoot'
-    , configMonoidWorkDir            :: !(First FilePath)
+    , configMonoidWorkDir            :: !(First (Path Rel Dir))
     -- ^ See: 'configWorkDir'.
     , configMonoidBuildOpts          :: !BuildOptsMonoid
     -- ^ build options.
@@ -942,11 +942,7 @@ parseConfigMonoidJSON obj = do
     configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName
 
     configMonoidGhcOptions <- obj ..:? configMonoidGhcOptionsName ..!= mempty
-
-    extraPath <- obj ..:? configMonoidExtraPathName ..!= []
-    configMonoidExtraPath <- forM extraPath $
-        either (fail . show) return . parseAbsDir . T.unpack
-
+    configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= []
     configMonoidSetupInfoLocations <-
         maybeToList <$> jsonSubWarningsT (obj ..:?  configMonoidSetupInfoLocationsName)
     configMonoidPvpBounds <- First <$> obj ..:? configMonoidPvpBoundsName