-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE GADTs #-}

-- | Display information on hover.
module Development.IDE.LSP.HoverDefinition
    (
    -- * For haskell-language-server
    hover
    , gotoDefinition
    , gotoTypeDefinition
    , documentHighlight
    , references
    , wsSymbols
    ) where

import           Control.Monad.Except           (ExceptT)
import           Control.Monad.IO.Class
import           Data.Maybe                     (fromMaybe)
import           Development.IDE.Core.Actions
import           Development.IDE.Core.Rules
import           Development.IDE.Core.Shake
import           Development.IDE.Types.Location
import           Ide.Logger
import           Ide.Plugin.Error
import           Ide.Types
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import qualified Language.LSP.Server            as LSP

import qualified Data.Text                      as T

gotoDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition)
hover          :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null)
gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition)
documentHighlight :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null)
gotoDefinition :: forall c.
IdeState
-> TextDocumentPositionParams
-> ExceptT
     PluginError (LspM c) (MessageResult 'Method_TextDocumentDefinition)
gotoDefinition = Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe [Location]))
-> (Definition |? ([DefinitionLink] |? Null))
-> ([Location] -> Definition |? ([DefinitionLink] |? Null))
-> IdeState
-> TextDocumentPositionParams
-> ExceptT
     PluginError (LspT c IO) (Definition |? ([DefinitionLink] |? Null))
forall a b c.
Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-> b
-> (a -> b)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (LspM c) b
request Text
"Definition" NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
getDefinition (([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) (Definition -> Definition |? ([DefinitionLink] |? Null)
forall a b. a -> a |? b
InL (Definition -> Definition |? ([DefinitionLink] |? Null))
-> ([Location] -> Definition)
-> [Location]
-> Definition |? ([DefinitionLink] |? Null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location |? [Location]) -> Definition
Definition((Location |? [Location]) -> Definition)
-> ([Location] -> Location |? [Location])
-> [Location]
-> Definition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Location] -> Location |? [Location]
forall a b. b -> a |? b
InR)
gotoTypeDefinition :: forall c.
IdeState
-> TextDocumentPositionParams
-> ExceptT
     PluginError
     (LspM c)
     (MessageResult 'Method_TextDocumentTypeDefinition)
gotoTypeDefinition = Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe [Location]))
-> (Definition |? ([DefinitionLink] |? Null))
-> ([Location] -> Definition |? ([DefinitionLink] |? Null))
-> IdeState
-> TextDocumentPositionParams
-> ExceptT
     PluginError (LspT c IO) (Definition |? ([DefinitionLink] |? Null))
forall a b c.
Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-> b
-> (a -> b)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (LspM c) b
request Text
"TypeDefinition" NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
getTypeDefinition (([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) (Definition -> Definition |? ([DefinitionLink] |? Null)
forall a b. a -> a |? b
InL (Definition -> Definition |? ([DefinitionLink] |? Null))
-> ([Location] -> Definition)
-> [Location]
-> Definition |? ([DefinitionLink] |? Null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location |? [Location]) -> Definition
Definition((Location |? [Location]) -> Definition)
-> ([Location] -> Location |? [Location])
-> [Location]
-> Definition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Location] -> Location |? [Location]
forall a b. b -> a |? b
InR)
hover :: forall c.
IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (LspM c) (Hover |? Null)
hover          = Text
-> (NormalizedFilePath
    -> Position -> IdeAction (Maybe (Maybe Range, [Text])))
-> (Hover |? Null)
-> ((Maybe Range, [Text]) -> Hover |? Null)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (LspM c) (Hover |? Null)
forall a b c.
Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-> b
-> (a -> b)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (LspM c) b
request Text
"Hover"      NormalizedFilePath
-> Position -> IdeAction (Maybe (Maybe Range, [Text]))
getAtPoint     (Null -> Hover |? Null
forall a b. b -> a |? b
InR Null
Null)     (Maybe Range, [Text]) -> Hover |? Null
foundHover
documentHighlight :: forall c.
IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (LspM c) ([DocumentHighlight] |? Null)
documentHighlight = Text
-> (NormalizedFilePath
    -> Position -> IdeAction (Maybe [DocumentHighlight]))
-> ([DocumentHighlight] |? Null)
-> ([DocumentHighlight] -> [DocumentHighlight] |? Null)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (LspM c) ([DocumentHighlight] |? Null)
forall a b c.
Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-> b
-> (a -> b)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (LspM c) b
request Text
"DocumentHighlight" NormalizedFilePath
-> Position -> IdeAction (Maybe [DocumentHighlight])
highlightAtPoint (Null -> [DocumentHighlight] |? Null
forall a b. b -> a |? b
InR Null
Null) [DocumentHighlight] -> [DocumentHighlight] |? Null
forall a b. a -> a |? b
InL

references :: PluginMethodHandler IdeState Method_TextDocumentReferences
references :: PluginMethodHandler IdeState 'Method_TextDocumentReferences
references IdeState
ide PluginId
_ (ReferenceParams (TextDocumentIdentifier Uri
uri) Position
pos Maybe ProgressToken
_ Maybe ProgressToken
_ ReferenceContext
_) = do
  NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
  IO () -> ExceptT PluginError (LspM Config) ()
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT PluginError (LspM Config) ())
-> IO () -> ExceptT PluginError (LspM Config) ()
forall a b. (a -> b) -> a -> b
$ Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text
"References request at position " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Position -> String
showPosition Position
pos) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
" in file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (NormalizedFilePath -> String
forall a. Show a => a -> String
show NormalizedFilePath
nfp)
  [Location] -> [Location] |? Null
forall a b. a -> a |? b
InL ([Location] -> [Location] |? Null)
-> ExceptT PluginError (LspM Config) [Location]
-> ExceptT PluginError (LspM Config) ([Location] |? Null)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO [Location] -> ExceptT PluginError (LspM Config) [Location]
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Location] -> ExceptT PluginError (LspM Config) [Location])
-> IO [Location] -> ExceptT PluginError (LspM Config) [Location]
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action [Location] -> IO [Location]
forall a. String -> IdeState -> Action a -> IO a
runAction String
"references" IdeState
ide (Action [Location] -> IO [Location])
-> Action [Location] -> IO [Location]
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Position -> Action [Location]
refsAtPoint NormalizedFilePath
nfp Position
pos)

wsSymbols :: PluginMethodHandler IdeState Method_WorkspaceSymbol
wsSymbols :: PluginMethodHandler IdeState 'Method_WorkspaceSymbol
wsSymbols IdeState
ide PluginId
_ (WorkspaceSymbolParams Maybe ProgressToken
_ Maybe ProgressToken
_ Text
query) = IO (MessageResult 'Method_WorkspaceSymbol)
-> ExceptT
     PluginError (LspM Config) (MessageResult 'Method_WorkspaceSymbol)
forall a. IO a -> ExceptT PluginError (LspM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MessageResult 'Method_WorkspaceSymbol)
 -> ExceptT
      PluginError (LspM Config) (MessageResult 'Method_WorkspaceSymbol))
-> IO (MessageResult 'Method_WorkspaceSymbol)
-> ExceptT
     PluginError (LspM Config) (MessageResult 'Method_WorkspaceSymbol)
forall a b. (a -> b) -> a -> b
$ do
  Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Workspace symbols request: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
query
  String
-> ShakeExtras
-> IdeAction ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
-> IO ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
forall a. String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction String
"WorkspaceSymbols" (IdeState -> ShakeExtras
shakeExtras IdeState
ide) (IdeAction ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
 -> IO ([SymbolInformation] |? ([WorkspaceSymbol] |? Null)))
-> IdeAction ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
-> IO ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
forall a b. (a -> b) -> a -> b
$ [SymbolInformation]
-> [SymbolInformation] |? ([WorkspaceSymbol] |? Null)
forall a b. a -> a |? b
InL ([SymbolInformation]
 -> [SymbolInformation] |? ([WorkspaceSymbol] |? Null))
-> (Maybe [SymbolInformation] -> [SymbolInformation])
-> Maybe [SymbolInformation]
-> [SymbolInformation] |? ([WorkspaceSymbol] |? Null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SymbolInformation]
-> Maybe [SymbolInformation] -> [SymbolInformation]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [SymbolInformation]
 -> [SymbolInformation] |? ([WorkspaceSymbol] |? Null))
-> IdeAction (Maybe [SymbolInformation])
-> IdeAction ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IdeAction (Maybe [SymbolInformation])
workspaceSymbols Text
query

foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null
foundHover :: (Maybe Range, [Text]) -> Hover |? Null
foundHover (Maybe Range
mbRange, [Text]
contents) =
  Hover -> Hover |? Null
forall a b. a -> a |? b
InL (Hover -> Hover |? Null) -> Hover -> Hover |? Null
forall a b. (a -> b) -> a -> b
$ (MarkupContent |? (MarkedString |? [MarkedString]))
-> Maybe Range -> Hover
Hover (MarkupContent -> MarkupContent |? (MarkedString |? [MarkedString])
forall a b. a -> a |? b
InL (MarkupContent
 -> MarkupContent |? (MarkedString |? [MarkedString]))
-> MarkupContent
-> MarkupContent |? (MarkedString |? [MarkedString])
forall a b. (a -> b) -> a -> b
$ MarkupKind -> Text -> MarkupContent
MarkupContent MarkupKind
MarkupKind_Markdown (Text -> MarkupContent) -> Text -> MarkupContent
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
sectionSeparator [Text]
contents) Maybe Range
mbRange

-- | Respond to and log a hover or go-to-definition request
request
  :: T.Text
  -> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
  -> b
  -> (a -> b)
  -> IdeState
  -> TextDocumentPositionParams
  -> ExceptT PluginError (LSP.LspM c) b
request :: forall a b c.
Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-> b
-> (a -> b)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (LspM c) b
request Text
label NormalizedFilePath -> Position -> IdeAction (Maybe a)
getResults b
notFound a -> b
found IdeState
ide (TextDocumentPositionParams (TextDocumentIdentifier Uri
uri) Position
pos) = IO b -> ExceptT PluginError (LspM c) b
forall a. IO a -> ExceptT PluginError (LspM c) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> ExceptT PluginError (LspM c) b)
-> IO b -> ExceptT PluginError (LspM c) b
forall a b. (a -> b) -> a -> b
$ do
    Maybe a
mbResult <- case Uri -> Maybe String
uriToFilePath' Uri
uri of
        Just String
path -> Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-> IdeState
-> Position
-> String
-> IO (Maybe a)
forall b.
Text
-> (NormalizedFilePath -> Position -> IdeAction b)
-> IdeState
-> Position
-> String
-> IO b
logAndRunRequest Text
label NormalizedFilePath -> Position -> IdeAction (Maybe a)
getResults IdeState
ide Position
pos String
path
        Maybe String
Nothing   -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    b -> IO b
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> IO b) -> b -> IO b
forall a b. (a -> b) -> a -> b
$ b -> (a -> b) -> Maybe a -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
notFound a -> b
found Maybe a
mbResult

logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b
logAndRunRequest :: forall b.
Text
-> (NormalizedFilePath -> Position -> IdeAction b)
-> IdeState
-> Position
-> String
-> IO b
logAndRunRequest Text
label NormalizedFilePath -> Position -> IdeAction b
getResults IdeState
ide Position
pos String
path = do
  let filePath :: NormalizedFilePath
filePath = String -> NormalizedFilePath
toNormalizedFilePath' String
path
  Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
    Text
label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" request at position " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Position -> String
showPosition Position
pos) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
    Text
" in file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
path
  String -> ShakeExtras -> IdeAction b -> IO b
forall a. String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction (Text -> String
T.unpack Text
label) (IdeState -> ShakeExtras
shakeExtras IdeState
ide) (NormalizedFilePath -> Position -> IdeAction b
getResults NormalizedFilePath
filePath Position
pos)