From 7db266c22d00ea0def7179904d2f314c7768001a Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 23 Sep 2014 17:34:09 +0900 Subject: [PATCH] adding World.hs. --- Language/Haskell/GhcMod/Internal.hs | 18 +++++++ Language/Haskell/GhcMod/World.hs | 75 +++++++++++++++++++++++++++++ ghc-mod.cabal | 3 +- src/GHCModi.hs | 6 +-- src/Misc.hs | 33 +------------ 5 files changed, 99 insertions(+), 36 deletions(-) create mode 100644 Language/Haskell/GhcMod/World.hs diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index e222ad9..27a8ab4 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -46,9 +46,14 @@ module Language.Haskell.GhcMod.Internal ( , (||>) , goNext , runAnyOne + -- * World + , World + , getWorld + , isChanged ) where import GHC.Paths (libdir) +import GHC (getSessionDynFlags) import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.DynFlags @@ -57,7 +62,20 @@ 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 new file mode 100644 index 0000000..41cdb88 --- /dev/null +++ b/Language/Haskell/GhcMod/World.hs @@ -0,0 +1,75 @@ +{-# 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 529033b..695640b 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -86,14 +86,15 @@ Library Language.Haskell.GhcMod.Lang Language.Haskell.GhcMod.Lint Language.Haskell.GhcMod.Logger - Language.Haskell.GhcMod.Monad Language.Haskell.GhcMod.Modules + Language.Haskell.GhcMod.Monad Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.Read Language.Haskell.GhcMod.SrcUtils 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 b9d35d7..ae36ca1 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -28,7 +28,7 @@ import Data.List (intercalate) import Data.List.Split (splitOn) import Data.Version (showVersion) import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal (cradle) +import Language.Haskell.GhcMod.Internal import Paths_ghc_mod import System.Console.GetOpt import System.Directory (setCurrentDirectory) @@ -91,7 +91,7 @@ run opt ref = flip E.catches handlers $ do prepareAutogen cradle0 -- Asynchronous db loading starts here. symdbreq <- newSymDbReq opt - (res, _) <- runGhcModT opt $ getCurrentWorld >>= loop symdbreq ref + (res, _) <- runGhcModT opt $ getWorld >>= loop symdbreq ref case res of Right () -> return () Left (GMECabalConfigure msg) -> do @@ -126,7 +126,7 @@ loop symdbreq ref world = do -- blocking cmdArg <- liftIO $ getCommand ref -- after blocking, we need to see if the world has changed. - changed <- isWorldChanged world + changed <- isChanged world when changed $ do liftIO $ ungetCommand ref cmdArg E.throw Restart diff --git a/src/Misc.hs b/src/Misc.hs index fe0a4d2..21248ad 100644 --- a/src/Misc.hs +++ b/src/Misc.hs @@ -3,9 +3,6 @@ module Misc ( GHCModiError(..) , Restart(..) - , World - , getCurrentWorld - , isWorldChanged , UnGetLine , emptyNewUnGetLine , ungetCommand @@ -26,13 +23,8 @@ import CoreMonad (liftIO) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List (isPrefixOf) import Data.Maybe (isJust) -#if __GLASGOW_HASKELL__ <= 704 -import System.Time (ClockTime) -#else -import Data.Time (UTCTime) -#endif import Data.Typeable (Typeable) -import System.Directory (getModificationTime, doesDirectoryExist, getDirectoryContents) +import System.Directory (doesDirectoryExist, getDirectoryContents) import System.IO (openBinaryFile, IOMode(..)) import System.Process @@ -53,29 +45,6 @@ instance Exception Restart ---------------------------------------------------------------- -data World = World { -#if __GLASGOW_HASKELL__ <= 704 - worldCabalFileModificationTime :: Maybe ClockTime -#else - worldCabalFileModificationTime :: Maybe UTCTime -#endif - } deriving (Show, Eq) - -getCurrentWorld :: IOish m => GhcModT m World -getCurrentWorld = do - crdl <- cradle - mmt <- case cradleCabalFile crdl of - Just file -> liftIO $ Just <$> getModificationTime file - Nothing -> return Nothing - return $ World { worldCabalFileModificationTime = mmt } - -isWorldChanged :: IOish m => World -> GhcModT m Bool -isWorldChanged world = do - world' <- getCurrentWorld - return (world /= world') - ----------------------------------------------------------------- - newtype UnGetLine = UnGetLine (IORef (Maybe String)) emptyNewUnGetLine :: IO UnGetLine