Merge remote-tracking branch 'upstream/no-set'

Conflicts:
	Language/Haskell/GhcMod/Find.hs

Language/Haskell/GhcMod.hs

@@ -46,6 +46,7 @@ module Language.Haskell.GhcMod (
   , dumpSymbol
   -- * SymbolDb
   , loadSymbolDb
+  , isOutdated
   ) where
 
 import Language.Haskell.GhcMod.Boot

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@).
@@ -6,13 +6,17 @@ module Language.Haskell.GhcMod.CabalConfig (
     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
@@ -23,7 +27,7 @@ import qualified Language.Haskell.GhcMod.Cabal21 as C21
 #endif
 
 import Control.Applicative ((<$>))
-import Control.Monad (mplus)
+import Control.Monad (unless, void, mplus)
 #if MIN_VERSION_mtl(2,2,1)
 import Control.Monad.Except ()
 #else
@@ -39,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
@@ -53,20 +65,26 @@ type CabalConfig = String
 getConfig :: (IOish m, MonadError GhcModError m)
           => Cradle
           -> m CabalConfig
-getConfig cradle = liftIO (readFile path) `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
-   path = prjDir </> configPath
 
    configure :: (IOish m, MonadError GhcModError m) => m ()
-   configure =
-       withDirectory_ prjDir $ readProcess' "cabal" ["configure"] >> return ()
+   configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
 
 
+setupConfigFile :: Cradle -> FilePath
+setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
+
 -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
-configPath :: FilePath
-configPath = localBuildInfoFile defaultDistPref
+setupConfigPath :: FilePath
+setupConfigPath = localBuildInfoFile defaultDistPref
 
 -- | Get list of 'Package's needed by all components of the current package
 cabalConfigDependencies :: (IOish m, MonadError GhcModError m)
@@ -175,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/Check.hs

@@ -8,9 +8,8 @@ module Language.Haskell.GhcMod.Check (
 import Control.Applicative ((<$>))
 import Language.Haskell.GhcMod.DynFlags
 import qualified Language.Haskell.GhcMod.Gap as Gap
-import qualified GHC as G
 import Language.Haskell.GhcMod.Logger
-import Language.Haskell.GhcMod.Monad (IOish, GhcModT, overrideGhcUserOptions)
+import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
 import Language.Haskell.GhcMod.Target (setTargetFiles)
 
 ----------------------------------------------------------------
@@ -30,10 +29,15 @@ checkSyntax files = either id id <$> check files
 check :: IOish m
       => [FilePath]  -- ^ The target files.
       -> GhcModT m (Either String String)
+{-
 check fileNames = overrideGhcUserOptions $ \ghcOpts -> do
   withLogger (setAllWarningFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do
     _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
     setTargetFiles fileNames
+-}
+check fileNames =
+  withLogger (setAllWarningFlags . setNoMaxRelevantBindings) $
+    setTargetFiles fileNames
 
 ----------------------------------------------------------------
 

Language/Haskell/GhcMod/Find.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, BangPatterns #-}
 
 module Language.Haskell.GhcMod.Find
 #ifndef SPEC
@@ -10,28 +10,26 @@ module Language.Haskell.GhcMod.Find
   , dumpSymbol
   , findSymbol
   , lookupSym
+  , isOutdated
   )
 #endif
   where
 
-import Config (cProjectVersion,cTargetPlatformString)
 import Control.Applicative ((<$>))
 import Control.Monad (when, void)
 import Control.Monad.Error.Class
 import Data.Function (on)
 import Data.List (groupBy, sort)
-import Data.List.Split (splitOn)
 import Data.Maybe (fromMaybe)
-import DynFlags (DynFlags(..), systemPackageConfig)
-import Exception (handleIO)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils
 import Name (getOccString)
-import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime)
-import System.FilePath ((</>))
+import System.Directory (doesFileExist, getModificationTime)
+import System.FilePath ((</>), takeDirectory)
 import System.IO
 
 #ifndef MIN_VERSION_containers
@@ -51,8 +49,14 @@ import qualified Data.Map as M
 -- | Type of function and operation names.
 type Symbol = String
 -- | Database from 'Symbol' to \['ModuleString'\].
-newtype SymbolDb = SymbolDb (Map Symbol [ModuleString])
-    deriving (Show)
+data SymbolDb = SymbolDb {
+    table :: Map Symbol [ModuleString]
+  , packageCachePath :: FilePath
+  , symbolDbCachePath :: FilePath
+  } deriving (Show)
+
+isOutdated :: SymbolDb -> IO Bool
+isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db
 
 ----------------------------------------------------------------
 
@@ -65,12 +69,6 @@ symbolCacheVersion = 0
 symbolCache :: String
 symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache"
 
-packageCache :: String
-packageCache = "package.cache"
-
-packageConfDir :: String
-packageConfDir = "package.conf.d"
-
 ----------------------------------------------------------------
 
 -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
@@ -84,19 +82,21 @@ lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String
 lookupSymbol sym db = convert' $ lookupSym sym db
 
 lookupSym :: Symbol -> SymbolDb -> [ModuleString]
-lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db
+lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db
 
 ---------------------------------------------------------------
 
 -- | Loading a file and creates 'SymbolDb'.
 loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb
-loadSymbolDb = SymbolDb <$> readSymbolDb
-
-readSymbolDb :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString])
-readSymbolDb = do
+loadSymbolDb = do
     ghcMod <- liftIO ghcModExecutable
     file <- chop <$> readProcess' ghcMod ["dumpsym"]
-    M.fromAscList . map conv . lines <$> liftIO (readFile file)
+    !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
+    return $ SymbolDb {
+        table = db
+      , packageCachePath = takeDirectory file </> packageCache
+      , symbolDbCachePath = file
+      }
   where
     conv :: String -> (Symbol,[ModuleString])
     conv = read
@@ -106,24 +106,18 @@ readSymbolDb = do
 ----------------------------------------------------------------
 -- used 'ghc-mod dumpsym'
 
-getSymbolCachePath :: IOish m => GhcModT m FilePath
-getSymbolCachePath = do
-    u:_ <- filter (/= GlobalDb) . cradlePkgDbStack <$> cradle
-    Just db <- (liftIO . flip resolvePackageDb u) =<< G.getSessionDynFlags
-    return db
-  `catchError` const (fail "Couldn't find non-global package database for symbol cache")
-
 -- | Dumping a set of ('Symbol',\['ModuleString'\]) to a file
 --   if the file does not exist or is invalid.
 --   The file name is printed.
 
 dumpSymbol :: IOish m => GhcModT m String
 dumpSymbol = do
-    dir <- getSymbolCachePath
+    crdl <- cradle
+    dir <- liftIO $ getPackageCachePath crdl
     let cache = dir </> symbolCache
         pkgdb = dir </> packageCache
 
-    create <- liftIO $ cache `isNewerThan` pkgdb
+    create <- liftIO $ cache `isOlderThan` pkgdb
     when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable
     return $ unlines [cache]
 
@@ -134,15 +128,15 @@ writeSymbolCache cache sm =
   void . withFile cache WriteMode $ \hdl ->
       mapM (hPrint hdl) sm
 
-isNewerThan :: FilePath -> FilePath -> IO Bool
-isNewerThan ref file = do
-    exist <- doesFileExist ref
+isOlderThan :: FilePath -> FilePath -> IO Bool
+isOlderThan cache file = do
+    exist <- doesFileExist cache
     if not exist then
         return True
       else do
-        tRef <- getModificationTime ref
+        tCache <- getModificationTime cache
         tFile <- getModificationTime file
-        return $ tRef <= tFile -- including equal just in case
+        return $ tCache <= tFile -- including equal just in case
 
 -- | Browsing all functions in all system/user modules.
 getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]
@@ -171,16 +165,3 @@ collectModules :: [(Symbol,ModuleString)]
 collectModules = map tieup . groupBy ((==) `on` fst) . sort
   where
     tieup x = (head (map fst x), map snd x)
-
---- Copied from ghc module `Packages' unfortunately it's not exported :/
-resolvePackageDb :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath)
-resolvePackageDb df GlobalDb         = return $ Just (systemPackageConfig df)
-resolvePackageDb _  (PackageDb name) = return $ Just name
-resolvePackageDb _  UserDb           = handleIO (\_ -> return Nothing) $ do
-    appdir <- getAppUserDataDirectory "ghc"
-    let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)
-        pkgconf = dir </> packageConfDir
-    exist <- doesDirectoryExist pkgconf
-    return $ if exist then Just pkgconf else Nothing
-  where
-    [target_arch,_,target_os] = splitOn "-" cTargetPlatformString

Language/Haskell/GhcMod/GhcPkg.hs

@@ -8,9 +8,12 @@ module Language.Haskell.GhcMod.GhcPkg (
   , fromInstalledPackageId'
   , getSandboxDb
   , getPackageDbStack
+  , getPackageCachePath
+  , packageCache
+  , packageConfDir
   ) where
 
-import Config (cProjectVersionInt)
+import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
 import Control.Applicative ((<$>))
 import Control.Exception (SomeException(..))
 import qualified Control.Exception as E
@@ -18,8 +21,10 @@ import Data.Char (isSpace)
 import Data.List (isPrefixOf, intercalate)
 import Data.List.Split (splitOn)
 import Distribution.Package (InstalledPackageId(..))
+import Exception (handleIO)
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
+import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
 import System.FilePath ((</>))
 
 ghcVersion :: Int
@@ -46,6 +51,8 @@ getSandboxDbDir sconf = do
     parse = head . filter (key `isPrefixOf`) . lines
     extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
 
+----------------------------------------------------------------
+
 getPackageDbStack :: FilePath -- ^ Project Directory (where the
                                  -- cabal.sandbox.config file would be if it
                                  -- exists)
@@ -54,6 +61,8 @@ getPackageDbStack cdir =
     (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db])
       `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb]
 
+----------------------------------------------------------------
+
 fromInstalledPackageId' :: InstalledPackageId -> Maybe Package
 fromInstalledPackageId' pid = let
     InstalledPackageId pkg = pid
@@ -68,6 +77,8 @@ fromInstalledPackageId pid =
       Nothing -> error $
         "fromInstalledPackageId: `"++show pid++"' is not a valid package-id"
 
+----------------------------------------------------------------
+
 -- | Get options needed to add a list of package dbs to ghc-pkg's db stack
 ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
                   -> [String]
@@ -78,6 +89,8 @@ ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
                -> [String]
 ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs
 
+----------------------------------------------------------------
+
 ghcPkgDbOpt :: GhcPkgDb -> [String]
 ghcPkgDbOpt GlobalDb = ["--global"]
 ghcPkgDbOpt UserDb   = ["--user"]
@@ -95,3 +108,31 @@ ghcDbOpt UserDb
 ghcDbOpt (PackageDb pkgDb)
   | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]
   | otherwise        = ["-no-user-package-db",   "-package-db",   pkgDb]
+
+----------------------------------------------------------------
+
+packageCache :: String
+packageCache = "package.cache"
+
+packageConfDir :: String
+packageConfDir = "package.conf.d"
+
+-- fixme: error handling
+getPackageCachePath :: Cradle -> IO FilePath
+getPackageCachePath crdl = do
+    let u:_ = filter (/= GlobalDb) $ cradlePkgDbStack crdl
+    Just db <- resolvePath u
+    return db
+
+--- Copied from ghc module `Packages' unfortunately it's not exported :/
+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
+    exist <- doesDirectoryExist pkgconf
+    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

@@ -49,11 +49,16 @@ module Language.Haskell.GhcMod.Internal (
   , (||>)
   , goNext
   , runAnyOne
+  -- * World
+  , World
+  , getCurrentWorld
+  , isWorldChanged
   ) where
 
 import GHC.Paths (libdir)
 
 import Language.Haskell.GhcMod.CabalApi
+import Language.Haskell.GhcMod.CabalConfig
 import Language.Haskell.GhcMod.DynFlags
 import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.GHCChoice

Language/Haskell/GhcMod/Monad.hs

@@ -200,11 +200,11 @@ initializeFlagsWithCradle opt c
   | cabal     = withCabal
   | otherwise = withSandbox
   where
-    mCradleFile = cradleCabalFile c
-    cabal = isJust mCradleFile
+    mCabalFile = cradleCabalFile c
+    cabal = isJust mCabalFile
     ghcopts = ghcUserOptions opt
     withCabal = do
-        pkgDesc <- parseCabalFile c $ fromJust mCradleFile
+        pkgDesc <- parseCabalFile c $ fromJust mCabalFile
         compOpts <- getCompilerOptions ghcopts c pkgDesc
         initSession CabalPkg opt compOpts
     withSandbox = initSession SingleFile opt compOpts

Language/Haskell/GhcMod/Utils.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE CPP #-}
 module Language.Haskell.GhcMod.Utils where
 
-
+import Control.Applicative ((<$>))
 import Language.Haskell.GhcMod.Error
 import MonadUtils (MonadIO, liftIO)
 import System.Directory (getCurrentDirectory, setCurrentDirectory)
@@ -9,6 +9,7 @@ import System.Exit (ExitCode(..))
 import System.Process (readProcessWithExitCode)
 #ifndef SPEC
 import System.Environment
+import System.FilePath ((</>), takeDirectory)
 #endif
 
 -- dropWhileEnd is not provided prior to base 4.5.0.0.
@@ -51,15 +52,18 @@ withDirectory_ dir action =
 -- this is a guess but >=7.6 uses 'getExecutablePath'.
 ghcModExecutable :: IO FilePath
 #ifndef SPEC
-ghcModExecutable = getExecutable'
- where
-    getExecutable' :: IO FilePath
-# if __GLASGOW_HASKELL__ >= 706
-    getExecutable' = getExecutablePath
-# else
-    getExecutable' = getProgName
-# endif
-
+ghcModExecutable = do
+    dir <- getExecutablePath'
+    return $ dir </> "ghc-mod"
 #else
-ghcModExecutable = return "dist/build/ghc-mod/ghc-mod"
+ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when
+                                              -- compiling spec
+                      return "dist/build/ghc-mod/ghc-mod"
 #endif
+ where
+    getExecutablePath' :: IO FilePath
+# if __GLASGOW_HASKELL__ >= 706
+    getExecutablePath' = takeDirectory <$> getExecutablePath
+# else
+    getExecutablePath' = return ""
+# endif