Misc module for ghc-modi.
This commit is contained in:
Kazu Yamamoto
parent
6f814a4378
commit
7382e1bf1d
|
|
@ -144,6 +144,7 @@ Executable ghc-modi
|
|||
Default-Language: Haskell2010
|
||||
Main-Is: GHCModi.hs
|
||||
Other-Modules: Paths_ghc_mod
|
||||
Misc
|
||||
Utils
|
||||
GHC-Options: -Wall -threaded
|
||||
Default-Extensions: ConstraintKinds, FlexibleContexts
|
||||
|
|
|
|||
|
|
@ -20,44 +20,26 @@ module Main where
|
|||
|
||||
import Config (cProjectVersion)
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Concurrent.Async (Async, async, wait)
|
||||
import Control.Exception (SomeException(..), Exception)
|
||||
import Control.Exception (SomeException(..))
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad (when)
|
||||
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 (getModificationTime, setCurrentDirectory)
|
||||
import System.Directory (setCurrentDirectory)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (ExitCode, exitFailure)
|
||||
import System.IO (hFlush,stdout)
|
||||
|
||||
import Misc
|
||||
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
|
||||
progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
|
||||
|
||||
|
|
@ -87,13 +69,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.
|
||||
|
||||
|
|
@ -128,14 +103,6 @@ run opt ref = flip E.catches handlers $ do
|
|||
, 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
|
||||
|
|
@ -152,28 +119,13 @@ replace needle replacement = intercalate replacement . splitOn needle
|
|||
|
||||
----------------------------------------------------------------
|
||||
|
||||
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
|
||||
changed <- isWorldChanged world
|
||||
when changed $ do
|
||||
liftIO $ ungetCommand ref cmdArg
|
||||
E.throw Restart
|
||||
let (cmd,arg') = break (== ' ') cmdArg
|
||||
|
|
@ -212,35 +164,6 @@ checkStx file = do
|
|||
|
||||
----------------------------------------------------------------
|
||||
|
||||
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
|
||||
|
||||
findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool)
|
||||
findSym sym symdbreq = do
|
||||
db <- getDb symdbreq >>= checkDb symdbreq
|
||||
|
|
|
|||
|
|
@ -0,0 +1,109 @@
|
|||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
|
||||
module Misc (
|
||||
GHCModiError(..)
|
||||
, Restart(..)
|
||||
, World
|
||||
, getCurrentWorld
|
||||
, isWorldChanged
|
||||
, UnGetLine
|
||||
, emptyNewUnGetLine
|
||||
, ungetCommand
|
||||
, getCommand
|
||||
, SymDbReq
|
||||
, newSymDbReq
|
||||
, getDb
|
||||
, checkDb
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Concurrent.Async (Async, async, wait)
|
||||
import Control.Exception (Exception)
|
||||
import CoreMonad (liftIO)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Typeable (Typeable)
|
||||
import Language.Haskell.GhcMod
|
||||
import Language.Haskell.GhcMod.Internal
|
||||
import System.Directory (getModificationTime)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
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
|
||||
Loading…
Reference in New Issue