177 lines
4.7 KiB
Haskell
177 lines
4.7 KiB
Haskell
{-# LANGUAGE DeriveDataTypeable, CPP #-}
|
|
|
|
module Misc (
|
|
GHCModiError(..)
|
|
, Restart(..)
|
|
, World
|
|
, getCurrentWorld
|
|
, isWorldChanged
|
|
, 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)
|
|
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
|
|
|
|
----------------------------------------------------------------
|
|
|
|
data GHCModiError = CmdArg [String] deriving (Show, Typeable)
|
|
|
|
instance Exception GHCModiError
|
|
|
|
----------------------------------------------------------------
|
|
|
|
data Restart = Restart deriving (Show, Typeable)
|
|
|
|
instance Exception Restart
|
|
|
|
----------------------------------------------------------------
|
|
|
|
data World = World {
|
|
worldCabalFileModificationTime :: Maybe UTCTime
|
|
} deriving (Show, Eq)
|
|
|
|
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 { worldCabalFileModificationTime = mmt }
|
|
|
|
isWorldChanged :: IOish m => World -> GhcModT m Bool
|
|
isWorldChanged world = do
|
|
world' <- getCurrentWorld
|
|
return (world /= world')
|
|
|
|
----------------------------------------------------------------
|
|
|
|
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 :: IO ()
|
|
prepareAutogen = do
|
|
prepared <- isAutogenPrepared
|
|
unless prepared $ do
|
|
hdl <- build
|
|
watch 30 hdl
|