diff --git a/Language/Haskell/GhcMod/CabalConfig.hs b/Language/Haskell/GhcMod/CabalConfig.hs index 22aae06..8f1474e 100644 --- a/Language/Haskell/GhcMod/CabalConfig.hs +++ b/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,8 +65,12 @@ type CabalConfig = String getConfig :: (IOish m, MonadError GhcModError m) => Cradle -> m CabalConfig -getConfig cradle = liftIO (readFile file) `tryFix` \_ -> - configure `modifyError'` GMECabalConfigure +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 prjDir = cradleRootDir 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 diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 359103b..2fccbed 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/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 dflags + dir <- liftIO $ getPackageCachePath crdl let cache = dir symbolCache pkgdb = dir packageCache diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index 1f94fc5..c0cb2c2 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/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 crdl df = do +getPackageCachePath :: Cradle -> IO FilePath +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 df GlobalDb = return $ Just (systemPackageConfig df) -resolvePath _ (PackageDb name) = return $ Just name -resolvePath _ UserDb = handleIO (\_ -> return Nothing) $ do +resolvePath :: GhcPkgDb -> IO (Maybe FilePath) +resolvePath (PackageDb name) = return $ Just name +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" diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index 27a8ab4..681657c 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -48,34 +48,21 @@ module Language.Haskell.GhcMod.Internal ( , runAnyOne -- * World , World - , getWorld - , isChanged + , getCurrentWorld + , 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 diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs deleted file mode 100644 index 41cdb88..0000000 --- a/Language/Haskell/GhcMod/World.hs +++ /dev/null @@ -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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 695640b..b1dcc0b 100644 --- a/ghc-mod.cabal +++ b/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 diff --git a/src/GHCModi.hs b/src/GHCModi.hs index ae36ca1..ace2526 100644 --- a/src/GHCModi.hs +++ b/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