Avoid recomputing stack yaml path in #1340

commercialhaskell · Nov 16, 2015 · a4869ef · a4869ef
1 parent 2798368
commit a4869ef
Showing 1 changed file with 14 additions and 11 deletions.
diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -94,7 +94,7 @@ configFromConfigMonoid
     :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env)
     => Path Abs Dir -- ^ stack root, e.g. ~/.stack
     -> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml
-    -> Maybe Project
+    -> Maybe (Project, Path Abs File)
     -> ConfigMonoid
     -> m Config
 configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoid@ConfigMonoid{..} = do
@@ -142,7 +142,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi
 
          configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck
 
-     configDocker <- dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts
+     configDocker <- dockerOptsFromMonoid (fmap fst mproject) configStackRoot configMonoidDockerOpts
 
      rawEnv <- liftIO getEnvironment
      origEnv <- mkEnvOverride configPlatform
@@ -168,14 +168,16 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi
                  localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir
                  return $ localDir </> $(mkRelDir "bin")
              Just userPath ->
-                  (getProjectConfig Nothing >>= \case
-                       Nothing ->
-                       -- ^ Not in a project
-                           liftIO (canonicalizePath userPath >>= parseAbsDir)
-                       Just (parent -> sYamlDir) -> (resolveDir sYamlDir userPath))
-                       -- ^ Resolves to the project dir and appends the user path if it is relative
-                  `catchAll`
-                  const (throwM (NoSuchDirectory userPath))
+                 (case mproject of
+                     -- Not in a project
+                     Nothing -> parseRelAsAbsDir userPath
+                     -- Resolves to the project dir and appends the user path if it is relative
+                     Just (_, configYaml) -> resolveDir (parent configYaml) userPath)
+                 -- TODO: Either catch specific exceptions or add a
+                 -- parseRelAsAbsDirMaybe utility and use it along with
+                 -- resolveDirMaybe.
+                 `catchAll`
+                 const (throwM (NoSuchDirectory userPath))
 
      configJobs <-
         case configMonoidJobs of
@@ -278,7 +280,8 @@ loadConfig configArgs mstackYaml = do
                               (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = False}})
                 extraConfigs0
     mproject <- loadProjectConfig mstackYaml
-    config <- configFromConfigMonoid stackRoot userConfigPath (fmap (\(proj, _, _) -> proj) mproject) $ mconcat $
+    let mproject' = (\(project, stackYaml, _) -> (project, stackYaml)) <$> mproject
+    config <- configFromConfigMonoid stackRoot userConfigPath mproject' $ mconcat $
         case mproject of
             Nothing -> configArgs : extraConfigs
             Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs