{-# LANGUAGE ExplicitNamespaces #-}

-- | @futhark lsp@
module Futhark.CLI.LSP (main, serverDefinition) where

import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.IORef (newIORef)
import Futhark.LSP.CommandType (CommandType)
import Futhark.LSP.Handlers (handlers)
import Futhark.LSP.State (emptyState)
import Futhark.Util (showText)
import Language.LSP.Protocol.Types
  ( SaveOptions (SaveOptions),
    TextDocumentSyncKind (TextDocumentSyncKind_Incremental),
    TextDocumentSyncOptions (..),
    type (|?) (InR),
  )
import Language.LSP.Server
  ( Options (optExecuteCommandCommands, optTextDocumentSync),
    ServerDefinition
      ( ServerDefinition,
        configSection,
        defaultConfig,
        doInitialize,
        interpretHandler,
        onConfigChange,
        options,
        parseConfig,
        staticHandlers
      ),
    defaultOptions,
    runLspT,
    runServer,
    type (<~>) (Iso),
  )
import System.Exit (ExitCode (ExitFailure), exitSuccess, exitWith)

-- | Run @futhark lsp@
main :: String -> [String] -> IO ()
main :: String -> [String] -> IO ()
main String
_prog [String]
_args = do
  code <-
    ServerDefinition () -> IO Int
forall config. ServerDefinition config -> IO Int
runServer (ServerDefinition () -> IO Int)
-> IO (ServerDefinition ()) -> IO Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (ServerDefinition ())
serverDefinition
  case code of
    Int
0 -> IO ()
forall a. IO a
exitSuccess
    Int
_ -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
code

serverDefinition :: IO (ServerDefinition ())
serverDefinition :: IO (ServerDefinition ())
serverDefinition = do
  state_mvar <- State -> IO (IORef State)
forall a. a -> IO (IORef a)
newIORef State
emptyState
  pure $
    ServerDefinition
      { onConfigChange = const $ pure (),
        configSection = "Futhark",
        parseConfig = const . const $ Right (),
        defaultConfig = (),
        doInitialize = \LanguageContextEnv ()
env TMessage 'Method_Initialize
_req -> Either (TResponseError 'Method_Initialize) (LanguageContextEnv ())
-> IO
     (Either
        (TResponseError 'Method_Initialize) (LanguageContextEnv ()))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (TResponseError 'Method_Initialize) (LanguageContextEnv ())
 -> IO
      (Either
         (TResponseError 'Method_Initialize) (LanguageContextEnv ())))
-> Either
     (TResponseError 'Method_Initialize) (LanguageContextEnv ())
-> IO
     (Either
        (TResponseError 'Method_Initialize) (LanguageContextEnv ()))
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv ()
-> Either
     (TResponseError 'Method_Initialize) (LanguageContextEnv ())
forall a b. b -> Either a b
Right LanguageContextEnv ()
env,
        staticHandlers = handlers state_mvar,
        interpretHandler = \LanguageContextEnv ()
env -> (forall a. LspM () a -> IO a)
-> (forall a. IO a -> LspM () a) -> LspM () <~> IO
forall {k} (m :: k -> *) (n :: k -> *).
(forall (a :: k). m a -> n a)
-> (forall (a :: k). n a -> m a) -> m <~> n
Iso (LanguageContextEnv () -> LspT () IO a -> IO a
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv ()
env) IO a -> LspM () a
forall a. IO a -> LspM () a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO,
        options =
          defaultOptions
            { optTextDocumentSync =
                Just syncOptions,
              optExecuteCommandCommands =
                Just $ map showText [minBound :: CommandType .. maxBound]
            }
      }

syncOptions :: TextDocumentSyncOptions
syncOptions :: TextDocumentSyncOptions
syncOptions =
  TextDocumentSyncOptions
    { _openClose :: Maybe Bool
_openClose = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True,
      _change :: Maybe TextDocumentSyncKind
_change = TextDocumentSyncKind -> Maybe TextDocumentSyncKind
forall a. a -> Maybe a
Just TextDocumentSyncKind
TextDocumentSyncKind_Incremental,
      _willSave :: Maybe Bool
_willSave = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False,
      _willSaveWaitUntil :: Maybe Bool
_willSaveWaitUntil = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False,
      _save :: Maybe (Bool |? SaveOptions)
_save = (Bool |? SaveOptions) -> Maybe (Bool |? SaveOptions)
forall a. a -> Maybe a
Just ((Bool |? SaveOptions) -> Maybe (Bool |? SaveOptions))
-> (Bool |? SaveOptions) -> Maybe (Bool |? SaveOptions)
forall a b. (a -> b) -> a -> b
$ SaveOptions -> Bool |? SaveOptions
forall a b. b -> a |? b
InR (SaveOptions -> Bool |? SaveOptions)
-> SaveOptions -> Bool |? SaveOptions
forall a b. (a -> b) -> a -> b
$ Maybe Bool -> SaveOptions
SaveOptions (Maybe Bool -> SaveOptions) -> Maybe Bool -> SaveOptions
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
    }