{-# LANGUAGE DataKinds #-}

-- | The handlers exposed by the language server.
module Futhark.LSP.Handlers (handlers) where

import Colog.Core (logStringStderr, (<&))
import Control.Lens ((^.))
import Data.Aeson.Types (Value (Array, String))
import Data.IORef
import Data.Proxy (Proxy (..))
import Data.Vector qualified as V
import Futhark.LSP.Compile (tryReCompile, tryTakeStateFromIORef)
import Futhark.LSP.State (State (..))
import Futhark.LSP.Tool (findDefinitionRange, getHoverInfoFromState)
import Language.LSP.Protocol.Lens (HasUri (uri))
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Server (Handlers, LspM, notificationHandler, requestHandler)

onInitializeHandler :: Handlers (LspM ())
onInitializeHandler :: Handlers (LspT () IO)
onInitializeHandler = SMethod 'Method_Initialized
-> Handler (LspT () IO) 'Method_Initialized
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_Initialized
SMethod_Initialized (Handler (LspT () IO) 'Method_Initialized -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_Initialized
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_Initialized
_msg ->
  LogAction (LspT () IO) String
forall (m :: * -> *). MonadIO m => LogAction m String
logStringStderr LogAction (LspT () IO) String -> String -> LspT () IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& String
"Initialized"

onHoverHandler :: IORef State -> Handlers (LspM ())
onHoverHandler :: IORef State -> Handlers (LspT () IO)
onHoverHandler IORef State
state_mvar =
  SMethod 'Method_TextDocumentHover
-> Handler (LspT () IO) 'Method_TextDocumentHover
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
requestHandler SMethod 'Method_TextDocumentHover
SMethod_TextDocumentHover (Handler (LspT () IO) 'Method_TextDocumentHover
 -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_TextDocumentHover
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TRequestMessage 'Method_TextDocumentHover
req Either ResponseError (Hover |? Null) -> LspT () IO ()
responder -> do
    let TRequestMessage Text
_ LspId 'Method_TextDocumentHover
_ SMethod 'Method_TextDocumentHover
_ (HoverParams TextDocumentIdentifier
doc Position
pos Maybe ProgressToken
_workDone) = TRequestMessage 'Method_TextDocumentHover
req
        Position UInt
l UInt
c = Position
pos
        file_path :: Maybe String
file_path = Uri -> Maybe String
uriToFilePath (Uri -> Maybe String) -> Uri -> Maybe String
forall a b. (a -> b) -> a -> b
$ TextDocumentIdentifier
doc TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
uri
    LogAction (LspT () IO) String
forall (m :: * -> *). MonadIO m => LogAction m String
logStringStderr LogAction (LspT () IO) String -> String -> LspT () IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& (String
"Got hover request: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Maybe String, Position) -> String
forall a. Show a => a -> String
show (Maybe String
file_path, Position
pos))
    State
state <- IORef State -> Maybe String -> LspT () IO State
tryTakeStateFromIORef IORef State
state_mvar Maybe String
file_path
    Either ResponseError (Hover |? Null) -> LspT () IO ()
responder (Either ResponseError (Hover |? Null) -> LspT () IO ())
-> Either ResponseError (Hover |? Null) -> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ (Hover |? Null) -> Either ResponseError (Hover |? Null)
forall a b. b -> Either a b
Right ((Hover |? Null) -> Either ResponseError (Hover |? Null))
-> (Hover |? Null) -> Either ResponseError (Hover |? Null)
forall a b. (a -> b) -> a -> b
$ (Hover |? Null)
-> (Hover -> Hover |? Null) -> Maybe Hover -> Hover |? Null
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Null -> Hover |? Null
forall a b. b -> a |? b
InR Null
Null) Hover -> Hover |? Null
forall a b. a -> a |? b
InL (Maybe Hover -> Hover |? Null) -> Maybe Hover -> Hover |? Null
forall a b. (a -> b) -> a -> b
$ State -> Maybe String -> Int -> Int -> Maybe Hover
getHoverInfoFromState State
state Maybe String
file_path (UInt -> Int
forall a. Enum a => a -> Int
fromEnum UInt
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (UInt -> Int
forall a. Enum a => a -> Int
fromEnum UInt
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

onDocumentFocusHandler :: IORef State -> Handlers (LspM ())
onDocumentFocusHandler :: IORef State -> Handlers (LspT () IO)
onDocumentFocusHandler IORef State
state_mvar =
  SMethod ('Method_CustomMethod "custom/onFocusTextDocument")
-> Handler
     (LspT () IO) ('Method_CustomMethod "custom/onFocusTextDocument")
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler (Proxy "custom/onFocusTextDocument"
-> SMethod ('Method_CustomMethod "custom/onFocusTextDocument")
forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @"custom/onFocusTextDocument")) (Handler
   (LspT () IO) ('Method_CustomMethod "custom/onFocusTextDocument")
 -> Handlers (LspT () IO))
-> Handler
     (LspT () IO) ('Method_CustomMethod "custom/onFocusTextDocument")
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage
  ('Method_CustomMethod "custom/onFocusTextDocument")
msg -> do
    LogAction (LspT () IO) String
forall (m :: * -> *). MonadIO m => LogAction m String
logStringStderr LogAction (LspT () IO) String -> String -> LspT () IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& String
"Got custom request: onFocusTextDocument"
    let TNotificationMessage Text
_ SMethod ('Method_CustomMethod "custom/onFocusTextDocument")
_ (Array Array
vector_param) = TNotificationMessage
  ('Method_CustomMethod "custom/onFocusTextDocument")
msg
        String Text
focused_uri = Array -> Value
forall a. Vector a -> a
V.head Array
vector_param -- only one parameter passed from the client
    IORef State -> Maybe String -> LspT () IO ()
tryReCompile IORef State
state_mvar (Uri -> Maybe String
uriToFilePath (Text -> Uri
Uri Text
focused_uri))

goToDefinitionHandler :: IORef State -> Handlers (LspM ())
goToDefinitionHandler :: IORef State -> Handlers (LspT () IO)
goToDefinitionHandler IORef State
state_mvar =
  SMethod 'Method_TextDocumentDefinition
-> Handler (LspT () IO) 'Method_TextDocumentDefinition
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
requestHandler SMethod 'Method_TextDocumentDefinition
SMethod_TextDocumentDefinition (Handler (LspT () IO) 'Method_TextDocumentDefinition
 -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_TextDocumentDefinition
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TRequestMessage 'Method_TextDocumentDefinition
req Either ResponseError (Definition |? ([DefinitionLink] |? Null))
-> LspT () IO ()
responder -> do
    let TRequestMessage Text
_ LspId 'Method_TextDocumentDefinition
_ SMethod 'Method_TextDocumentDefinition
_ (DefinitionParams TextDocumentIdentifier
doc Position
pos Maybe ProgressToken
_workDone Maybe ProgressToken
_partial) = TRequestMessage 'Method_TextDocumentDefinition
req
        Position UInt
l UInt
c = Position
pos
        file_path :: Maybe String
file_path = Uri -> Maybe String
uriToFilePath (Uri -> Maybe String) -> Uri -> Maybe String
forall a b. (a -> b) -> a -> b
$ TextDocumentIdentifier
doc TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
uri
    LogAction (LspT () IO) String
forall (m :: * -> *). MonadIO m => LogAction m String
logStringStderr LogAction (LspT () IO) String -> String -> LspT () IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& (String
"Got goto definition: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Maybe String, Position) -> String
forall a. Show a => a -> String
show (Maybe String
file_path, Position
pos))
    State
state <- IORef State -> Maybe String -> LspT () IO State
tryTakeStateFromIORef IORef State
state_mvar Maybe String
file_path
    case State -> Maybe String -> Int -> Int -> Maybe Location
findDefinitionRange State
state Maybe String
file_path (UInt -> Int
forall a. Enum a => a -> Int
fromEnum UInt
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (UInt -> Int
forall a. Enum a => a -> Int
fromEnum UInt
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) of
      Maybe Location
Nothing -> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
-> LspT () IO ()
responder (Either ResponseError (Definition |? ([DefinitionLink] |? Null))
 -> LspT () IO ())
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
-> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ (Definition |? ([DefinitionLink] |? Null))
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
forall a b. b -> Either a b
Right ((Definition |? ([DefinitionLink] |? Null))
 -> Either ResponseError (Definition |? ([DefinitionLink] |? Null)))
-> (Definition |? ([DefinitionLink] |? Null))
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
forall a b. (a -> b) -> a -> b
$ ([DefinitionLink] |? Null)
-> Definition |? ([DefinitionLink] |? Null)
forall a b. b -> a |? b
InR (([DefinitionLink] |? Null)
 -> Definition |? ([DefinitionLink] |? Null))
-> ([DefinitionLink] |? Null)
-> Definition |? ([DefinitionLink] |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> [DefinitionLink] |? Null
forall a b. b -> a |? b
InR Null
Null
      Just Location
loc -> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
-> LspT () IO ()
responder (Either ResponseError (Definition |? ([DefinitionLink] |? Null))
 -> LspT () IO ())
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
-> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ (Definition |? ([DefinitionLink] |? Null))
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
forall a b. b -> Either a b
Right ((Definition |? ([DefinitionLink] |? Null))
 -> Either ResponseError (Definition |? ([DefinitionLink] |? Null)))
-> (Definition |? ([DefinitionLink] |? Null))
-> Either ResponseError (Definition |? ([DefinitionLink] |? Null))
forall a b. (a -> b) -> a -> b
$ Definition -> Definition |? ([DefinitionLink] |? Null)
forall a b. a -> a |? b
InL (Definition -> Definition |? ([DefinitionLink] |? Null))
-> Definition -> Definition |? ([DefinitionLink] |? Null)
forall a b. (a -> b) -> a -> b
$ (Location |? [Location]) -> Definition
Definition ((Location |? [Location]) -> Definition)
-> (Location |? [Location]) -> Definition
forall a b. (a -> b) -> a -> b
$ Location -> Location |? [Location]
forall a b. a -> a |? b
InL Location
loc

onDocumentSaveHandler :: IORef State -> Handlers (LspM ())
onDocumentSaveHandler :: IORef State -> Handlers (LspT () IO)
onDocumentSaveHandler IORef State
state_mvar =
  SMethod 'Method_TextDocumentDidSave
-> Handler (LspT () IO) 'Method_TextDocumentDidSave
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidSave
SMethod_TextDocumentDidSave (Handler (LspT () IO) 'Method_TextDocumentDidSave
 -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_TextDocumentDidSave
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidSave
msg -> do
    let TNotificationMessage Text
_ SMethod 'Method_TextDocumentDidSave
_ (DidSaveTextDocumentParams TextDocumentIdentifier
doc Maybe Text
_text) = TNotificationMessage 'Method_TextDocumentDidSave
msg
        file_path :: Maybe String
file_path = Uri -> Maybe String
uriToFilePath (Uri -> Maybe String) -> Uri -> Maybe String
forall a b. (a -> b) -> a -> b
$ TextDocumentIdentifier
doc TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
uri
    LogAction (LspT () IO) String
forall (m :: * -> *). MonadIO m => LogAction m String
logStringStderr LogAction (LspT () IO) String -> String -> LspT () IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& (String
"Saved document: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TextDocumentIdentifier -> String
forall a. Show a => a -> String
show TextDocumentIdentifier
doc)
    IORef State -> Maybe String -> LspT () IO ()
tryReCompile IORef State
state_mvar Maybe String
file_path

onDocumentChangeHandler :: IORef State -> Handlers (LspM ())
onDocumentChangeHandler :: IORef State -> Handlers (LspT () IO)
onDocumentChangeHandler IORef State
state_mvar =
  SMethod 'Method_TextDocumentDidChange
-> Handler (LspT () IO) 'Method_TextDocumentDidChange
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidChange
SMethod_TextDocumentDidChange (Handler (LspT () IO) 'Method_TextDocumentDidChange
 -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_TextDocumentDidChange
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidChange
msg -> do
    let TNotificationMessage Text
_ SMethod 'Method_TextDocumentDidChange
_ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier
doc [TextDocumentContentChangeEvent]
_content) = TNotificationMessage 'Method_TextDocumentDidChange
msg
        file_path :: Maybe String
file_path = Uri -> Maybe String
uriToFilePath (Uri -> Maybe String) -> Uri -> Maybe String
forall a b. (a -> b) -> a -> b
$ VersionedTextDocumentIdentifier
doc VersionedTextDocumentIdentifier
-> Getting Uri VersionedTextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri VersionedTextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
Lens' VersionedTextDocumentIdentifier Uri
uri
    IORef State -> Maybe String -> LspT () IO ()
tryReCompile IORef State
state_mvar Maybe String
file_path

onDocumentOpenHandler :: IORef State -> Handlers (LspM ())
onDocumentOpenHandler :: IORef State -> Handlers (LspT () IO)
onDocumentOpenHandler IORef State
state_mvar =
  SMethod 'Method_TextDocumentDidOpen
-> Handler (LspT () IO) 'Method_TextDocumentDidOpen
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidOpen
SMethod_TextDocumentDidOpen (Handler (LspT () IO) 'Method_TextDocumentDidOpen
 -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_TextDocumentDidOpen
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidOpen
msg -> do
    let TNotificationMessage Text
_ SMethod 'Method_TextDocumentDidOpen
_ (DidOpenTextDocumentParams TextDocumentItem
doc) = TNotificationMessage 'Method_TextDocumentDidOpen
msg
        file_path :: Maybe String
file_path = Uri -> Maybe String
uriToFilePath (Uri -> Maybe String) -> Uri -> Maybe String
forall a b. (a -> b) -> a -> b
$ TextDocumentItem
doc TextDocumentItem -> Getting Uri TextDocumentItem Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentItem Uri
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentItem Uri
uri
    LogAction (LspT () IO) String
forall (m :: * -> *). MonadIO m => LogAction m String
logStringStderr LogAction (LspT () IO) String -> String -> LspT () IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& (String
"Opened document: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Uri -> String
forall a. Show a => a -> String
show (TextDocumentItem
doc TextDocumentItem -> Getting Uri TextDocumentItem Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentItem Uri
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentItem Uri
uri))
    IORef State -> Maybe String -> LspT () IO ()
tryReCompile IORef State
state_mvar Maybe String
file_path

onDocumentCloseHandler :: Handlers (LspM ())
onDocumentCloseHandler :: Handlers (LspT () IO)
onDocumentCloseHandler =
  SMethod 'Method_TextDocumentDidClose
-> Handler (LspT () IO) 'Method_TextDocumentDidClose
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_TextDocumentDidClose
SMethod_TextDocumentDidClose (Handler (LspT () IO) 'Method_TextDocumentDidClose
 -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_TextDocumentDidClose
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_TextDocumentDidClose
_msg ->
    LogAction (LspT () IO) String
forall (m :: * -> *). MonadIO m => LogAction m String
logStringStderr LogAction (LspT () IO) String -> String -> LspT () IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& String
"Closed document"

-- Sent by Eglot when first connecting - not sure when else it might
-- be sent.
onWorkspaceDidChangeConfiguration :: IORef State -> Handlers (LspM ())
onWorkspaceDidChangeConfiguration :: IORef State -> Handlers (LspT () IO)
onWorkspaceDidChangeConfiguration IORef State
_state_mvar =
  SMethod 'Method_WorkspaceDidChangeConfiguration
-> Handler (LspT () IO) 'Method_WorkspaceDidChangeConfiguration
-> Handlers (LspT () IO)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Method_WorkspaceDidChangeConfiguration
SMethod_WorkspaceDidChangeConfiguration (Handler (LspT () IO) 'Method_WorkspaceDidChangeConfiguration
 -> Handlers (LspT () IO))
-> Handler (LspT () IO) 'Method_WorkspaceDidChangeConfiguration
-> Handlers (LspT () IO)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage 'Method_WorkspaceDidChangeConfiguration
_ ->
    LogAction (LspT () IO) String
forall (m :: * -> *). MonadIO m => LogAction m String
logStringStderr LogAction (LspT () IO) String -> String -> LspT () IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& String
"WorkspaceDidChangeConfiguration"

-- | Given an 'IORef' tracking the state, produce a set of handlers.
-- When we want to add more features to the language server, this is
-- the thing to change.
handlers :: IORef State -> ClientCapabilities -> Handlers (LspM ())
handlers :: IORef State -> ClientCapabilities -> Handlers (LspT () IO)
handlers IORef State
state_mvar ClientCapabilities
_ =
  [Handlers (LspT () IO)] -> Handlers (LspT () IO)
forall a. Monoid a => [a] -> a
mconcat
    [ Handlers (LspT () IO)
onInitializeHandler,
      IORef State -> Handlers (LspT () IO)
onDocumentOpenHandler IORef State
state_mvar,
      Handlers (LspT () IO)
onDocumentCloseHandler,
      IORef State -> Handlers (LspT () IO)
onDocumentSaveHandler IORef State
state_mvar,
      IORef State -> Handlers (LspT () IO)
onDocumentChangeHandler IORef State
state_mvar,
      IORef State -> Handlers (LspT () IO)
onDocumentFocusHandler IORef State
state_mvar,
      IORef State -> Handlers (LspT () IO)
goToDefinitionHandler IORef State
state_mvar,
      IORef State -> Handlers (LspT () IO)
onHoverHandler IORef State
state_mvar,
      IORef State -> Handlers (LspT () IO)
onWorkspaceDidChangeConfiguration IORef State
state_mvar
    ]