restart a GhcMod session if the cabal file is changed.

This commit is contained in:
Kazu Yamamoto 2014-09-22 14:13:07 +09:00
parent 71bbd1c5d4
commit 6f814a4378
2 changed files with 68 additions and 24 deletions

View File

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

View File

@ -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 ()
loop symdbreq = do
cmdArg <- liftIO getLine
emptyNewUnGetLine :: IO UnGetLine
emptyNewUnGetLine = newIORef Nothing
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
----------------------------------------------------------------