{-# LANGUAGE OverloadedStrings #-}

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

import Control.Lens ((^.))
import Data.Aeson.Types (Value (Array, String))
import Data.IORef
import qualified Data.Vector as V
import Futhark.LSP.Compile (tryReCompile, tryTakeStateFromIORef)
import Futhark.LSP.State (State (..))
import Futhark.LSP.Tool (findDefinitionRange, getHoverInfoFromState)
import Futhark.Util (debug)
import Language.LSP.Server (Handlers, LspM, notificationHandler, requestHandler)
import Language.LSP.Types
import Language.LSP.Types.Lens (HasUri (uri))

-- | 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 -> Handlers (LspM ())
handlers :: IORef State -> Handlers (LspM ())
handlers IORef State
state_mvar =
  [Handlers (LspM ())] -> Handlers (LspM ())
forall a. Monoid a => [a] -> a
mconcat
    [ Handlers (LspM ())
onInitializeHandler,
      IORef State -> Handlers (LspM ())
onDocumentOpenHandler IORef State
state_mvar,
      Handlers (LspM ())
onDocumentCloseHandler,
      IORef State -> Handlers (LspM ())
onDocumentSaveHandler IORef State
state_mvar,
      IORef State -> Handlers (LspM ())
onDocumentChangeHandler IORef State
state_mvar,
      IORef State -> Handlers (LspM ())
onDocumentFocusHandler IORef State
state_mvar,
      IORef State -> Handlers (LspM ())
goToDefinitionHandler IORef State
state_mvar,
      IORef State -> Handlers (LspM ())
onHoverHandler IORef State
state_mvar
    ]

onInitializeHandler :: Handlers (LspM ())
onInitializeHandler :: Handlers (LspM ())
onInitializeHandler = SMethod 'Initialized
-> Handler (LspM ()) 'Initialized -> Handlers (LspM ())
forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'Initialized
SInitialized (Handler (LspM ()) 'Initialized -> Handlers (LspM ()))
-> Handler (LspM ()) 'Initialized -> Handlers (LspM ())
forall a b. (a -> b) -> a -> b
$ \NotificationMessage 'Initialized
_msg -> String -> LspT () IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Initialized"

onHoverHandler :: IORef State -> Handlers (LspM ())
onHoverHandler :: IORef State -> Handlers (LspM ())
onHoverHandler IORef State
state_mvar = SMethod 'TextDocumentHover
-> Handler (LspM ()) 'TextDocumentHover -> Handlers (LspM ())
forall (m :: Method 'FromClient 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
requestHandler SMethod 'TextDocumentHover
STextDocumentHover (Handler (LspM ()) 'TextDocumentHover -> Handlers (LspM ()))
-> Handler (LspM ()) 'TextDocumentHover -> Handlers (LspM ())
forall a b. (a -> b) -> a -> b
$ \RequestMessage 'TextDocumentHover
req Either ResponseError (Maybe Hover) -> LspT () IO ()
responder -> do
  let RequestMessage Text
_ LspId 'TextDocumentHover
_ SMethod 'TextDocumentHover
_ (HoverParams doc pos _workDone) = RequestMessage '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
uri
  String -> LspT () IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> LspT () IO ()) -> String -> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ 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 (Maybe Hover) -> LspT () IO ()
responder (Either ResponseError (Maybe Hover) -> LspT () IO ())
-> Either ResponseError (Maybe Hover) -> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Hover -> Either ResponseError (Maybe Hover)
forall a b. b -> Either a b
Right (Maybe Hover -> Either ResponseError (Maybe Hover))
-> Maybe Hover -> Either ResponseError (Maybe Hover)
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 (LspM ())
onDocumentFocusHandler IORef State
state_mvar = SMethod 'CustomMethod
-> Handler (LspM ()) 'CustomMethod -> Handlers (LspM ())
forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler (Text -> SMethod 'CustomMethod
forall (f :: From) (t :: MethodType). Text -> SMethod 'CustomMethod
SCustomMethod Text
"custom/onFocusTextDocument") (Handler (LspM ()) 'CustomMethod -> Handlers (LspM ()))
-> Handler (LspM ()) 'CustomMethod -> Handlers (LspM ())
forall a b. (a -> b) -> a -> b
$ \NotificationMessage 'CustomMethod
msg -> do
  String -> LspT () IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Got custom request: onFocusTextDocument"
  let NotificationMessage Text
_ SMethod 'CustomMethod
_ (Array vector_param) = NotificationMessage 'CustomMethod
msg
      String Text
focused_uri = Vector Value -> Value
forall a. Vector a -> a
V.head Vector Value
vector_param -- only one parameter passed from the client
  String -> LspT () IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> LspT () IO ()) -> String -> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
focused_uri
  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 (LspM ())
goToDefinitionHandler IORef State
state_mvar = SMethod 'TextDocumentDefinition
-> Handler (LspM ()) 'TextDocumentDefinition -> Handlers (LspM ())
forall (m :: Method 'FromClient 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
requestHandler SMethod 'TextDocumentDefinition
STextDocumentDefinition (Handler (LspM ()) 'TextDocumentDefinition -> Handlers (LspM ()))
-> Handler (LspM ()) 'TextDocumentDefinition -> Handlers (LspM ())
forall a b. (a -> b) -> a -> b
$ \RequestMessage 'TextDocumentDefinition
req Either
  ResponseError (Location |? (List Location |? List LocationLink))
-> LspT () IO ()
responder -> do
  let RequestMessage Text
_ LspId 'TextDocumentDefinition
_ SMethod 'TextDocumentDefinition
_ (DefinitionParams doc pos _workDone _partial) = RequestMessage '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
uri
  String -> LspT () IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> LspT () IO ()) -> String -> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ 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 (Location |? (List Location |? List LocationLink))
-> LspT () IO ()
responder (Either
   ResponseError (Location |? (List Location |? List LocationLink))
 -> LspT () IO ())
-> Either
     ResponseError (Location |? (List Location |? List LocationLink))
-> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ (Location |? (List Location |? List LocationLink))
-> Either
     ResponseError (Location |? (List Location |? List LocationLink))
forall a b. b -> Either a b
Right ((Location |? (List Location |? List LocationLink))
 -> Either
      ResponseError (Location |? (List Location |? List LocationLink)))
-> (Location |? (List Location |? List LocationLink))
-> Either
     ResponseError (Location |? (List Location |? List LocationLink))
forall a b. (a -> b) -> a -> b
$ (List Location |? List LocationLink)
-> Location |? (List Location |? List LocationLink)
forall a b. b -> a |? b
InR ((List Location |? List LocationLink)
 -> Location |? (List Location |? List LocationLink))
-> (List Location |? List LocationLink)
-> Location |? (List Location |? List LocationLink)
forall a b. (a -> b) -> a -> b
$ List Location -> List Location |? List LocationLink
forall a b. a -> a |? b
InL (List Location -> List Location |? List LocationLink)
-> List Location -> List Location |? List LocationLink
forall a b. (a -> b) -> a -> b
$ [Location] -> List Location
forall a. [a] -> List a
List []
    Just Location
loc -> do
      String -> LspT () IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> LspT () IO ()) -> String -> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ Location -> String
forall a. Show a => a -> String
show Location
loc
      Either
  ResponseError (Location |? (List Location |? List LocationLink))
-> LspT () IO ()
responder (Either
   ResponseError (Location |? (List Location |? List LocationLink))
 -> LspT () IO ())
-> Either
     ResponseError (Location |? (List Location |? List LocationLink))
-> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ (Location |? (List Location |? List LocationLink))
-> Either
     ResponseError (Location |? (List Location |? List LocationLink))
forall a b. b -> Either a b
Right ((Location |? (List Location |? List LocationLink))
 -> Either
      ResponseError (Location |? (List Location |? List LocationLink)))
-> (Location |? (List Location |? List LocationLink))
-> Either
     ResponseError (Location |? (List Location |? List LocationLink))
forall a b. (a -> b) -> a -> b
$ Location -> Location |? (List Location |? List LocationLink)
forall a b. a -> a |? b
InL Location
loc

onDocumentSaveHandler :: IORef State -> Handlers (LspM ())
onDocumentSaveHandler :: IORef State -> Handlers (LspM ())
onDocumentSaveHandler IORef State
state_mvar = SMethod 'TextDocumentDidSave
-> Handler (LspM ()) 'TextDocumentDidSave -> Handlers (LspM ())
forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'TextDocumentDidSave
STextDocumentDidSave (Handler (LspM ()) 'TextDocumentDidSave -> Handlers (LspM ()))
-> Handler (LspM ()) 'TextDocumentDidSave -> Handlers (LspM ())
forall a b. (a -> b) -> a -> b
$ \NotificationMessage 'TextDocumentDidSave
msg -> do
  let NotificationMessage Text
_ SMethod 'TextDocumentDidSave
_ (DidSaveTextDocumentParams doc _text) = NotificationMessage '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
uri
  String -> LspT () IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> LspT () IO ()) -> String -> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ 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 (LspM ())
onDocumentChangeHandler IORef State
state_mvar = SMethod 'TextDocumentDidChange
-> Handler (LspM ()) 'TextDocumentDidChange -> Handlers (LspM ())
forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'TextDocumentDidChange
STextDocumentDidChange (Handler (LspM ()) 'TextDocumentDidChange -> Handlers (LspM ()))
-> Handler (LspM ()) 'TextDocumentDidChange -> Handlers (LspM ())
forall a b. (a -> b) -> a -> b
$ \NotificationMessage 'TextDocumentDidChange
msg -> do
  let NotificationMessage Text
_ SMethod 'TextDocumentDidChange
_ (DidChangeTextDocumentParams doc _content) = NotificationMessage '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
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 (LspM ())
onDocumentOpenHandler IORef State
state_mvar = SMethod 'TextDocumentDidOpen
-> Handler (LspM ()) 'TextDocumentDidOpen -> Handlers (LspM ())
forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'TextDocumentDidOpen
STextDocumentDidOpen (Handler (LspM ()) 'TextDocumentDidOpen -> Handlers (LspM ()))
-> Handler (LspM ()) 'TextDocumentDidOpen -> Handlers (LspM ())
forall a b. (a -> b) -> a -> b
$ \NotificationMessage 'TextDocumentDidOpen
msg -> do
  let NotificationMessage Text
_ SMethod 'TextDocumentDidOpen
_ (DidOpenTextDocumentParams doc) = NotificationMessage '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
uri
  String -> LspT () IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> LspT () IO ()) -> String -> LspT () IO ()
forall a b. (a -> b) -> a -> b
$ 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
uri)
  IORef State -> Maybe String -> LspT () IO ()
tryReCompile IORef State
state_mvar Maybe String
file_path

onDocumentCloseHandler :: Handlers (LspM ())
onDocumentCloseHandler :: Handlers (LspM ())
onDocumentCloseHandler = SMethod 'TextDocumentDidClose
-> Handler (LspM ()) 'TextDocumentDidClose -> Handlers (LspM ())
forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
notificationHandler SMethod 'TextDocumentDidClose
STextDocumentDidClose (Handler (LspM ()) 'TextDocumentDidClose -> Handlers (LspM ()))
-> Handler (LspM ()) 'TextDocumentDidClose -> Handlers (LspM ())
forall a b. (a -> b) -> a -> b
$ \NotificationMessage 'TextDocumentDidClose
_msg -> String -> LspT () IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"Closed document"