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

-- | 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 = 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 (forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR Null
Null) (forall a b. a -> a |? b
InL forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location |? [Location]) -> Definition
Definitionforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> a |? b
InR)
gotoTypeDefinition :: forall c.
IdeState
-> TextDocumentPositionParams
-> ExceptT
     PluginError
     (LspM c)
     (MessageResult 'Method_TextDocumentTypeDefinition)
gotoTypeDefinition = 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 (forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR Null
Null) (forall a b. a -> a |? b
InL forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location |? [Location]) -> Definition
Definitionforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> a |? b
InR)
hover :: forall c.
IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (LspM c) (Hover |? Null)
hover          = 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     (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 = 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 (forall a b. b -> a |? b
InR Null
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 <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) forall a b. (a -> b) -> a -> b
$
        Text
"References request at position " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Position -> String
showPosition Position
pos) forall a. Semigroup a => a -> a -> a
<>
        Text
" in file: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show NormalizedFilePath
nfp)
  forall a b. a -> a |? b
InL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IdeState -> Action a -> IO a
runAction String
"references" IdeState
ide 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) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) forall a b. (a -> b) -> a -> b
$ Text
"Workspace symbols request: " forall a. Semigroup a => a -> a -> a
<> Text
query
  forall a. String -> ShakeExtras -> IdeAction a -> IO a
runIdeAction String
"WorkspaceSymbols" (IdeState -> ShakeExtras
shakeExtras IdeState
ide) forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe [] 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) =
  forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ (MarkupContent |? (MarkedString |? [MarkedString]))
-> Maybe Range -> Hover
Hover (forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ MarkupKind -> Text -> MarkupContent
MarkupContent MarkupKind
MarkupKind_Markdown 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) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Maybe a
mbResult <- case Uri -> Maybe String
uriToFilePath' Uri
uri of
        Just String
path -> 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   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> 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) forall a b. (a -> b) -> a -> b
$
    Text
label forall a. Semigroup a => a -> a -> a
<> Text
" request at position " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Position -> String
showPosition Position
pos) forall a. Semigroup a => a -> a -> a
<>
    Text
" in file: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
path
  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)