-- | An HLS plugin to provide code lenses for type signatures

module Development.IDE.Plugin.TypeLenses
  ( descriptor,
    suggestSignature,
    typeLensCommandId,
  )
where

import Control.Monad.IO.Class
import Data.Aeson.Types (Value (..), toJSON)
import qualified Data.HashMap.Strict as Map
import qualified Data.Text as T
import Development.IDE.Core.RuleTypes (TypeCheck (TypeCheck))
import Development.IDE.Core.Rules (IdeState, runAction)
import Development.IDE.Core.Service (getDiagnostics)
import Development.IDE.Core.Shake (getHiddenDiagnostics, use)
import Development.IDE.Types.Location
  ( Position (Position, _character, _line),
    Range (Range, _end, _start),
    toNormalizedFilePath',
    uriToFilePath',
  )
import Ide.PluginUtils (mkLspCommand)
import Ide.Types
  ( CommandFunction,
    CommandId (CommandId),
    PluginCommand (PluginCommand),
    PluginDescriptor(..),
    PluginId,
    defaultPluginDescriptor,
    mkPluginHandler
  )
import qualified Language.LSP.Server as LSP
import Language.LSP.Types
  ( ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
    CodeLens (CodeLens),
    CodeLensParams (CodeLensParams, _textDocument),
    Diagnostic (..),
    List (..),
    ResponseError,
    TextDocumentIdentifier (TextDocumentIdentifier),
    TextEdit (TextEdit),
    WorkspaceEdit (WorkspaceEdit),
    SMethod(..)
  )
import Text.Regex.TDFA ((=~))

typeLensCommandId :: T.Text
typeLensCommandId :: Text
typeLensCommandId = Text
"typesignature.add"

descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId =
  (PluginId -> PluginDescriptor Any
forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
    { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = SClientMethod 'TextDocumentCodeLens
-> PluginMethodHandler IdeState 'TextDocumentCodeLens
-> PluginHandlers IdeState
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod 'TextDocumentCodeLens
STextDocumentCodeLens PluginMethodHandler IdeState 'TextDocumentCodeLens
forall c.
IdeState
-> PluginId
-> CodeLensParams
-> LspM c (Either ResponseError (List CodeLens))
codeLensProvider,
      pluginCommands :: [PluginCommand IdeState]
pluginCommands = [CommandId
-> Text
-> CommandFunction IdeState WorkspaceEdit
-> PluginCommand IdeState
forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand (Text -> CommandId
CommandId Text
typeLensCommandId) Text
"adds a signature" CommandFunction IdeState WorkspaceEdit
commandHandler]
    }

codeLensProvider ::
  IdeState ->
  PluginId ->
  CodeLensParams ->
  LSP.LspM c (Either ResponseError (List CodeLens))
codeLensProvider :: IdeState
-> PluginId
-> CodeLensParams
-> LspM c (Either ResponseError (List CodeLens))
codeLensProvider IdeState
ideState PluginId
pId CodeLensParams {$sel:_textDocument:CodeLensParams :: CodeLensParams -> TextDocumentIdentifier
_textDocument = TextDocumentIdentifier Uri
uri} = do
  ([CodeLens] -> Either ResponseError (List CodeLens))
-> LspT c IO [CodeLens]
-> LspM c (Either ResponseError (List CodeLens))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (List CodeLens -> Either ResponseError (List CodeLens)
forall a b. b -> Either a b
Right (List CodeLens -> Either ResponseError (List CodeLens))
-> ([CodeLens] -> List CodeLens)
-> [CodeLens]
-> Either ResponseError (List CodeLens)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CodeLens] -> List CodeLens
forall a. [a] -> List a
List) (LspT c IO [CodeLens]
 -> LspM c (Either ResponseError (List CodeLens)))
-> LspT c IO [CodeLens]
-> LspM c (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$ case Uri -> Maybe FilePath
uriToFilePath' Uri
uri of
    Just (FilePath -> NormalizedFilePath
toNormalizedFilePath' -> NormalizedFilePath
filePath) -> IO [CodeLens] -> LspT c IO [CodeLens]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CodeLens] -> LspT c IO [CodeLens])
-> IO [CodeLens] -> LspT c IO [CodeLens]
forall a b. (a -> b) -> a -> b
$ do
      Maybe TcModuleResult
_ <- FilePath
-> IdeState
-> Action (Maybe TcModuleResult)
-> IO (Maybe TcModuleResult)
forall a. FilePath -> IdeState -> Action a -> IO a
runAction FilePath
"codeLens" IdeState
ideState (TypeCheck -> NormalizedFilePath -> Action (Maybe TcModuleResult)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
filePath)
      [FileDiagnostic]
diag <- IdeState -> IO [FileDiagnostic]
getDiagnostics IdeState
ideState
      [FileDiagnostic]
hDiag <- IdeState -> IO [FileDiagnostic]
getHiddenDiagnostics IdeState
ideState
      [IO CodeLens] -> IO [CodeLens]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ PluginId -> Range -> Text -> WorkspaceEdit -> IO CodeLens
generateLens PluginId
pId Range
_range Text
title WorkspaceEdit
edit
          | (NormalizedFilePath
dFile, ShowDiagnostic
_, dDiag :: Diagnostic
dDiag@Diagnostic {$sel:_range:Diagnostic :: Diagnostic -> Range
_range = Range
_range}) <- [FileDiagnostic]
diag [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
forall a. [a] -> [a] -> [a]
++ [FileDiagnostic]
hDiag,
            NormalizedFilePath
dFile NormalizedFilePath -> NormalizedFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== NormalizedFilePath
filePath,
            (Text
title, [TextEdit]
tedit) <- Bool -> Diagnostic -> [(Text, [TextEdit])]
suggestSignature Bool
False Diagnostic
dDiag,
            let edit :: WorkspaceEdit
edit = Maybe WorkspaceEditMap
-> Maybe (List DocumentChange) -> WorkspaceEdit
WorkspaceEdit (WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a. a -> Maybe a
Just (WorkspaceEditMap -> Maybe WorkspaceEditMap)
-> WorkspaceEditMap -> Maybe WorkspaceEditMap
forall a b. (a -> b) -> a -> b
$ Uri -> List TextEdit -> WorkspaceEditMap
forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton Uri
uri (List TextEdit -> WorkspaceEditMap)
-> List TextEdit -> WorkspaceEditMap
forall a b. (a -> b) -> a -> b
$ [TextEdit] -> List TextEdit
forall a. [a] -> List a
List [TextEdit]
tedit) Maybe (List DocumentChange)
forall a. Maybe a
Nothing
        ]
    Maybe FilePath
Nothing -> [CodeLens] -> LspT c IO [CodeLens]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> IO CodeLens
generateLens :: PluginId -> Range -> Text -> WorkspaceEdit -> IO CodeLens
generateLens PluginId
pId Range
_range Text
title WorkspaceEdit
edit = do
  let cId :: Command
cId = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
pId (Text -> CommandId
CommandId Text
typeLensCommandId) Text
title ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [WorkspaceEdit -> Value
forall a. ToJSON a => a -> Value
toJSON WorkspaceEdit
edit])
  CodeLens -> IO CodeLens
forall (m :: * -> *) a. Monad m => a -> m a
return (CodeLens -> IO CodeLens) -> CodeLens -> IO CodeLens
forall a b. (a -> b) -> a -> b
$ Range -> Maybe Command -> Maybe Value -> CodeLens
CodeLens Range
_range (Command -> Maybe Command
forall a. a -> Maybe a
Just Command
cId) Maybe Value
forall a. Maybe a
Nothing

commandHandler :: CommandFunction IdeState WorkspaceEdit
commandHandler :: CommandFunction IdeState WorkspaceEdit
commandHandler IdeState
_ideState WorkspaceEdit
wedit = do
  LspId 'WorkspaceApplyEdit
_ <- SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
wedit) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value
 -> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null

suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
suggestSignature :: Bool -> Diagnostic -> [(Text, [TextEdit])]
suggestSignature Bool
isQuickFix Diagnostic {$sel:_range:Diagnostic :: Diagnostic -> Range
_range = _range :: Range
_range@Range {Position
_end :: Position
_start :: Position
_start :: Range -> Position
_end :: Range -> Position
..}, Maybe Text
Maybe DiagnosticSeverity
Maybe (Int |? Text)
Maybe (List DiagnosticTag)
Maybe (List DiagnosticRelatedInformation)
Text
$sel:_severity:Diagnostic :: Diagnostic -> Maybe DiagnosticSeverity
$sel:_code:Diagnostic :: Diagnostic -> Maybe (Int |? Text)
$sel:_source:Diagnostic :: Diagnostic -> Maybe Text
$sel:_message:Diagnostic :: Diagnostic -> Text
$sel:_tags:Diagnostic :: Diagnostic -> Maybe (List DiagnosticTag)
$sel:_relatedInformation:Diagnostic :: Diagnostic -> Maybe (List DiagnosticRelatedInformation)
_relatedInformation :: Maybe (List DiagnosticRelatedInformation)
_tags :: Maybe (List DiagnosticTag)
_message :: Text
_source :: Maybe Text
_code :: Maybe (Int |? Text)
_severity :: Maybe DiagnosticSeverity
..}
  | Text
_message
      Text -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (Text
"(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) =
    let signature :: Text
signature =
          Text -> Text
removeInitialForAll (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
            (Char -> Bool) -> Text -> Text
T.takeWhile (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'*' Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'•') (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
              Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
unifySpaces (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. [a] -> a
last ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"type signature: " (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
filterNewlines Text
_message
        startOfLine :: Position
startOfLine = Int -> Int -> Position
Position (Position -> Int
_line Position
_start) Int
startCharacter
        beforeLine :: Range
beforeLine = Position -> Position -> Range
Range Position
startOfLine Position
startOfLine
        title :: Text
title = if Bool
isQuickFix then Text
"add signature: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
signature else Text
signature
        action :: TextEdit
action = Range -> Text -> TextEdit
TextEdit Range
beforeLine (Text -> TextEdit) -> Text -> TextEdit
forall a b. (a -> b) -> a -> b
$ Text
signature Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
startCharacter Text
" "
     in [(Text
title, [TextEdit
action])]
  where
    removeInitialForAll :: T.Text -> T.Text
    removeInitialForAll :: Text -> Text
removeInitialForAll (Text -> Text -> (Text, Text)
T.breakOnEnd Text
" :: " -> (Text
nm, Text
ty))
      | Text
"forall" Text -> Text -> Bool
`T.isPrefixOf` Text
ty = Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop Int
2 ((Text, Text) -> Text
forall a b. (a, b) -> b
snd (Text -> Text -> (Text, Text)
T.breakOn Text
"." Text
ty))
      | Bool
otherwise = Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty
    startCharacter :: Int
startCharacter
      | Text
"Polymorphic local binding" Text -> Text -> Bool
`T.isPrefixOf` Text
_message =
        Position -> Int
_character Position
_start
      | Bool
otherwise =
        Int
0
suggestSignature Bool
_ Diagnostic
_ = []

unifySpaces :: T.Text -> T.Text
unifySpaces :: Text -> Text
unifySpaces = [Text] -> Text
T.unwords ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words

filterNewlines :: T.Text -> T.Text
filterNewlines :: Text -> Text
filterNewlines = [Text] -> Text
T.concat ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines