Let Cabal determine the package-db stack

Language/Haskell/GhcMod/CabalHelper.hs

@@ -15,23 +15,28 @@
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 {-# LANGUAGE CPP #-}
-module Language.Haskell.GhcMod.CabalHelper (
+module Language.Haskell.GhcMod.CabalHelper
-    getComponents
+#ifndef SPEC
+  ( getComponents
   , getGhcMergedPkgOptions
-  ) where
+  , getPackageDbStack
+  )
+#endif
+  where
 
 import Control.Applicative
 import Control.Monad
+import Data.Maybe
 import Data.Monoid
 import Data.Version
 import Data.Serialize (Serialize)
+import Data.Traversable
 import Distribution.Helper
 import qualified Language.Haskell.GhcMod.Types as T
 import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram,
                                              cabalProgram)
 import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Utils
-import Language.Haskell.GhcMod.World
 import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Logging
 import System.FilePath
@@ -50,12 +55,35 @@ getGhcMergedPkgOptions = chCached Cached {
     return ([setupConfigPath], opts)
  }
 
-helperProgs :: Options -> Programs
+parseCustomPackageDb :: String -> [GhcPkgDb]
-helperProgs opts = Programs {
+parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src
-                            cabalProgram  = T.cabalProgram opts,
+ where
-                            ghcProgram    = T.ghcProgram opts,
+   parsePkgDb "global" = GlobalDb
-                            ghcPkgProgram = T.ghcPkgProgram opts
+   parsePkgDb "user" = UserDb
-                          }
+   parsePkgDb s = PackageDb s
+
+getCustomPkgDbStack :: (IOish m, GmEnv m) => m (Maybe [GhcPkgDb])
+getCustomPkgDbStack = do
+    mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle
+    return $ parseCustomPackageDb <$> mCusPkgDbFile
+
+getPackageDbStack :: (IOish m, GmEnv m, GmLog m) => m [GhcPkgDb]
+getPackageDbStack = do
+    mCusPkgStack <- getCustomPkgDbStack
+    flip fromMaybe mCusPkgStack <$> getPackageDbStack'
+
+getPackageDbStack' :: (IOish m, GmEnv m, GmLog m) => m [GhcPkgDb]
+getPackageDbStack' = chCached Cached {
+  cacheFile = pkgDbStackCacheFile,
+  cachedAction = \ _tcf (progs, root, _) _ma -> do
+    dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery' progs root packageDbStack
+    return ([setupConfigPath, sandboConfigFile], dbs)
+ }
+
+chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb
+chPkgToGhcPkg ChPkgGlobal = GlobalDb
+chPkgToGhcPkg ChPkgUser = UserDb
+chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f
 
 -- | Primary interface to cabal-helper and intended single entrypoint to
 -- constructing 'GmComponent's
@@ -66,23 +94,6 @@ getComponents :: (Applicative m, IOish m, GmEnv m, GmLog m)
               => m [GmComponent 'GMCRaw ChEntrypoint]
 getComponents = chCached cabalHelperCache
 
-chCached :: (Applicative m, IOish m, GmEnv m, GmLog m, Serialize a)
-         => Cached m (Programs, FilePath, (Version, [Char])) a -> m a
-chCached c = do
-  root <- cradleRootDir <$> cradle
-  d <- cacheInputData root
-  withCabal $ cached root c d
- where
-   cacheInputData root = do
-               opt <- options
-               return $ ( helperProgs opt
-                        , root </> "dist"
-                        , (gmVer, chVer)
-                        )
-
-   gmVer = GhcMod.version
-   chVer = VERSION_cabal_helper
-
 cabalHelperCache
   :: (Functor m, Applicative m, MonadIO m)
   => Cached m (Programs, FilePath, (Version, String)) [GmComponent 'GMCRaw ChEntrypoint]
@@ -116,18 +127,37 @@ withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a
 withCabal action = do
     crdl <- cradle
     opts <- options
-    whenM (liftIO $ isSetupConfigOutOfDate <$> getCurrentWorld crdl) $
+    mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
+    mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
+
+    mCusPkgDbStack <- getCustomPkgDbStack
+
+    pkgDbStackOutOfSync <-
+         case mCusPkgDbStack of
+           Just cusPkgDbStack -> do
+             pkgDb <- runQuery' (helperProgs opts) (cradleRootDir crdl </> "dist") $
+                 map chPkgToGhcPkg <$> packageDbStack
+             return $ pkgDb /= cusPkgDbStack
+
+           Nothing -> return False
+
+    cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
+
+    when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $
+      gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project."
+    when pkgDbStackOutOfSync $
+      gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack, reconfiguring Cabal project."
+
+    when (isSetupConfigOutOfDate mCabalFile mCabalConfig || pkgDbStackOutOfSync) $
         withDirectory_ (cradleRootDir crdl) $ do
-            let pkgDbArgs = "--package-db=clear" : map pkgDbArg (cradlePkgDbStack crdl)
+            let progOpts =
-                progOpts =
                     [ "--with-ghc=" ++ T.ghcProgram opts ]
                     -- Only pass ghc-pkg if it was actually set otherwise we
                     -- might break cabal's guessing logic
                     ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions
                          then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
                          else []
-                    ++ pkgDbArgs
+                    ++ map pkgDbArg cusPkgStack
-            gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project."
             liftIO $ void $ readProcess (T.cabalProgram opts) ("configure":progOpts) ""
             gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
             liftIO $ writeAutogenFiles $ cradleRootDir crdl </> "dist"
@@ -137,3 +167,45 @@ pkgDbArg :: GhcPkgDb -> String
 pkgDbArg GlobalDb      = "--package-db=global"
 pkgDbArg UserDb        = "--package-db=user"
 pkgDbArg (PackageDb p) = "--package-db=" ++ p
+
+-- * Neither file exists -> should return False:
+--   @Nothing < Nothing = False@
+--   (since we don't need to @cabal configure@ when no cabal file exists.)
+--
+-- * Cabal file doesn't exist (unlikely case) -> should return False
+--   @Just cc < Nothing = False@
+--   TODO: should we delete dist/setup-config?
+--
+-- * dist/setup-config doesn't exist yet -> should return True:
+--   @Nothing < Just cf = True@
+--
+-- * Both files exist
+--   @Just cc < Just cf = cc < cf = cc `olderThan` cf@
+isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool
+isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do
+  worldCabalConfig < worldCabalFile
+
+
+helperProgs :: Options -> Programs
+helperProgs opts = Programs {
+                            cabalProgram  = T.cabalProgram opts,
+                            ghcProgram    = T.ghcProgram opts,
+                            ghcPkgProgram = T.ghcPkgProgram opts
+                          }
+
+chCached :: (Applicative m, IOish m, GmEnv m, GmLog m, Serialize a)
+         => Cached m (Programs, FilePath, (Version, [Char])) a -> m a
+chCached c = do
+  root <- cradleRootDir <$> cradle
+  d <- cacheInputData root
+  withCabal $ cached root c d
+ where
+   cacheInputData root = do
+               opt <- options
+               return $ ( helperProgs opt
+                        , root </> "dist"
+                        , (gmVer, chVer)
+                        )
+
+   gmVer = GhcMod.version
+   chVer = VERSION_cabal_helper

Language/Haskell/GhcMod/Cradle.hs

@@ -57,14 +57,11 @@ customCradle :: FilePath -> MaybeT IO Cradle
 customCradle wdir = do
     cabalFile <- MaybeT $ findCabalFile wdir
     let cabalDir = takeDirectory cabalFile
-    cradleFile <- MaybeT $ findCradleFile cabalDir
-    pkgDbStack <- liftIO $ parseCradle cradleFile
     return Cradle {
         cradleCurrentDir = wdir
       , cradleRootDir    = cabalDir
       , cradleTempDir    = error "tmpDir"
       , cradleCabalFile  = Just cabalFile
-      , cradlePkgDbStack = pkgDbStack
       }
 
 cabalCradle :: FilePath -> MaybeT IO Cradle
@@ -72,26 +69,22 @@ cabalCradle wdir = do
     cabalFile <- MaybeT $ findCabalFile wdir
 
     let cabalDir = takeDirectory cabalFile
-    pkgDbStack <- liftIO $ getPackageDbStack cabalDir
 
     return Cradle {
         cradleCurrentDir = wdir
       , cradleRootDir    = cabalDir
       , cradleTempDir    = error "tmpDir"
       , cradleCabalFile  = Just cabalFile
-      , cradlePkgDbStack = pkgDbStack
       }
 
 sandboxCradle :: FilePath -> MaybeT IO Cradle
 sandboxCradle wdir = do
     sbDir <- MaybeT $ findCabalSandboxDir wdir
-    pkgDbStack <- liftIO $ getPackageDbStack sbDir
     return Cradle {
         cradleCurrentDir = wdir
       , cradleRootDir    = sbDir
       , cradleTempDir    = error "tmpDir"
       , cradleCabalFile  = Nothing
-      , cradlePkgDbStack = pkgDbStack
       }
 
 plainCradle :: FilePath -> MaybeT IO Cradle
@@ -101,23 +94,4 @@ plainCradle wdir = do
       , cradleRootDir    = wdir
       , cradleTempDir    = error "tmpDir"
       , cradleCabalFile  = Nothing
-      , cradlePkgDbStack = [GlobalDb, UserDb]
       }
-
-getPackageDbStack :: FilePath -- ^ Project Directory (where the
-                                 -- cabal.sandbox.config file would be if it
-                                 -- exists)
-                  -> IO [GhcPkgDb]
-getPackageDbStack cdir =
-    ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir
-
-parseCradle :: FilePath -> IO [GhcPkgDb]
-parseCradle path = do
-    source <- readFile path
-    return $ parseCradle' source
-  where
-    parseCradle' source = map parsePkgDb $ filter (not . null) $ lines source
-
-    parsePkgDb "global" = GlobalDb
-    parsePkgDb "user" = UserDb
-    parsePkgDb s = PackageDb s

Language/Haskell/GhcMod/Find.hs

@@ -15,7 +15,7 @@ module Language.Haskell.GhcMod.Find
   where
 
 import Control.Applicative
-import Control.Monad (when, void, (<=<))
+import Control.Monad (when, void)
 import Data.Function (on)
 import Data.List (groupBy, sort)
 import qualified GHC as G
@@ -46,9 +46,9 @@ data SymbolDb = SymbolDb
   , symbolDbCachePath :: FilePath
   } deriving (Show)
 
-isOutdated :: (GmEnv m, IOish m) => SymbolDb -> m Bool
+isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
 isOutdated db =
-  liftIO . (isOlderThan (symbolDbCachePath db) <=< timedPackageCaches) =<< cradle
+  (liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches
 
 ----------------------------------------------------------------
 
@@ -94,9 +94,8 @@ loadSymbolDb = do
 
 dumpSymbol :: IOish m => FilePath -> GhcModT m String
 dumpSymbol dir = do
-  crdl <- cradle
+  create <- (liftIO . isOlderThan cache) =<< timedPackageCaches
   runGmPkgGhc $ do
-    create <- liftIO $ isOlderThan cache =<< timedPackageCaches crdl
     when create $
       liftIO . writeSymbolCache cache =<< getGlobalSymbolTable
     return $ unlines [cache]

Language/Haskell/GhcMod/GhcPkg.hs

@@ -12,11 +12,14 @@ import Control.Applicative
 import Data.List.Split (splitOn)
 import Data.Maybe
 import Exception (handleIO)
-import Language.Haskell.GhcMod.Types
 import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
 import System.FilePath ((</>))
 import Prelude
 
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.CabalHelper
+
 ghcVersion :: Int
 ghcVersion = read cProjectVersionInt
 
@@ -54,9 +57,10 @@ ghcDbOpt (PackageDb pkgDb)
 
 ----------------------------------------------------------------
 
-getPackageCachePaths :: FilePath -> Cradle -> IO [FilePath]
+getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]
-getPackageCachePaths sysPkgCfg crdl =
+getPackageCachePaths sysPkgCfg = do
-    catMaybes <$> resolvePackageConfig sysPkgCfg `mapM` cradlePkgDbStack crdl
+  pkgDbStack <- getPackageDbStack
+  catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack
 
 -- TODO: use PkgConfRef
 --- Copied from ghc module `Packages' unfortunately it's not exported :/

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -71,6 +71,33 @@ findCabalFile dir = do
    appendDir :: DirPath -> [FileName] -> [FilePath]
    appendDir d fs = (d </>) `map` fs
 
+-- | Get path to sandbox config file
+getSandboxDb :: FilePath
+             -- ^ Path to the cabal package root directory (containing the
+             -- @cabal.sandbox.config@ file)
+             -> IO (Maybe GhcPkgDb)
+getSandboxDb d = do
+  mConf <- traverse readFile =<< mightExist (d </> "cabal.sandbox.config")
+  return $ PackageDb . fixPkgDbVer <$> (extractSandboxDbDir =<< mConf)
+
+ where
+   fixPkgDbVer dir =
+       case takeFileName dir == ghcSandboxPkgDbDir of
+         True -> dir
+         False -> takeDirectory dir </> ghcSandboxPkgDbDir
+
+-- | Extract the sandbox package db directory from the cabal.sandbox.config
+-- file. Exception is thrown if the sandbox config file is broken.
+extractSandboxDbDir :: String -> Maybe FilePath
+extractSandboxDbDir conf = extractValue <$> parse conf
+  where
+    key = "package-db:"
+    keyLen = length key
+
+    parse = listToMaybe . filter (key `isPrefixOf`) . lines
+    extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
+
+
 -- |
 -- >>> isCabalFile "/home/user/.cabal"
 -- False
@@ -117,7 +144,7 @@ findCabalSandboxDir dir = do
              _ -> Nothing
 
  where
-   isSandboxConfig = (=="cabal.sandbox.config")
+   isSandboxConfig = (==sandboConfigFile)
 
 zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
 zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as
@@ -150,34 +177,12 @@ parents dir' =
 
 ----------------------------------------------------------------
 
--- | Get path to sandbox config file
-getSandboxDb :: FilePath -- ^ Path to the cabal package root directory
-                         -- (containing the @cabal.sandbox.config@ file)
-             -> IO (Maybe GhcPkgDb)
-getSandboxDb d = do
-  mConf <- traverse readFile =<< U.mightExist (d </> "cabal.sandbox.config")
-  return $ PackageDb . fixPkgDbVer <$> (extractSandboxDbDir =<< mConf)
-
- where
-   fixPkgDbVer dir =
-       case takeFileName dir == ghcSandboxPkgDbDir of
-         True -> dir
-         False -> takeDirectory dir </> ghcSandboxPkgDbDir
-
--- | Extract the sandbox package db directory from the cabal.sandbox.config file.
---   Exception is thrown if the sandbox config file is broken.
-extractSandboxDbDir :: String -> Maybe FilePath
-extractSandboxDbDir conf = extractValue <$> parse conf
-  where
-    key = "package-db:"
-    keyLen = length key
-
-    parse = listToMaybe . filter (key `isPrefixOf`) . lines
-    extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
-
 setupConfigFile :: Cradle -> FilePath
 setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
 
+sandboConfigFile :: FilePath
+sandboConfigFile = "cabal.sandbox.config"
+
 -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
 setupConfigPath :: FilePath
 setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref
@@ -211,9 +216,12 @@ cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-components"
 mergedPkgOptsCacheFile :: String
 mergedPkgOptsCacheFile = setupConfigPath <.> "ghc-mod.package-options"
 
--- | @findCradleFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@.
+pkgDbStackCacheFile :: String
+pkgDbStackCacheFile = setupConfigPath <.> "ghc-mod.package-db-stack"
+
+-- | @findCustomPackageDbFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@.
 -- If it exists in the given directory it is returned otherwise @findCradleFile@ returns @Nothing@
-findCradleFile :: FilePath -> IO (Maybe FilePath)
+findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath)
-findCradleFile directory = do
+findCustomPackageDbFile directory = do
-    let path = directory </> "ghc-mod.cradle"
+    let path = directory </> "ghc-mod.package-db-stack"
     mightExist path

Language/Haskell/GhcMod/PkgDoc.hs

@@ -4,6 +4,7 @@ import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Utils
+import Language.Haskell.GhcMod.CabalHelper
 
 import Control.Applicative
 import Prelude
@@ -11,17 +12,17 @@ import Prelude
 -- | Obtaining the package name and the doc path of a module.
 pkgDoc :: IOish m => String -> GhcModT m String
 pkgDoc mdl = do
-    c <- cradle
+    pkgDbStack <- getPackageDbStack
-    pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts c) ""
+    pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts pkgDbStack) ""
     if pkg == "" then
         return "\n"
       else do
-        htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg c) ""
+        htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg pkgDbStack) ""
         let ret = pkg ++ " " ++ drop 14 htmlpath
         return ret
   where
-    toModuleOpts c = ["find-module", mdl, "--simple-output"]
+    toModuleOpts dbs = ["find-module", mdl, "--simple-output"]
-                   ++ ghcPkgDbStackOpts (cradlePkgDbStack c)
+                   ++ ghcPkgDbStackOpts dbs
-    toDocDirOpts pkg c = ["field", pkg, "haddock-html"]
+    toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"]
-                       ++ ghcPkgDbStackOpts (cradlePkgDbStack c)
+                       ++ ghcPkgDbStackOpts dbs
     trim = takeWhile (`notElem` " \n")

Language/Haskell/GhcMod/Target.hs

@@ -37,7 +37,7 @@ import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Types
-import Language.Haskell.GhcMod.Utils
+import Language.Haskell.GhcMod.Utils as U
 
 
 import Data.Maybe
@@ -289,13 +289,21 @@ packageGhcOptions = do
       Just _ -> getGhcMergedPkgOptions
       Nothing -> sandboxOpts crdl
 
-sandboxOpts :: Monad m => Cradle -> m [String]
+sandboxOpts :: MonadIO m => Cradle -> m [String]
-sandboxOpts crdl =
+sandboxOpts crdl = do
+    pkgDbStack <- liftIO $ getSandboxPackageDbStack $ cradleRootDir crdl
+    let pkgOpts = ghcDbStackOpts pkgDbStack
     return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"]
   where
-    pkgOpts = ghcDbStackOpts $ cradlePkgDbStack crdl
     (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)
 
+    getSandboxPackageDbStack :: FilePath
+                      -- ^ Project Directory (where the cabal.sandbox.config
+                      -- file would be if it exists)
+                      -> IO [GhcPkgDb]
+    getSandboxPackageDbStack cdir =
+        ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir
+
 resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
     => Maybe [CompilationUnit] -- ^ Updated modules
     -> GmComponent 'GMCRaw (Set ModulePath)

Language/Haskell/GhcMod/Types.hs

@@ -112,14 +112,17 @@ data Cradle = Cradle {
   , cradleTempDir    :: FilePath
   -- | The file name of the found cabal file.
   , cradleCabalFile  :: Maybe FilePath
-  -- | Package database stack
-  , cradlePkgDbStack :: [GhcPkgDb]
   } deriving (Eq, Show)
 
 ----------------------------------------------------------------
 
 -- | GHC package database flags.
-data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
+data GhcPkgDb = GlobalDb
+              | UserDb
+              | PackageDb String
+                deriving (Eq, Show, Generic)
+
+instance Serialize GhcPkgDb
 
 -- | A single GHC command line option.
 type GHCOption = String

Language/Haskell/GhcMod/World.hs

@@ -3,6 +3,7 @@ module Language.Haskell.GhcMod.World where
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Utils
 
 import Control.Applicative
@@ -20,18 +21,19 @@ data World = World {
   , worldSymbolCache   :: Maybe TimedFile
   } deriving (Eq, Show)
 
-timedPackageCaches :: Cradle -> IO [TimedFile]
+timedPackageCaches :: IOish m => GhcModT m [TimedFile]
-timedPackageCaches crdl = do
+timedPackageCaches = do
-    fs <- mapM mightExist . map (</> packageCache)
+    fs <- mapM (liftIO . mightExist) . map (</> packageCache)
-            =<< getPackageCachePaths libdir crdl
+            =<< getPackageCachePaths libdir
-    timeFile `mapM` catMaybes fs
+    (liftIO . timeFile) `mapM` catMaybes fs
 
-getCurrentWorld :: Cradle -> IO World
+getCurrentWorld :: IOish m => GhcModT m World
-getCurrentWorld crdl = do
+getCurrentWorld = do
-    pkgCaches    <- timedPackageCaches crdl
+    crdl <- cradle
-    mCabalFile   <- timeFile `traverse` cradleCabalFile crdl
+    pkgCaches    <- timedPackageCaches
-    mCabalConfig <- timeMaybe (setupConfigFile crdl)
+    mCabalFile   <- liftIO $ timeFile `traverse` cradleCabalFile crdl
-    mSymbolCache <- timeMaybe (symbolCache crdl)
+    mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
+    mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl)
 
     return World {
         worldPackageCaches = pkgCaches
@@ -40,26 +42,9 @@ getCurrentWorld crdl = do
       , worldSymbolCache   = mSymbolCache
       }
 
-didWorldChange :: World -> Cradle -> IO Bool
+didWorldChange :: IOish m => World -> GhcModT m Bool
-didWorldChange world crdl = do
+didWorldChange world = do
-    (world /=) <$> getCurrentWorld crdl
+    (world /=) <$> getCurrentWorld
-
--- * Neither file exists -> should return False:
---   @Nothing < Nothing = False@
---   (since we don't need to @cabal configure@ when no cabal file exists.)
---
--- * Cabal file doesn't exist (unlikely case) -> should return False
---   @Just cc < Nothing = False@
---   TODO: should we delete dist/setup-config?
---
--- * dist/setup-config doesn't exist yet -> should return True:
---   @Nothing < Just cf = True@
---
--- * Both files exist
---   @Just cc < Just cf = cc < cf = cc `olderThan` cf@
-isSetupConfigOutOfDate :: World -> Bool
-isSetupConfigOutOfDate World {..} = do
-  worldCabalConfig < worldCabalFile
 
 isYoungerThanSetupConfig :: FilePath -> World -> IO Bool
 isYoungerThanSetupConfig file World {..} = do

ghc-mod.cabal

@@ -73,6 +73,11 @@ Extra-Source-Files:     ChangeLog
                         test/data/template-haskell/*.hs
                         test/data/target/*.hs
                         test/data/check-missing-warnings/*.hs
+                        test/data/custom-cradle/custom-cradle.cabal
+                        test/data/custom-cradle/ghc-mod.package-db-stack
+                        test/data/custom-cradle/package-db-a/.gitkeep
+                        test/data/custom-cradle/package-db-b/.gitkeep
+                        test/data/custom-cradle/package-db-c/.gitkeep
 
 Library
   Default-Language:     Haskell2010
@@ -123,7 +128,7 @@ Library
                       , bytestring
                       , cereal >= 0.4
                       , containers
-                      , cabal-helper >= 0.3.7.0
+                      , cabal-helper == 0.3.* && >= 0.3.8.0
                       , deepseq
                       , directory
                       , filepath

src/GHCMod.hs

@@ -344,7 +344,7 @@ legacyInteractive :: IOish m => GhcModT m ()
 legacyInteractive = do
     opt <- options
     symdbreq <- liftIO $ newSymDbReq opt
-    world <- liftIO . getCurrentWorld =<< cradle
+    world <- getCurrentWorld
     legacyInteractiveLoop symdbreq world
 
 bug :: String -> IO ()
@@ -371,7 +371,7 @@ legacyInteractiveLoop symdbreq world = do
 
     -- after blocking, we need to see if the world has changed.
 
-    changed <- liftIO . didWorldChange world =<< cradle
+    changed <- didWorldChange world
     when changed $ do
         dropSession
 

test/CabalHelperSpec.hs

@@ -9,7 +9,7 @@ import Language.Haskell.GhcMod.Error
 import Test.Hspec
 import System.Directory
 import System.FilePath
-import System.Process (readProcess)
+import System.Process (readProcess, system)
 
 import Dir
 import TestUtils
@@ -51,8 +51,6 @@ spec = do
             -- comment in cabal-helper
             opts <- map gmcGhcOpts . filter ((/= ChSetupHsName) . gmcName) <$> runD' tdir getComponents
 
-            print opts
-
             if ghcVersion < 706
               then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir])
               else forM_ opts (\o -> o `shouldContain` ["-no-user-package-db","-package-db",cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir])
@@ -73,3 +71,25 @@ spec = do
             let ghcOpts = head opts
                 pkgs = pkgOptions ghcOpts
             pkgs `shouldBe` ["Cabal","base"]
+
+    describe "getCustomPkgDbStack" $ do
+        it "works" $ do
+            let tdir = "test/data/custom-cradle"
+            Just stack <- runD' tdir $ getCustomPkgDbStack
+            stack `shouldBe` [ GlobalDb
+                             , UserDb
+                             , PackageDb "package-db-a"
+                             , PackageDb "package-db-b"
+                             , PackageDb "package-db-c"
+                             ]
+
+    describe "getPackageDbStack'" $ do
+        it "fixes out of sync custom pkg-db stack" $ do
+            withDirectory_ "test/data/custom-cradle" $ do
+                _ <- system "cabal configure"
+                (s, s') <- runD $ do
+                    Just stack <- getCustomPkgDbStack
+                    withCabal $ do
+                        stack' <- getPackageDbStack'
+                        return (stack, stack')
+                s' `shouldBe` s

test/CradleSpec.hs

@@ -9,7 +9,6 @@ import System.FilePath (pathSeparator)
 import Test.Hspec
 
 import Dir
-import TestUtils
 
 clean_ :: IO Cradle -> IO Cradle
 clean_ f = do
@@ -40,10 +39,8 @@ spec = do
                 cradleCurrentDir res `shouldBe` curDir
                 cradleRootDir    res `shouldBe` curDir
                 cradleCabalFile  res `shouldBe` Nothing
-                cradlePkgDbStack res `shouldBe` [GlobalDb,UserDb]
 
         it "finds a cabal file and a sandbox" $ do
-            cwd <- getCurrentDirectory
             withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do
                 res <- relativeCradle dir <$> clean_ findCradle
 
@@ -55,10 +52,6 @@ spec = do
                 cradleCabalFile  res `shouldBe`
                     Just ("test/data/cabal-project/cabalapi.cabal")
 
-                let [GlobalDb, sb] = cradlePkgDbStack res
-                sb `shouldSatisfy`
-                   isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")
-
         it "works even if a sandbox config file is broken" $ do
             withDirectory "test/data/broken-sandbox" $ \dir -> do
                 res <- relativeCradle dir <$> clean_ findCradle
@@ -70,13 +63,3 @@ spec = do
 
                 cradleCabalFile  res `shouldBe`
                   Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
-
-                cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb]
-
-        it "uses the custom cradle file if present" $ do
-            withDirectory "test/data/custom-cradle" $ \dir -> do
-                res <- relativeCradle dir <$> findCradle
-                cradleCurrentDir res `shouldBe` "test" </> "data" </> "custom-cradle"
-                cradleRootDir res    `shouldBe` "test" </> "data" </> "custom-cradle"
-                cradleCabalFile res  `shouldBe` Just ("test" </> "data" </> "custom-cradle" </> "dummy.cabal")
-                cradlePkgDbStack res `shouldBe` [PackageDb "a/packages", GlobalDb, PackageDb "b/packages", UserDb, PackageDb "c/packages"]

test/Main.hs

@@ -30,7 +30,10 @@ main = do
 
   let caches = [ "setup-config"
                , "setup-config.ghc-mod.cabal-helper"
+               , "setup-config.ghc-mod.cabal-components"
                , "setup-config.ghc-mod.resolved-components"
+               , "setup-config.ghc-mod.package-options"
+               , "setup-config.ghc-mod.package-db-stack"
                , "ghc-mod.cache"
                ]
       cachesFindExp :: String

test/data/custom-cradle/custom-cradle.cabal

@@ -0,0 +1,12 @@
+name:                custom-cradle
+version:             0.1.0.0
+homepage:            asd
+license-file:        LICENSE
+author:              asd
+maintainer:          asd
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  build-depends:       base >=4.7 && <4.8
+  default-language:    Haskell2010

test/data/custom-cradle/dummy.cabal

@@ -1 +0,0 @@
-dummy

test/data/custom-cradle/ghc-mod.cradle

@@ -1,5 +0,0 @@
-a/packages
-global
-b/packages
-user
-c/packages

test/data/custom-cradle/ghc-mod.package-db-stack

@@ -0,0 +1,5 @@
+global
+user
+package-db-a
+package-db-b
+package-db-c