Reactor.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
module Haskell.Ide.Engine.Reactor
  ( R
  , runReactor
  , reactorSend
  , reactorSend'
  , makeRequest
  , makeRequests
  , updateDocumentRequest
  , updateDocument
  , cancelRequest
  , asksLspFuncs
  , getClientConfig
  , REnv(..)
  )
where

import           Control.Monad.Reader
import qualified Data.Map                      as Map
import qualified Data.Default
import           Data.Maybe                     ( fromMaybe )
import           Haskell.Ide.Engine.Compat
import           Haskell.Ide.Engine.Config
import           Haskell.Ide.Engine.PluginsIdeMonads
import qualified Haskell.Ide.Engine.Scheduler  as Scheduler
import           Haskell.Ide.Engine.Types
import qualified Language.Haskell.LSP.Core     as Core
import qualified Language.Haskell.LSP.Messages as J
import qualified Language.Haskell.LSP.Types    as J

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

data REnv = REnv
  { scheduler           :: Scheduler.Scheduler R
  , lspFuncs            :: Core.LspFuncs Config
  -- | The process ID of HIE. See 'HasPidCache'
  , reactorPidCache     :: Int
  , diagnosticSources   :: Map.Map DiagnosticTrigger [(PluginId,DiagnosticProviderFunc)]
  , hoverProviders      :: [HoverProvider]
  , symbolProviders     :: [SymbolProvider]
  , formattingProviders :: Map.Map PluginId FormattingProvider
  -- | Ide Plugins that are available
  , idePlugins          :: IdePlugins
  -- TODO: Add code action providers here
  }

-- | The monad used in the reactor
type R = ReaderT REnv IO

instance HasPidCache R where
  getPidCache = asks reactorPidCache

instance Scheduler.HasScheduler REnv R where
  getScheduler = scheduler

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

runReactor
  :: Core.LspFuncs Config
  -> Scheduler.Scheduler R
  -> Map.Map DiagnosticTrigger [(PluginId, DiagnosticProviderFunc)]
  -> [HoverProvider]
  -> [SymbolProvider]
  -> Map.Map PluginId FormattingProvider
  -> IdePlugins
  -> R a
  -> IO a
runReactor lf sc dps hps sps fps plugins f = do
  pid <- getProcessID
  runReaderT f (REnv sc lf pid dps hps sps fps plugins)

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

asksLspFuncs :: MonadReader REnv m => (Core.LspFuncs Config -> a) -> m a
asksLspFuncs f = asks (f . lspFuncs)

-- | Returns the current client configuration. It is not wise to permanently
-- cache the returned value of this function, as clients can at runitime change
-- their configuration.
--
-- If no custom configuration has been set by the client, this function returns
-- our own defaults.
getClientConfig :: (MonadIO m, MonadReader REnv m) => m Config
getClientConfig = do
  lf <- asks lspFuncs
  liftIO $ fromMaybe Data.Default.def <$> Core.config lf

-- ---------------------------------------------------------------------
-- reactor monad functions
-- ---------------------------------------------------------------------

reactorSend :: (MonadIO m, MonadReader REnv m) => J.FromServerMessage -> m ()
reactorSend msg = do
  sf <- asksLspFuncs Core.sendFunc
  liftIO $ sf msg

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

reactorSend'
  :: (MonadIO m, MonadReader REnv m) => (Core.SendFunc -> IO ()) -> m ()
reactorSend' f = do
  sf <- asksLspFuncs Core.sendFunc
  liftIO $ f sf

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

-- | Sends a single request to the scheduler so it can be be processed
-- asynchronously.
makeRequest :: (MonadIO m, MonadReader REnv m) => PluginRequest R -> m ()
makeRequest = Scheduler.makeRequest

-- | Updates the version of a document and then sends the request to be processed
-- asynchronously.
updateDocumentRequest
  :: (MonadIO m, MonadReader REnv m) => Uri -> Int -> PluginRequest R -> m ()
updateDocumentRequest = Scheduler.updateDocumentRequest

updateDocument :: (MonadIO m, MonadReader REnv m) => Uri -> Int -> m ()
updateDocument uri ver = do
  re <- scheduler <$> ask
  liftIO $ Scheduler.updateDocument re uri ver

-- | Marks a s requests as cencelled by its LspId
cancelRequest :: (MonadIO m, MonadReader REnv m) => J.LspId -> m ()
cancelRequest lid =
  liftIO . flip Scheduler.cancelRequest lid =<< asks scheduler

-- | Execute multiple ide requests sequentially
makeRequests
  :: [IdeDeferM (IdeResult a)] -- ^ The requests to make
  -> String
  -> TrackingNumber
  -> J.LspId
  -> ([a] -> R ())          -- ^ Callback with the request inputs and results
  -> R ()
makeRequests = go []
 where
  go acc [] _ _ _ callback = callback acc
  go acc (x : xs) d tn reqId callback =
    let reqCallback result = go (acc ++ [result]) xs d tn reqId callback
    in  makeRequest $ IReq tn d reqId reqCallback x

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