Misc module for ghc-modi.

ghc-mod.cabal

@@ -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

src/GHCModi.hs

@@ -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

src/Misc.hs

@@ -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