restart a GhcMod session if the cabal file is changed.

ghc-mod.cabal

@@ -154,6 +154,7 @@ Executable ghc-modi
                       , directory
                       , filepath
                       , split
+                      , time
                       , ghc
                       , ghc-mod
 

src/GHCModi.hs

@@ -28,13 +28,14 @@ import CoreMonad (liftIO)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.List (intercalate)
 import Data.List.Split (splitOn)
+import Data.Time (UTCTime)
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
 import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Internal
 import Paths_ghc_mod
 import System.Console.GetOpt
-import System.Directory (setCurrentDirectory)
+import System.Directory (getModificationTime, setCurrentDirectory)
 import System.Environment (getArgs)
 import System.Exit (ExitCode, exitFailure)
 import System.IO (hFlush,stdout)
@@ -45,6 +46,16 @@ import Utils
 
 type Logger = IO String
 
+data World = World {
+    worldCabalFileModificationTime :: Maybe UTCTime
+  } deriving (Show, Eq)
+
+type UnGetLine = IORef (Maybe String)
+
+data Restart = Restart deriving (Show, Typeable)
+
+instance Exception Restart
+
 ----------------------------------------------------------------
 
 progVersion :: String
@@ -93,15 +104,17 @@ 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
+
+run :: Options -> UnGetLine -> IO ()
+run opt ref = flip E.catches handlers $ do
     cradle0 <- findCradle
     let rootdir = cradleRootDir cradle0
 --        c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
     setCurrentDirectory rootdir
     -- Asynchronous db loading starts here.
     symdbreq <- newSymDbReq opt
-        (res, _) <- runGhcModT opt $ loop symdbreq
+    (res, _) <- runGhcModT opt $ getCurrentWorld >>= loop symdbreq ref
-
     case res of
         Right () -> return ()
         Left (GMECabalConfigure msg) -> do
@@ -112,8 +125,17 @@ main = E.handle cmdHandler $
     -- 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) ]
 
+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 mmt
+
 bug :: String -> IO ()
 bug msg = do
   putStrLn $ notGood $ "BUG: " ++ msg
@@ -130,9 +152,30 @@ replace needle replacement = intercalate replacement . splitOn needle
 
 ----------------------------------------------------------------
 
-loop :: IOish m => SymDbReq -> GhcModT m ()
+emptyNewUnGetLine :: IO UnGetLine
-loop symdbreq = do
+emptyNewUnGetLine = newIORef Nothing
-    cmdArg <- liftIO getLine
+
+ungetCommand :: IORef (Maybe a) -> a -> IO ()
+ungetCommand ref cmd = writeIORef ref (Just cmd)
+
+getCommand :: UnGetLine -> IO String
+getCommand ref = do
+    mcmd <- readIORef ref
+    case mcmd of
+        Nothing -> getLine
+        Just cmd -> do
+            writeIORef ref Nothing
+            return cmd
+
+loop :: IOish m => SymDbReq -> UnGetLine -> World -> GhcModT m ()
+loop symdbreq ref world = do
+    -- blocking
+    cmdArg <- liftIO $ getCommand ref
+    -- after blocking, we need to see if the world has changed.
+    world' <- getCurrentWorld
+    when (world /= world') $ do
+        liftIO $ ungetCommand ref cmdArg
+        E.throw Restart
     let (cmd,arg') = break (== ' ') cmdArg
         arg = dropWhile (== ' ') arg'
     (ret,ok) <- case cmd of
@@ -156,7 +199,7 @@ loop symdbreq = do
       else do
         liftIO $ putStrLn $ notGood ret
     liftIO $ hFlush stdout
-    when ok $ loop symdbreq
+    when ok $ loop symdbreq ref world
 
 ----------------------------------------------------------------