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

import Monad
import Control.Concurrent
import qualified Server.ResponseController as ResponseController
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 <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
  ThreadId
-> ThreadId
-> ThreadId
-> IORef (Maybe (LanguageContextEnv Config))
-> Switchboard
Switchboard
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO ThreadId
forkIO (Env -> IO ()
keepPrintingLog Env
env)
    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)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO () -> IO ThreadId
forkIO (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ServerM IO ()
Agda.start Env
env)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 
  forall a. IORef a -> a -> IO ()
writeIORef (Switchboard -> IORef (Maybe (LanguageContextEnv Config))
sbLanguageContextEnv Switchboard
switchboard) (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)
  forall a. IORef a -> a -> IO ()
writeIORef (Switchboard -> IORef (Maybe (LanguageContextEnv Config))
sbLanguageContextEnv Switchboard
switchboard) forall a. Maybe a
Nothing

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

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

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