module Switchboard (Switchboard, new, setupLanguageContextEnv, destroy) where

import Monad
import Control.Concurrent
import qualified Server.ResponseController as ResponseController
import Control.Monad
import Control.Monad.Reader
import qualified Agda
import qualified Data.Aeson as JSON
import qualified Data.Text.IO as Text
import Language.LSP.Server
import Language.LSP.Types hiding (TextDocumentSyncClientCapabilities (..))
import Data.IORef
import Options (Config)

data Switchboard = Switchboard
  { Switchboard -> ThreadId
sbPrintLog :: ThreadId
  , Switchboard -> ThreadId
sbSendResponse :: ThreadId
  , Switchboard -> ThreadId
sbRunAgda :: ThreadId
  , Switchboard -> IORef (Maybe (LanguageContextEnv Config))
sbLanguageContextEnv :: IORef (Maybe (LanguageContextEnv Config))
  }

-- | All channels go in and out from here
new :: Env -> IO Switchboard
new :: Env -> IO Switchboard
new Env
env = do
  IORef (Maybe (LanguageContextEnv Config))
ctxEnvIORef <- Maybe (LanguageContextEnv Config)
-> IO (IORef (Maybe (LanguageContextEnv Config)))
forall a. a -> IO (IORef a)
newIORef Maybe (LanguageContextEnv Config)
forall a. Maybe a
Nothing
  ThreadId
-> ThreadId
-> ThreadId
-> IORef (Maybe (LanguageContextEnv Config))
-> Switchboard
Switchboard
    (ThreadId
 -> ThreadId
 -> ThreadId
 -> IORef (Maybe (LanguageContextEnv Config))
 -> Switchboard)
-> IO ThreadId
-> IO
     (ThreadId
      -> ThreadId
      -> IORef (Maybe (LanguageContextEnv Config))
      -> Switchboard)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO ThreadId
forkIO (Env -> IO ()
keepPrintingLog Env
env)
    IO
  (ThreadId
   -> ThreadId
   -> IORef (Maybe (LanguageContextEnv Config))
   -> Switchboard)
-> IO ThreadId
-> IO
     (ThreadId
      -> IORef (Maybe (LanguageContextEnv Config)) -> Switchboard)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO () -> IO ThreadId
forkIO (Env -> IORef (Maybe (LanguageContextEnv Config)) -> IO ()
keepSendindResponse Env
env IORef (Maybe (LanguageContextEnv Config))
ctxEnvIORef)
    IO
  (ThreadId
   -> IORef (Maybe (LanguageContextEnv Config)) -> Switchboard)
-> IO ThreadId
-> IO (IORef (Maybe (LanguageContextEnv Config)) -> Switchboard)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO () -> IO ThreadId
forkIO (ReaderT Env IO () -> Env -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Env IO ()
Agda.start Env
env)
    IO (IORef (Maybe (LanguageContextEnv Config)) -> Switchboard)
-> IO (IORef (Maybe (LanguageContextEnv Config))) -> IO Switchboard
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IORef (Maybe (LanguageContextEnv Config))
-> IO (IORef (Maybe (LanguageContextEnv Config)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IORef (Maybe (LanguageContextEnv Config))
ctxEnvIORef

-- | For sending reactions to the client
setupLanguageContextEnv :: Switchboard -> LanguageContextEnv Config -> IO ()
setupLanguageContextEnv :: Switchboard -> LanguageContextEnv Config -> IO ()
setupLanguageContextEnv Switchboard
switchboard LanguageContextEnv Config
ctxEnv = do
  IORef (Maybe (LanguageContextEnv Config))
-> Maybe (LanguageContextEnv Config) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Switchboard -> IORef (Maybe (LanguageContextEnv Config))
sbLanguageContextEnv Switchboard
switchboard) (LanguageContextEnv Config -> Maybe (LanguageContextEnv Config)
forall a. a -> Maybe a
Just LanguageContextEnv Config
ctxEnv)

destroy :: Switchboard -> IO ()
destroy :: Switchboard -> IO ()
destroy Switchboard
switchboard = do
  ThreadId -> IO ()
killThread (Switchboard -> ThreadId
sbPrintLog Switchboard
switchboard)
  ThreadId -> IO ()
killThread (Switchboard -> ThreadId
sbSendResponse Switchboard
switchboard)
  ThreadId -> IO ()
killThread (Switchboard -> ThreadId
sbRunAgda Switchboard
switchboard)
  IORef (Maybe (LanguageContextEnv Config))
-> Maybe (LanguageContextEnv Config) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Switchboard -> IORef (Maybe (LanguageContextEnv Config))
sbLanguageContextEnv Switchboard
switchboard) Maybe (LanguageContextEnv Config)
forall a. Maybe a
Nothing

-- | Keep printing log
-- Consumer of `envLogChan`
keepPrintingLog :: Env -> IO ()
keepPrintingLog :: Env -> IO ()
keepPrintingLog Env
env = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Text
result <- Chan Text -> IO Text
forall a. Chan a -> IO a
readChan (Env -> Chan Text
envLogChan Env
env)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Env -> Bool
envDevMode Env
env) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> IO ()
Text.putStrLn Text
result

-- | Keep sending reactions
-- Consumer of `envResponseChan`
keepSendindResponse :: Env -> IORef (Maybe (LanguageContextEnv Config)) -> IO ()
keepSendindResponse :: Env -> IORef (Maybe (LanguageContextEnv Config)) -> IO ()
keepSendindResponse Env
env IORef (Maybe (LanguageContextEnv Config))
ctxEnvIORef = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Response
response <- Chan Response -> IO Response
forall a. Chan a -> IO a
readChan (Env -> Chan Response
envResponseChan Env
env)

  Maybe (LanguageContextEnv Config)
result <- IORef (Maybe (LanguageContextEnv Config))
-> IO (Maybe (LanguageContextEnv Config))
forall a. IORef a -> IO a
readIORef IORef (Maybe (LanguageContextEnv Config))
ctxEnvIORef
  Maybe (LanguageContextEnv Config)
-> (LanguageContextEnv Config -> IO (LspId 'CustomMethod)) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LanguageContextEnv Config)
result ((LanguageContextEnv Config -> IO (LspId 'CustomMethod)) -> IO ())
-> (LanguageContextEnv Config -> IO (LspId 'CustomMethod)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LanguageContextEnv Config
ctxEnv -> do
    LanguageContextEnv Config
-> LspT Config IO (LspId 'CustomMethod) -> IO (LspId 'CustomMethod)
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv Config
ctxEnv (LspT Config IO (LspId 'CustomMethod) -> IO (LspId 'CustomMethod))
-> LspT Config IO (LspId 'CustomMethod) -> IO (LspId 'CustomMethod)
forall a b. (a -> b) -> a -> b
$ do
      () -> IO ()
callback <- IO (() -> IO ()) -> LspT Config IO (() -> IO ())
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (() -> IO ()) -> LspT Config IO (() -> IO ()))
-> IO (() -> IO ()) -> LspT Config IO (() -> IO ())
forall a b. (a -> b) -> a -> b
$ ResponseController -> IO (() -> IO ())
ResponseController.dispatch (Env -> ResponseController
envResponseController Env
env)

      let value :: Value
value = Response -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Response
response
      SServerMethod 'CustomMethod
-> MessageParams 'CustomMethod
-> (Either ResponseError (ResponseResult 'CustomMethod)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'CustomMethod)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest (Text -> SServerMethod 'CustomMethod
forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"agda") MessageParams 'CustomMethod
Value
value ((Either ResponseError (ResponseResult 'CustomMethod)
  -> LspT Config IO ())
 -> LspT Config IO (LspId 'CustomMethod))
-> (Either ResponseError (ResponseResult 'CustomMethod)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'CustomMethod)
forall a b. (a -> b) -> a -> b
$ \Either ResponseError (ResponseResult 'CustomMethod)
_result -> IO () -> LspT Config IO ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT Config IO ()) -> IO () -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- writeChan (envLogChan env) $ "[Response] >>>> " <> pack (show value)
        () -> IO ()
callback ()