Misc module for ghc-modi.
This commit is contained in:
parent
6f814a4378
commit
7382e1bf1d
@ -144,6 +144,7 @@ Executable ghc-modi
|
|||||||
Default-Language: Haskell2010
|
Default-Language: Haskell2010
|
||||||
Main-Is: GHCModi.hs
|
Main-Is: GHCModi.hs
|
||||||
Other-Modules: Paths_ghc_mod
|
Other-Modules: Paths_ghc_mod
|
||||||
|
Misc
|
||||||
Utils
|
Utils
|
||||||
GHC-Options: -Wall -threaded
|
GHC-Options: -Wall -threaded
|
||||||
Default-Extensions: ConstraintKinds, FlexibleContexts
|
Default-Extensions: ConstraintKinds, FlexibleContexts
|
||||||
|
@ -20,44 +20,26 @@ module Main where
|
|||||||
|
|
||||||
import Config (cProjectVersion)
|
import Config (cProjectVersion)
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import Control.Concurrent.Async (Async, async, wait)
|
import Control.Exception (SomeException(..))
|
||||||
import Control.Exception (SomeException(..), Exception)
|
|
||||||
import qualified Control.Exception as E
|
import qualified Control.Exception as E
|
||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
import CoreMonad (liftIO)
|
import CoreMonad (liftIO)
|
||||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
|
||||||
import Data.List (intercalate)
|
import Data.List (intercalate)
|
||||||
import Data.List.Split (splitOn)
|
import Data.List.Split (splitOn)
|
||||||
import Data.Time (UTCTime)
|
|
||||||
import Data.Typeable (Typeable)
|
|
||||||
import Data.Version (showVersion)
|
import Data.Version (showVersion)
|
||||||
import Language.Haskell.GhcMod
|
import Language.Haskell.GhcMod
|
||||||
import Language.Haskell.GhcMod.Internal
|
|
||||||
import Paths_ghc_mod
|
import Paths_ghc_mod
|
||||||
import System.Console.GetOpt
|
import System.Console.GetOpt
|
||||||
import System.Directory (getModificationTime, setCurrentDirectory)
|
import System.Directory (setCurrentDirectory)
|
||||||
import System.Environment (getArgs)
|
import System.Environment (getArgs)
|
||||||
import System.Exit (ExitCode, exitFailure)
|
import System.Exit (ExitCode, exitFailure)
|
||||||
import System.IO (hFlush,stdout)
|
import System.IO (hFlush,stdout)
|
||||||
|
|
||||||
|
import Misc
|
||||||
import Utils
|
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 :: String
|
||||||
progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
|
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
|
-- Running two GHC monad threads disables the handling of
|
||||||
-- C-c since installSignalHandlers is called twice, sigh.
|
-- 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 (\(_ :: Restart) -> run opt ref)
|
||||||
, E.Handler (\(SomeException e) -> bug $ show e) ]
|
, 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 :: String -> IO ()
|
||||||
bug msg = do
|
bug msg = do
|
||||||
putStrLn $ notGood $ "BUG: " ++ msg
|
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 :: IOish m => SymDbReq -> UnGetLine -> World -> GhcModT m ()
|
||||||
loop symdbreq ref world = do
|
loop symdbreq ref world = do
|
||||||
-- blocking
|
-- blocking
|
||||||
cmdArg <- liftIO $ getCommand ref
|
cmdArg <- liftIO $ getCommand ref
|
||||||
-- after blocking, we need to see if the world has changed.
|
-- after blocking, we need to see if the world has changed.
|
||||||
world' <- getCurrentWorld
|
changed <- isWorldChanged world
|
||||||
when (world /= world') $ do
|
when changed $ do
|
||||||
liftIO $ ungetCommand ref cmdArg
|
liftIO $ ungetCommand ref cmdArg
|
||||||
E.throw Restart
|
E.throw Restart
|
||||||
let (cmd,arg') = break (== ' ') cmdArg
|
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 :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool)
|
||||||
findSym sym symdbreq = do
|
findSym sym symdbreq = do
|
||||||
db <- getDb symdbreq >>= checkDb symdbreq
|
db <- getDb symdbreq >>= checkDb symdbreq
|
||||||
|
109
src/Misc.hs
Normal file
109
src/Misc.hs
Normal file
@ -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
Block a user