diff --git a/ghc-mod.cabal b/ghc-mod.cabal index e69b81a..b8b8028 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -147,6 +147,8 @@ Executable ghc-modi 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 @@ -154,6 +156,7 @@ Executable ghc-modi , containers , directory , filepath + , process , split , time , ghc diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 3b84bf8..565be8b 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -87,6 +87,7 @@ run opt ref = flip E.catches handlers $ do let rootdir = cradleRootDir cradle0 -- c = cradle0 { cradleCurrentDir = rootdir } TODO: ????? setCurrentDirectory rootdir + prepareAutogen -- Asynchronous db loading starts here. symdbreq <- newSymDbReq opt (res, _) <- runGhcModT opt $ getCurrentWorld >>= loop symdbreq ref @@ -128,6 +129,7 @@ loop symdbreq ref world = do when changed $ do liftIO $ ungetCommand ref cmdArg E.throw Restart + liftIO $ prepareAutogen let (cmd,arg') = break (== ' ') cmdArg arg = dropWhile (== ' ') arg' (ret,ok) <- case cmd of diff --git a/src/Misc.hs b/src/Misc.hs index 0395447..d9c0894 100644 --- a/src/Misc.hs +++ b/src/Misc.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, CPP #-} module Misc ( GHCModiError(..) @@ -14,18 +14,25 @@ module Misc ( , 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) import CoreMonad (liftIO) import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (isPrefixOf) import Data.Time (UTCTime) import Data.Typeable (Typeable) +import System.Directory (getModificationTime, doesDirectoryExist, getDirectoryContents) +import System.Process +import System.IO (openBinaryFile, IOMode(..)) + import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal -import System.Directory (getModificationTime) ---------------------------------------------------------------- @@ -107,3 +114,59 @@ checkDb (SymDbReq ref act) db = do 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 + , create_group = True + , delegate_ctlc = False + } + +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 :: IO () +prepareAutogen = do + prepared <- isAutogenPrepared + unless prepared $ do + hdl <- build + watch 30 hdl