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` \_ ->
+getConfig cradle = do
-     configure `modifyError'` GMECabalConfigure
+    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 =
+   configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
-       withDirectory_ prjDir $ readProcess' "cabal" ["configure"] >> return ()
 
 
+setupConfigFile :: Cradle -> FilePath
+setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
+
 -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
-configPath :: FilePath
+setupConfigPath :: FilePath
-configPath = localBuildInfoFile defaultDistPref
+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.Directory (doesFileExist, getModificationTime)
-import System.FilePath ((</>))
+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])
+data SymbolDb = SymbolDb {
-    deriving (Show)
+    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
+loadSymbolDb = do
-
-readSymbolDb :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString])
-readSymbolDb = 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
+isOlderThan :: FilePath -> FilePath -> IO Bool
-isNewerThan ref file = do
+isOlderThan cache file = do
-    exist <- doesFileExist ref
+    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
+    mCabalFile = cradleCabalFile c
-    cabal = isJust mCradleFile
+    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'
+ghcModExecutable = do
- where
+    dir <- getExecutablePath'
-    getExecutable' :: IO FilePath
+    return $ dir </> "ghc-mod"
-# if __GLASGOW_HASKELL__ >= 706
-    getExecutable' = getExecutablePath
-# else
-    getExecutable' = getProgName
-# endif
-
 #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

elisp/ghc-rewrite.el

@@ -125,8 +125,8 @@
     (ghc-display nil
       (lambda ()
         (insert "Possible completions:\n")
-        (mapc 
+        (mapc
-          (lambda (x) 
+          (lambda (x)
             (let* (; (ins1      (insert "- "))
                    (pos-begin (point))
                    (ins       (insert x))

ghc-mod.cabal

@@ -86,8 +86,8 @@ 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
@@ -148,8 +148,11 @@ Executable ghc-modi
   Default-Language:     Haskell2010
   Main-Is:              GHCModi.hs
   Other-Modules:        Paths_ghc_mod
+                        Misc
                         Utils
   GHC-Options:          -Wall -threaded
+  if os(windows)
+      Cpp-Options:      -DWINDOWS
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
   Build-Depends:        base >= 4.0 && < 5
@@ -157,7 +160,10 @@ Executable ghc-modi
                       , containers
                       , directory
                       , filepath
+                      , old-time
+                      , process
                       , split
+                      , time
                       , ghc
                       , ghc-mod
 

src/GHCModi.hs

@@ -20,36 +20,27 @@ module Main where
 
 import Config (cProjectVersion)
 import Control.Applicative ((<$>))
-import Control.Concurrent.Async (Async, async, wait)
+import Control.Exception (SomeException(..))
-import Control.Exception (SomeException(..), Exception)
 import qualified Control.Exception as E
 import Control.Monad (when)
 import CoreMonad (liftIO)
-import Data.List (find, intercalate)
+import Data.List (intercalate)
 import Data.List.Split (splitOn)
-import Data.Maybe (fromMaybe)
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.Typeable (Typeable)
 import Data.Version (showVersion)
-import qualified GHC as G
 import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Internal
 import Paths_ghc_mod
 import System.Console.GetOpt
 import System.Directory (setCurrentDirectory)
 import System.Environment (getArgs)
-import System.IO (hFlush,stdout)
 import System.Exit (ExitCode, exitFailure)
+import System.IO (hFlush,stdout)
 
+import Misc
 import Utils
 
 ----------------------------------------------------------------
 
-type Logger = IO String
-
-----------------------------------------------------------------
-
 progVersion :: String
 progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
 
@@ -79,13 +70,6 @@ parseArgs spec argv
 
 ----------------------------------------------------------------
 
-data GHCModiError = CmdArg [String]
-                  deriving (Show, Typeable)
-
-instance Exception GHCModiError
-
-----------------------------------------------------------------
-
 -- Running two GHC monad threads disables the handling of
 -- C-c since installSignalHandlers is called twice, sigh.
 
@@ -96,25 +80,33 @@ main = E.handle cmdHandler $
     cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec
     go (_,"help":_) = putStr $ usageInfo usage argspec
     go (_,"version":_) = putStr progVersion
-    go (opt,_) = flip E.catches handlers $ do
+    go (opt,_) = emptyNewUnGetLine >>= run opt
-        cradle0 <- findCradle
-        let rootdir = cradleRootDir cradle0
---            c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
-        setCurrentDirectory rootdir
-        symDb <- async $ runGhcModT opt loadSymbolDb
-        (res, _) <- runGhcModT opt $ loop S.empty symDb
 
-        case res of
+run :: Options -> UnGetLine -> IO ()
-          Right () -> return ()
+run opt ref = flip E.catches handlers $ do
-          Left (GMECabalConfigure msg) -> do
+    cradle0 <- findCradle
-              putStrLn $ notGood $ "cabal configure failed: " ++ show msg
+    let rootdir = cradleRootDir cradle0
-              exitFailure
+--        c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
-          Left e -> bug $ show e
+    setCurrentDirectory rootdir
-      where
+    prepareAutogen cradle0
-        -- this is just in case.
+    -- Asynchronous db loading starts here.
-        -- If an error is caught here, it is a bug of GhcMod library.
+    symdbreq <- newSymDbReq opt
-        handlers = [ E.Handler (\(_ :: ExitCode) -> return ())
+    (res, _) <- runGhcModT opt $ do
-                   , E.Handler (\(SomeException e) -> bug $ show e) ]
+        crdl <- cradle
+        world <- liftIO $ getCurrentWorld crdl
+        loop symdbreq ref world
+    case res of
+        Right () -> return ()
+        Left (GMECabalConfigure msg) -> do
+            putStrLn $ notGood $ "cabal configure failed: " ++ show msg
+            exitFailure
+        Left e -> bug $ show e
+  where
+    -- this is just in case.
+    -- If an error is caught here, it is a bug of GhcMod library.
+    handlers = [ E.Handler (\(_ :: ExitCode) -> return ())
+               , E.Handler (\(_ :: Restart) -> run opt ref)
+               , E.Handler (\(SomeException e) -> bug $ show e) ]
 
 bug :: String -> IO ()
 bug msg = do
@@ -132,91 +124,63 @@ replace needle replacement = intercalate replacement . splitOn needle
 
 ----------------------------------------------------------------
 
-loop :: IOish m => Set FilePath -> SymDbReq -> GhcModT m ()
+loop :: IOish m => SymDbReq -> UnGetLine -> World -> GhcModT m ()
-loop set symDbReq = do
+loop symdbreq ref world = do
-    cmdArg <- liftIO getLine
+    -- blocking
+    cmdArg <- liftIO $ getCommand ref
+    -- after blocking, we need to see if the world has changed.
+    crdl <- cradle
+    changed <- liftIO $ isWorldChanged world crdl
+    when changed $ do
+        liftIO $ ungetCommand ref cmdArg
+        E.throw Restart
+    cradle >>= liftIO . prepareAutogen
     let (cmd,arg') = break (== ' ') cmdArg
         arg = dropWhile (== ' ') arg'
-    (ret,ok,set') <- case cmd of
+    (ret,ok) <- case cmd of
-        "check"  -> checkStx set arg
+        "check"  -> checkStx arg
-        "find"   -> findSym set arg symDbReq
+        "find"   -> findSym arg symdbreq
-        "lint"   -> lintStx set arg
+        "lint"   -> lintStx arg
-        "info"   -> showInfo set arg
+        "info"   -> showInfo arg
-        "type"   -> showType set arg
+        "type"   -> showType arg
-        "split"  -> doSplit set arg
+        "split"  -> doSplit arg
-        "sig"    -> doSig set arg
+        "sig"    -> doSig arg
-        "refine" -> doRefine set arg
+        "refine" -> doRefine arg
-        "auto"   -> doAuto set arg
+        "auto"   -> doAuto arg
-        "boot"   -> bootIt set
+        "boot"   -> bootIt
-        "browse" -> browseIt set arg
+        "browse" -> browseIt arg
-        "quit"   -> return ("quit", False, set)
+        "quit"   -> return ("quit", False)
-        ""       -> return ("quit", False, set)
+        ""       -> return ("quit", False)
-        _        -> return ([], True, set)
+        _        -> return ([], True)
     if ok then do
         liftIO $ putStr ret
         liftIO $ putStrLn "OK"
       else do
         liftIO $ putStrLn $ notGood ret
     liftIO $ hFlush stdout
-    when ok $ loop set' symDbReq
+    when ok $ loop symdbreq ref world
 
 ----------------------------------------------------------------
 
-checkStx :: IOish m
+checkStx :: IOish m => FilePath -> GhcModT m (String, Bool)
-         => Set FilePath
+checkStx file = do
-         -> FilePath
+    eret <- check [file]
-         -> GhcModT m (String, Bool, Set FilePath)
-checkStx set file = do
-    set' <- newFileSet set file
-    let files = S.toList set'
-    eret <- check files
     case eret of
-        Right ret -> return (ret, True, set')
+        Right ret -> return (ret, True)
-        Left ret  -> return (ret, True, set) -- fxime: set
+        Left ret  -> return (ret, True)
-
-newFileSet :: IOish m => Set FilePath -> FilePath -> GhcModT m (Set FilePath)
-newFileSet set file = do
-    let set1
-         | S.member file set = set
-         | otherwise         = S.insert file set
-    mx <- isSameMainFile file <$> getModSummaryForMain
-    return $ case mx of
-        Nothing       -> set1
-        Just mainfile -> S.delete mainfile set1
-
-getModSummaryForMain :: IOish m => GhcModT m (Maybe G.ModSummary)
-getModSummaryForMain = find isMain <$> G.getModuleGraph
-  where
-    isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"
-
-isSameMainFile :: FilePath -> (Maybe G.ModSummary) -> Maybe FilePath
-isSameMainFile _    Nothing  = Nothing
-isSameMainFile file (Just x)
-    | mainfile == file = Nothing
-    | otherwise        = Just mainfile
-  where
-    mmainfile = G.ml_hs_file (G.ms_location x)
-    -- G.ms_hspp_file x is a temporary file with CPP.
-    -- this is a just fake.
-    mainfile = fromMaybe (G.ms_hspp_file x) mmainfile
 
 ----------------------------------------------------------------
 
-type SymDbReq = Async (Either GhcModError SymbolDb, GhcModLog)
+findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool)
-
+findSym sym symdbreq = do
-findSym :: IOish m => Set FilePath -> String -> SymDbReq
+    db <- getDb symdbreq >>= checkDb symdbreq
-        -> GhcModT m (String, Bool, Set FilePath)
-findSym set sym dbReq = do
-    db <- hoistGhcModT =<< liftIO (wait dbReq)
     ret <- lookupSymbol sym db
-    return (ret, True, set)
+    return (ret, True)
 
-lintStx :: IOish m => Set FilePath
+lintStx :: IOish m => FilePath -> GhcModT m (String, Bool)
-        -> FilePath
+lintStx optFile = do
-        -> GhcModT m (String, Bool, Set FilePath)
-lintStx set optFile = do
     ret <- withOptions changeOpt $ lint file
-    return (ret, True, set)
+    return (ret, True)
   where
     (opts,file) = parseLintOptions optFile
     hopts = if opts == "" then [] else read opts
@@ -239,85 +203,56 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
 
 ----------------------------------------------------------------
 
-showInfo :: IOish m
+showInfo :: IOish m => FilePath -> GhcModT m (String, Bool)
-         => Set FilePath
+showInfo fileArg = do
-         -> FilePath
-         -> GhcModT m (String, Bool, Set FilePath)
-showInfo set fileArg = do
     let [file, expr] = splitN 2 fileArg
-    set' <- newFileSet set file
     ret <- info file expr
-    return (ret, True, set')
+    return (ret, True)
 
-showType :: IOish m
+showType :: IOish m => FilePath -> GhcModT m (String, Bool)
-         => Set FilePath
+showType fileArg  = do
-         -> FilePath
-         -> GhcModT m (String, Bool, Set FilePath)
-showType set fileArg  = do
     let [file, line, column] = splitN 3 fileArg
-    set' <- newFileSet set file
     ret <- types file (read line) (read column)
-    return (ret, True, set')
+    return (ret, True)
 
-doSplit :: IOish m
+doSplit :: IOish m => FilePath -> GhcModT m (String, Bool)
-        => Set FilePath
+doSplit fileArg  = do
-        -> FilePath
-        -> GhcModT m (String, Bool, Set FilePath)
-doSplit set fileArg  = do
     let [file, line, column] = splitN 3 fileArg
-    set' <- newFileSet set file
     ret <- splits file (read line) (read column)
-    return (ret, True, set')
+    return (ret, True)
 
-doSig :: IOish m
+doSig :: IOish m => FilePath -> GhcModT m (String, Bool)
-      => Set FilePath
+doSig fileArg  = do
-      -> FilePath
-      -> GhcModT m (String, Bool, Set FilePath)
-doSig set fileArg  = do
     let [file, line, column] = splitN 3 fileArg
-    set' <- newFileSet set file
     ret <- sig file (read line) (read column)
-    return (ret, True, set')
+    return (ret, True)
 
-doRefine :: IOish m
+doRefine :: IOish m => FilePath -> GhcModT m (String, Bool)
-         => Set FilePath
+doRefine fileArg  = do
-         -> FilePath
-         -> GhcModT m (String, Bool, Set FilePath)
-doRefine set fileArg  = do
     let [file, line, column, expr] = splitN 4 fileArg
-    set' <- newFileSet set file
     ret <- refine file (read line) (read column) expr
-    return (ret, True, set')
+    return (ret, True)
 
-doAuto :: IOish m
+doAuto :: IOish m => FilePath -> GhcModT m (String, Bool)
-       => Set FilePath
+doAuto fileArg  = do
-       -> FilePath
-       -> GhcModT m (String, Bool, Set FilePath)
-doAuto set fileArg  = do
     let [file, line, column] = splitN 3 fileArg
-    set' <- newFileSet set file
     ret <- auto file (read line) (read column)
-    return (ret, True, set')
+    return (ret, True)
 
 ----------------------------------------------------------------
 
-bootIt :: IOish m
+bootIt :: IOish m => GhcModT m (String, Bool)
-       => Set FilePath
+bootIt = do
-       -> GhcModT m (String, Bool, Set FilePath)
-bootIt set = do
     ret <- boot
-    return (ret, True, set)
+    return (ret, True)
 
-browseIt :: IOish m
+browseIt :: IOish m => ModuleString -> GhcModT m (String, Bool)
-         => Set FilePath
+browseIt mdl = do
-         -> ModuleString
-         -> GhcModT m (String, Bool, Set FilePath)
-browseIt set mdl = do
     let (det,rest') = break (== ' ') mdl
         rest = dropWhile (== ' ') rest'
     ret <- if det == "-d"
                then withOptions setDetailed (browse rest)
                else browse mdl
-    return (ret, True, set)
+    return (ret, True)
   where
-    setDetailed opt = opt { detailed = True } 
+    setDetailed opt = opt { detailed = True }

src/Misc.hs

@@ -0,0 +1,154 @@
+{-# LANGUAGE DeriveDataTypeable, CPP #-}
+
+module Misc (
+    GHCModiError(..)
+  , Restart(..)
+  , UnGetLine
+  , emptyNewUnGetLine
+  , ungetCommand
+  , getCommand
+  , SymDbReq
+  , newSymDbReq
+  , getDb
+  , checkDb
+  , prepareAutogen
+  ) where
+
+import Control.Applicative ((<$>))
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (Async, async, wait)
+import Control.Exception (Exception)
+import Control.Monad (unless, when)
+import CoreMonad (liftIO)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.List (isPrefixOf)
+import Data.Maybe (isJust)
+import Data.Typeable (Typeable)
+import System.Directory (doesDirectoryExist, getDirectoryContents)
+import System.IO (openBinaryFile, IOMode(..))
+import System.Process
+
+import Language.Haskell.GhcMod
+import Language.Haskell.GhcMod.Internal
+
+----------------------------------------------------------------
+
+data GHCModiError = CmdArg [String] deriving (Show, Typeable)
+
+instance Exception GHCModiError
+
+----------------------------------------------------------------
+
+data Restart = Restart deriving (Show, Typeable)
+
+instance Exception Restart
+
+----------------------------------------------------------------
+
+newtype UnGetLine = UnGetLine (IORef (Maybe String))
+
+emptyNewUnGetLine :: IO UnGetLine
+emptyNewUnGetLine = UnGetLine <$> newIORef Nothing
+
+ungetCommand :: UnGetLine -> String -> IO ()
+ungetCommand (UnGetLine ref) cmd = writeIORef ref (Just cmd)
+
+getCommand :: UnGetLine -> IO String
+getCommand (UnGetLine ref) = do
+    mcmd <- readIORef ref
+    case mcmd of
+        Nothing -> getLine
+        Just cmd -> do
+            writeIORef ref Nothing
+            return cmd
+
+----------------------------------------------------------------
+
+type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)
+data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)
+
+newSymDbReq :: Options -> IO SymDbReq
+newSymDbReq opt = do
+    let act = runGhcModT opt loadSymbolDb
+    req <- async act
+    ref <- newIORef req
+    return $ SymDbReq ref act
+
+getDb :: IOish m => SymDbReq -> GhcModT m SymbolDb
+getDb (SymDbReq ref _) = do
+    req <- liftIO $ readIORef ref
+    -- 'wait' really waits for the asynchronous action at the fist time.
+    -- Then it reads a cached value from the second time.
+    hoistGhcModT =<< liftIO (wait req)
+
+checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb
+checkDb (SymDbReq ref act) db = do
+    outdated <- liftIO $ isOutdated db
+    if outdated then do
+        -- async and wait here is unnecessary because this is essentially
+        -- synchronous. But Async can be used a cache.
+        req <- liftIO $ async act
+        liftIO $ writeIORef ref req
+        hoistGhcModT =<< liftIO (wait req)
+      else
+        return db
+
+----------------------------------------------------------------
+
+build :: IO ProcessHandle
+build = do
+#ifdef WINDOWS
+    nul <- openBinaryFile "NUL" AppendMode
+#else
+    nul <- openBinaryFile "/dev/null" AppendMode
+#endif
+    (_, _, _, hdl) <- createProcess $ pro nul
+    return hdl
+ where
+   pro nul = CreateProcess {
+       cmdspec = RawCommand "cabal" ["build"]
+     , cwd = Nothing
+     , env = Nothing
+     , std_in = Inherit
+     , std_out = UseHandle nul
+     , std_err = UseHandle nul
+     , close_fds = False
+#if __GLASGOW_HASKELL__ >= 702
+      , create_group = True
+#endif
+#if __GLASGOW_HASKELL__ >= 707
+      , delegate_ctlc = False
+#endif
+     }
+
+autogen :: String
+autogen = "dist/build/autogen"
+
+isAutogenPrepared :: IO Bool
+isAutogenPrepared = do
+    exist <- doesDirectoryExist autogen
+    if exist then do
+        files <- filter ("." `isPrefixOf`) <$> getDirectoryContents autogen
+        if length files >= 2 then
+            return True
+          else
+            return False
+      else
+        return False
+
+watch :: Int -> ProcessHandle -> IO ()
+watch 0 _ = return ()
+watch n hdl = do
+    prepared <- isAutogenPrepared
+    if prepared then
+        interruptProcessGroupOf hdl
+      else do
+        threadDelay 100000
+        watch (n - 1) hdl
+
+prepareAutogen :: Cradle -> IO ()
+prepareAutogen crdl = when (isJust $ cradleCabalFile crdl) $ do
+    prepared <- isAutogenPrepared
+    unless prepared $ do
+        hdl <- build
+        watch 30 hdl