getConfig runs "cabal configure" first if setup-config is invalid.

Language/Haskell/GhcMod/CabalConfig.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards, CPP #-}
 
 -- | This module facilitates extracting information from Cabal's on-disk
 -- 'LocalBuildInfo' (@dist/setup-config@).
@@ -7,13 +7,16 @@ module Language.Haskell.GhcMod.CabalConfig (
   , cabalConfigDependencies
   , cabalConfigFlags
   , setupConfigFile
+  , World
+  , getCurrentWorld
+  , isWorldChanged
   ) where
 
 import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.GhcPkg
-import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.Read
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils
 
 import qualified Language.Haskell.GhcMod.Cabal16 as C16
 import qualified Language.Haskell.GhcMod.Cabal18 as C18
@@ -24,7 +27,7 @@ import qualified Language.Haskell.GhcMod.Cabal21 as C21
 #endif
 
 import Control.Applicative ((<$>))
-import Control.Monad (void, mplus)
+import Control.Monad (unless, void, mplus)
 #if MIN_VERSION_mtl(2,2,1)
 import Control.Monad.Except ()
 #else
@@ -40,9 +43,17 @@ import Distribution.PackageDescription (FlagAssignment)
 import Distribution.Simple.BuildPaths (defaultDistPref)
 import Distribution.Simple.Configure (localBuildInfoFile)
 import Distribution.Simple.LocalBuildInfo (ComponentName)
+import Data.Traversable (traverse)
 import MonadUtils (liftIO)
+import System.Directory (doesFileExist, getModificationTime)
 import System.FilePath ((</>))
 
+#if __GLASGOW_HASKELL__ <= 704
+import System.Time (ClockTime)
+#else
+import Data.Time (UTCTime)
+#endif
+
 ----------------------------------------------------------------
 
 -- | 'Show'ed cabal 'LocalBuildInfo' string
@@ -54,7 +65,11 @@ type CabalConfig = String
 getConfig :: (IOish m, MonadError GhcModError m)
           => Cradle
           -> m CabalConfig
-getConfig cradle = liftIO (readFile file) `tryFix` \_ ->
+getConfig cradle = do
+    world <- liftIO $ getCurrentWorld cradle
+    let valid = isSetupConfigValid world
+    unless valid configure
+    liftIO (readFile file) `tryFix` \_ ->
         configure `modifyError'` GMECabalConfigure
  where
    file = setupConfigFile cradle
@@ -178,3 +193,57 @@ extractField config field =
     case extractParens <$> find (field `isPrefixOf`) (tails config) of
         Just f -> Right f
         Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config)
+
+----------------------------------------------------------------
+
+#if __GLASGOW_HASKELL__ <= 704
+type ModTime = ClockTime
+#else
+type ModTime = UTCTime
+#endif
+
+data World = World {
+    worldCabalFile :: Maybe FilePath
+  , worldCabalFileModificationTime :: Maybe ModTime
+  , worldPackageCache :: FilePath
+  , worldPackageCacheModificationTime :: ModTime
+  , worldSetupConfig :: FilePath
+  , worldSetupConfigModificationTime :: Maybe ModTime
+  } deriving (Show, Eq)
+
+getCurrentWorld :: Cradle -> IO World
+getCurrentWorld crdl = do
+    cachePath <- getPackageCachePath crdl
+    let mCabalFile = cradleCabalFile crdl
+        pkgCache = cachePath </> packageCache
+        setupFile = setupConfigFile crdl
+    mCabalFileMTime <- getModificationTime `traverse` mCabalFile
+    pkgCacheMTime <- getModificationTime pkgCache
+    exist <- doesFileExist setupFile
+    mSeetupMTime <- if exist then
+                        Just <$> getModificationTime setupFile
+                      else
+                        return Nothing
+    return $ World {
+        worldCabalFile = mCabalFile
+      , worldCabalFileModificationTime = mCabalFileMTime
+      , worldPackageCache = pkgCache
+      , worldPackageCacheModificationTime = pkgCacheMTime
+      , worldSetupConfig = setupFile
+      , worldSetupConfigModificationTime = mSeetupMTime
+      }
+
+isWorldChanged :: World -> Cradle -> IO Bool
+isWorldChanged world crdl = do
+    world' <- getCurrentWorld crdl
+    return (world /= world')
+
+isSetupConfigValid :: World -> Bool
+isSetupConfigValid World{ worldSetupConfigModificationTime = Nothing, ..} = False
+isSetupConfigValid World{ worldSetupConfigModificationTime = Just mt, ..} =
+    cond1 && cond2
+  where
+    cond1 = case worldCabalFileModificationTime of
+        Nothing -> True
+        Just mtime -> mtime <= mt
+    cond2 = worldPackageCacheModificationTime <= mt

Language/Haskell/GhcMod/Find.hs

@@ -135,8 +135,7 @@ ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when
 dumpSymbol :: IOish m => GhcModT m String
 dumpSymbol = do
     crdl <- cradle
-    dflags <- G.getSessionDynFlags
+    dir <- liftIO $ getPackageCachePath crdl
-    dir <- liftIO $ getPackageCachePath crdl dflags
     let cache = dir </> symbolCache
         pkgdb = dir </> packageCache
 

Language/Haskell/GhcMod/GhcPkg.hs

@@ -21,7 +21,6 @@ import Data.Char (isSpace)
 import Data.List (isPrefixOf, intercalate)
 import Data.List.Split (splitOn)
 import Distribution.Package (InstalledPackageId(..))
-import DynFlags (DynFlags(..), systemPackageConfig)
 import Exception (handleIO)
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
@@ -119,17 +118,16 @@ packageConfDir :: String
 packageConfDir = "package.conf.d"
 
 -- fixme: error handling
-getPackageCachePath :: Cradle -> DynFlags -> IO FilePath
+getPackageCachePath :: Cradle -> IO FilePath
-getPackageCachePath crdl df = do
+getPackageCachePath crdl = do
     let u:_ = filter (/= GlobalDb) $ cradlePkgDbStack crdl
-    Just db <- resolvePath df u
+    Just db <- resolvePath u
     return db
 
 --- Copied from ghc module `Packages' unfortunately it's not exported :/
-resolvePath :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath)
+resolvePath :: GhcPkgDb -> IO (Maybe FilePath)
-resolvePath df GlobalDb         = return $ Just (systemPackageConfig df)
+resolvePath (PackageDb name) = return $ Just name
-resolvePath _  (PackageDb name) = return $ Just name
+resolvePath UserDb           = handleIO (\_ -> return Nothing) $ do
-resolvePath _  UserDb           = handleIO (\_ -> return Nothing) $ do
     appdir <- getAppUserDataDirectory "ghc"
     let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)
         pkgconf = dir </> packageConfDir
@@ -137,3 +135,4 @@ resolvePath _  UserDb           = handleIO (\_ -> return Nothing) $ do
     return $ if exist then Just pkgconf else Nothing
   where
     [target_arch,_,target_os] = splitOn "-" cTargetPlatformString
+resolvePath _ = error "GlobalDb cannot be used in resolvePath"

Language/Haskell/GhcMod/Internal.hs

@@ -48,34 +48,21 @@ module Language.Haskell.GhcMod.Internal (
   , runAnyOne
   -- * World
   , World
-  , getWorld
+  , getCurrentWorld
-  , isChanged
+  , isWorldChanged
   ) where
 
 import GHC.Paths (libdir)
-import GHC (getSessionDynFlags)
 
 import Language.Haskell.GhcMod.CabalApi
+import Language.Haskell.GhcMod.CabalConfig
 import Language.Haskell.GhcMod.DynFlags
 import Language.Haskell.GhcMod.GHCChoice
 import Language.Haskell.GhcMod.Logger
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Target
 import Language.Haskell.GhcMod.Types
-import Language.Haskell.GhcMod.World
 
 -- | Obtaining the directory for ghc system libraries.
 ghcLibDir :: FilePath
 ghcLibDir = libdir
-
-getWorld :: IOish m => GhcModT m World
-getWorld = do
-    crdl <- cradle
-    dflags <- getSessionDynFlags
-    liftIO $ getCurrentWorld crdl dflags
-
-isChanged :: IOish m => World -> GhcModT m Bool
-isChanged world = do
-    crdl <- cradle
-    dflags <- getSessionDynFlags
-    liftIO $ isWorldChanged world crdl dflags

Language/Haskell/GhcMod/World.hs

@@ -1,75 +0,0 @@
-{-# LANGUAGE RecordWildCards, CPP #-}
-
-module Language.Haskell.GhcMod.World (
-    World
-  , getCurrentWorld
-  , isWorldChanged
-  , isSetupConfigValid
-  ) where
-
-import Control.Applicative ((<$>))
-import Data.Traversable (traverse)
-import DynFlags (DynFlags(..))
-import Language.Haskell.GhcMod.CabalConfig
-import Language.Haskell.GhcMod.GhcPkg
-import Language.Haskell.GhcMod.Types
-import System.Directory (doesFileExist, getModificationTime)
-import System.FilePath ((</>))
-
-#if __GLASGOW_HASKELL__ <= 704
-import System.Time (ClockTime)
-#else
-import Data.Time (UTCTime)
-#endif
-
-#if __GLASGOW_HASKELL__ <= 704
-type ModTime = ClockTime
-#else
-type ModTime = UTCTime
-#endif
-
-data World = World {
-    worldCabalFile :: Maybe FilePath
-  , worldCabalFileModificationTime :: Maybe ModTime
-  , worldPackageCache :: FilePath
-  , worldPackageCacheModificationTime :: ModTime
-  , worldSetupConfig :: FilePath
-  , worldSetupConfigModificationTime :: Maybe ModTime
-  } deriving (Show, Eq)
-
-getCurrentWorld :: Cradle -> DynFlags -> IO World
-getCurrentWorld crdl dflags = do
-    cachePath <- getPackageCachePath crdl dflags
-    let mCabalFile = cradleCabalFile crdl
-        pkgCache = cachePath </> packageCache
-        setupFile = setupConfigFile crdl
-    mCabalFileMTime <- getModificationTime `traverse` mCabalFile
-    pkgCacheMTime <- getModificationTime pkgCache
-    exist <- doesFileExist setupFile
-    mSeetupMTime <- if exist then
-                        Just <$> getModificationTime setupFile
-                      else
-                        return Nothing
-    return $ World {
-        worldCabalFile = mCabalFile
-      , worldCabalFileModificationTime = mCabalFileMTime
-      , worldPackageCache = pkgCache
-      , worldPackageCacheModificationTime = pkgCacheMTime
-      , worldSetupConfig = setupFile
-      , worldSetupConfigModificationTime = mSeetupMTime
-      }
-
-isWorldChanged :: World -> Cradle -> DynFlags -> IO Bool
-isWorldChanged world crdl dflags = do
-    world' <- getCurrentWorld crdl dflags
-    return (world /= world')
-
-isSetupConfigValid :: World -> Bool
-isSetupConfigValid World{ worldSetupConfigModificationTime = Nothing, ..} = False
-isSetupConfigValid World{ worldSetupConfigModificationTime = Just mt, ..} =
-    cond1 && cond2
-  where
-    cond1 = case worldCabalFileModificationTime of
-        Nothing -> True
-        Just mtime -> mtime <= mt
-    cond2 = worldPackageCacheModificationTime <= mt

ghc-mod.cabal

@@ -94,7 +94,6 @@ Library
                         Language.Haskell.GhcMod.Target
                         Language.Haskell.GhcMod.Types
                         Language.Haskell.GhcMod.Utils
-                        Language.Haskell.GhcMod.World
   Build-Depends:        base >= 4.0 && < 5
                       , containers
                       , deepseq

src/GHCModi.hs

@@ -91,7 +91,10 @@ run opt ref = flip E.catches handlers $ do
     prepareAutogen cradle0
     -- Asynchronous db loading starts here.
     symdbreq <- newSymDbReq opt
-    (res, _) <- runGhcModT opt $ getWorld >>= loop symdbreq ref
+    (res, _) <- runGhcModT opt $ do
+        crdl <- cradle
+        world <- liftIO $ getCurrentWorld crdl
+        loop symdbreq ref world
     case res of
         Right () -> return ()
         Left (GMECabalConfigure msg) -> do
@@ -126,7 +129,8 @@ loop symdbreq ref world = do
     -- blocking
     cmdArg <- liftIO $ getCommand ref
     -- after blocking, we need to see if the world has changed.
-    changed <- isChanged world
+    crdl <- cradle
+    changed <- liftIO $ isWorldChanged world crdl
     when changed $ do
         liftIO $ ungetCommand ref cmdArg
         E.throw Restart