ghc-mod/src/Misc.hs

{-# LANGUAGE DeriveDataTypeable, CPP #-}

module Misc (
    GHCModiError(..)
  , Restart(..)
  , 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.Typeable (Typeable)

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

----------------------------------------------------------------

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