-- 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
    ( Log(..)
    -- * 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 qualified Development.IDE.Core.Rules     as Shake
import           Development.IDE.Core.Shake     (IdeAction, IdeState (..),
                                                 runIdeAction)
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 Data.Text                      as T


data Log
  = LogWorkspaceSymbolRequest !T.Text
  | LogRequest !T.Text !Position !NormalizedFilePath
  deriving (Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> String
show :: Log -> String
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show)

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogWorkspaceSymbolRequest Text
query -> Doc ann
"Workspace symbols request:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
query
    LogRequest Text
label Position
pos NormalizedFilePath
nfp ->
      Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
label Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"request at position" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Position -> String
showPosition Position
pos) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        Doc ann
"in file:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp)

gotoDefinition     :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentDefinition)
hover              :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null)
gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition)
documentHighlight  :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null)
gotoDefinition :: forall c.
Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT
     PluginError
     (HandlerM c)
     (MessageResult 'Method_TextDocumentDefinition)
gotoDefinition = Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe [Location]))
-> (Definition |? ([DefinitionLink] |? Null))
-> ([Location] -> Definition |? ([DefinitionLink] |? Null))
-> Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT
     PluginError (HandlerM c) (Definition |? ([DefinitionLink] |? Null))
forall a b c.
Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-> b
-> (a -> b)
-> Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (HandlerM 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.
Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT
     PluginError
     (HandlerM c)
     (MessageResult 'Method_TextDocumentTypeDefinition)
gotoTypeDefinition = Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe [Location]))
-> (Definition |? ([DefinitionLink] |? Null))
-> ([Location] -> Definition |? ([DefinitionLink] |? Null))
-> Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT
     PluginError (HandlerM c) (Definition |? ([DefinitionLink] |? Null))
forall a b c.
Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-> b
-> (a -> b)
-> Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (HandlerM 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.
Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (HandlerM c) (Hover |? Null)
hover          = Text
-> (NormalizedFilePath
    -> Position -> IdeAction (Maybe (Maybe Range, [Text])))
-> (Hover |? Null)
-> ((Maybe Range, [Text]) -> Hover |? Null)
-> Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (HandlerM c) (Hover |? Null)
forall a b c.
Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-> b
-> (a -> b)
-> Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (HandlerM 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.
Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null)
documentHighlight = Text
-> (NormalizedFilePath
    -> Position -> IdeAction (Maybe [DocumentHighlight]))
-> ([DocumentHighlight] |? Null)
-> ([DocumentHighlight] -> [DocumentHighlight] |? Null)
-> Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null)
forall a b c.
Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-> b
-> (a -> b)
-> Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (HandlerM 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 :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentReferences
references :: Recorder (WithPriority Log)
-> PluginMethodHandler IdeState 'Method_TextDocumentReferences
references Recorder (WithPriority Log)
recorder IdeState
ide PluginId
_ (ReferenceParams (TextDocumentIdentifier Uri
uri) Position
pos Maybe ProgressToken
_ Maybe ProgressToken
_ ReferenceContext
_) = do
  NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (HandlerM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
  IO () -> ExceptT PluginError (HandlerM Config) ()
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT PluginError (HandlerM Config) ())
-> IO () -> ExceptT PluginError (HandlerM Config) ()
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Position -> NormalizedFilePath -> Log
LogRequest Text
"References" Position
pos NormalizedFilePath
nfp
  [Location] -> [Location] |? Null
forall a b. a -> a |? b
InL ([Location] -> [Location] |? Null)
-> ExceptT PluginError (HandlerM Config) [Location]
-> ExceptT PluginError (HandlerM Config) ([Location] |? Null)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO [Location] -> ExceptT PluginError (HandlerM Config) [Location]
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Location] -> ExceptT PluginError (HandlerM Config) [Location])
-> IO [Location]
-> ExceptT PluginError (HandlerM Config) [Location]
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action [Location] -> IO [Location]
forall a. String -> IdeState -> Action a -> IO a
Shake.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 :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_WorkspaceSymbol
wsSymbols :: Recorder (WithPriority Log)
-> PluginMethodHandler IdeState 'Method_WorkspaceSymbol
wsSymbols Recorder (WithPriority Log)
recorder IdeState
ide PluginId
_ (WorkspaceSymbolParams Maybe ProgressToken
_ Maybe ProgressToken
_ Text
query) = IO (MessageResult 'Method_WorkspaceSymbol)
-> ExceptT
     PluginError
     (HandlerM Config)
     (MessageResult 'Method_WorkspaceSymbol)
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MessageResult 'Method_WorkspaceSymbol)
 -> ExceptT
      PluginError
      (HandlerM Config)
      (MessageResult 'Method_WorkspaceSymbol))
-> IO (MessageResult 'Method_WorkspaceSymbol)
-> ExceptT
     PluginError
     (HandlerM Config)
     (MessageResult 'Method_WorkspaceSymbol)
forall a b. (a -> b) -> a -> b
$ do
  Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Log
LogWorkspaceSymbolRequest 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)
  -> Recorder (WithPriority Log)
  -> IdeState
  -> TextDocumentPositionParams
  -> ExceptT PluginError (HandlerM c) b
request :: forall a b c.
Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-> b
-> (a -> b)
-> Recorder (WithPriority Log)
-> IdeState
-> TextDocumentPositionParams
-> ExceptT PluginError (HandlerM c) b
request Text
label NormalizedFilePath -> Position -> IdeAction (Maybe a)
getResults b
notFound a -> b
found Recorder (WithPriority Log)
recorder IdeState
ide (TextDocumentPositionParams (TextDocumentIdentifier Uri
uri) Position
pos) = IO b -> ExceptT PluginError (HandlerM c) b
forall a. IO a -> ExceptT PluginError (HandlerM c) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> ExceptT PluginError (HandlerM c) b)
-> IO b -> ExceptT PluginError (HandlerM c) b
forall a b. (a -> b) -> a -> b
$ do
    Maybe a
mbResult <- case Uri -> Maybe String
uriToFilePath' Uri
uri of
        Just String
path -> Recorder (WithPriority Log)
-> Text
-> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-> IdeState
-> Position
-> String
-> IO (Maybe a)
forall b.
Recorder (WithPriority Log)
-> Text
-> (NormalizedFilePath -> Position -> IdeAction b)
-> IdeState
-> Position
-> String
-> IO b
logAndRunRequest Recorder (WithPriority Log)
recorder 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 :: Recorder (WithPriority Log) -> T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b
logAndRunRequest :: forall b.
Recorder (WithPriority Log)
-> Text
-> (NormalizedFilePath -> Position -> IdeAction b)
-> IdeState
-> Position
-> String
-> IO b
logAndRunRequest Recorder (WithPriority Log)
recorder Text
label NormalizedFilePath -> Position -> IdeAction b
getResults IdeState
ide Position
pos String
path = do
  let filePath :: NormalizedFilePath
filePath = String -> NormalizedFilePath
toNormalizedFilePath' String
path
  Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Position -> NormalizedFilePath -> Log
LogRequest Text
label Position
pos NormalizedFilePath
filePath
  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)