{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}

module Unison.LSP.CodeLens where

import Control.Lens hiding (List)
import Data.Aeson qualified as Aeson
import Data.Map qualified as Map
import Language.LSP.Protocol.Lens hiding (error)
import Language.LSP.Protocol.Message qualified as Msg
import Language.LSP.Protocol.Types
import Unison.HashQualified qualified as HQ
import Unison.LSP.Commands (TextReplacement (TextReplacement), replaceText)
import Unison.LSP.FileAnalysis
import Unison.LSP.Types
import Unison.Prelude
import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.Syntax.TypePrinter qualified as TypePrinter
import Unison.Util.Pretty qualified as CT

data TypeSigInsertion = TypeSigInsertion
  { TypeSigInsertion -> Range
range :: Range,
    TypeSigInsertion -> Text
typeSignature :: Text,
    TypeSigInsertion -> Uri
fileUri :: Uri
  }

instance Aeson.ToJSON TypeSigInsertion where
  toJSON :: TypeSigInsertion -> Value
toJSON (TypeSigInsertion Range
range Text
typeSignature Uri
fileUri) =
    [Pair] -> Value
Aeson.object
      [ Key
"range" Key -> Range -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Range
range,
        Key
"typeSignature" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Text
typeSignature,
        Key
"fileUri" Key -> Uri -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Uri
fileUri
      ]

instance Aeson.FromJSON TypeSigInsertion where
  parseJSON :: Value -> Parser TypeSigInsertion
parseJSON = String
-> (Object -> Parser TypeSigInsertion)
-> Value
-> Parser TypeSigInsertion
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"TypeSigInsertion" ((Object -> Parser TypeSigInsertion)
 -> Value -> Parser TypeSigInsertion)
-> (Object -> Parser TypeSigInsertion)
-> Value
-> Parser TypeSigInsertion
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Range -> Text -> Uri -> TypeSigInsertion
TypeSigInsertion
      (Range -> Text -> Uri -> TypeSigInsertion)
-> Parser Range -> Parser (Text -> Uri -> TypeSigInsertion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o
        Object -> Key -> Parser Range
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"range"
      Parser (Text -> Uri -> TypeSigInsertion)
-> Parser Text -> Parser (Uri -> TypeSigInsertion)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o
        Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"typeSignature"
      Parser (Uri -> TypeSigInsertion)
-> Parser Uri -> Parser TypeSigInsertion
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o
        Object -> Key -> Parser Uri
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"fileUri"

-- | Computes code actions for a document.
codeLensHandler :: Msg.TRequestMessage 'Msg.Method_TextDocumentCodeLens -> (Either (Msg.TResponseError m) ([CodeLens] |? Null) -> Lsp ()) -> Lsp ()
codeLensHandler :: forall {f :: MessageDirection} (m :: Method f 'Request).
TRequestMessage 'Method_TextDocumentCodeLens
-> (Either (TResponseError m) ([CodeLens] |? Null) -> Lsp ())
-> Lsp ()
codeLensHandler TRequestMessage 'Method_TextDocumentCodeLens
m Either (TResponseError m) ([CodeLens] |? Null) -> Lsp ()
respond =
  Either (TResponseError m) ([CodeLens] |? Null) -> Lsp ()
respond (Either (TResponseError m) ([CodeLens] |? Null) -> Lsp ())
-> (Maybe ([CodeLens] |? Null)
    -> Either (TResponseError m) ([CodeLens] |? Null))
-> Maybe ([CodeLens] |? Null)
-> Lsp ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (TResponseError m) ([CodeLens] |? Null)
-> (([CodeLens] |? Null)
    -> Either (TResponseError m) ([CodeLens] |? Null))
-> Maybe ([CodeLens] |? Null)
-> Either (TResponseError m) ([CodeLens] |? Null)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (([CodeLens] |? Null)
-> Either (TResponseError m) ([CodeLens] |? Null)
forall a b. b -> Either a b
Right (([CodeLens] |? Null)
 -> Either (TResponseError m) ([CodeLens] |? Null))
-> ([CodeLens] |? Null)
-> Either (TResponseError m) ([CodeLens] |? Null)
forall a b. (a -> b) -> a -> b
$ [CodeLens] -> [CodeLens] |? Null
forall a b. a -> a |? b
InL [CodeLens]
forall a. Monoid a => a
mempty) ([CodeLens] |? Null)
-> Either (TResponseError m) ([CodeLens] |? Null)
forall a b. b -> Either a b
Right (Maybe ([CodeLens] |? Null) -> Lsp ())
-> Lsp (Maybe ([CodeLens] |? Null)) -> Lsp ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MaybeT Lsp ([CodeLens] |? Null) -> Lsp (Maybe ([CodeLens] |? Null))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
    let fileUri :: Uri
fileUri = TRequestMessage 'Method_TextDocumentCodeLens
m TRequestMessage 'Method_TextDocumentCodeLens
-> Getting Uri (TRequestMessage 'Method_TextDocumentCodeLens) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (CodeLensParams -> Const Uri CodeLensParams)
-> TRequestMessage 'Method_TextDocumentCodeLens
-> Const Uri (TRequestMessage 'Method_TextDocumentCodeLens)
forall s a. HasParams s a => Lens' s a
Lens' (TRequestMessage 'Method_TextDocumentCodeLens) CodeLensParams
params ((CodeLensParams -> Const Uri CodeLensParams)
 -> TRequestMessage 'Method_TextDocumentCodeLens
 -> Const Uri (TRequestMessage 'Method_TextDocumentCodeLens))
-> ((Uri -> Const Uri Uri)
    -> CodeLensParams -> Const Uri CodeLensParams)
-> Getting Uri (TRequestMessage 'Method_TextDocumentCodeLens) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> CodeLensParams -> Const Uri CodeLensParams
forall s a. HasTextDocument s a => Lens' s a
Lens' CodeLensParams TextDocumentIdentifier
textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> CodeLensParams -> Const Uri CodeLensParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> (Uri -> Const Uri Uri)
-> CodeLensParams
-> Const Uri CodeLensParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
uri
    FileAnalysis {typeSignatureHints} <- Uri -> MaybeT Lsp FileAnalysis
forall (m :: * -> *). Lspish m => Uri -> MaybeT m FileAnalysis
getFileAnalysis Uri
fileUri
    codeLenses <- ifor typeSignatureHints \Symbol
_v (TypeSignatureHint Name
name Referent
ref Range
range Type Symbol Ann
typ) -> do
      ppe <- PrettyPrintEnvDecl -> PrettyPrintEnv
PPED.suffixifiedPPE (PrettyPrintEnvDecl -> PrettyPrintEnv)
-> MaybeT Lsp PrettyPrintEnvDecl -> MaybeT Lsp PrettyPrintEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lsp PrettyPrintEnvDecl -> MaybeT Lsp PrettyPrintEnvDecl
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Uri -> Lsp PrettyPrintEnvDecl
forall (m :: * -> *). Lspish m => Uri -> m PrettyPrintEnvDecl
ppedForFile Uri
fileUri)
      let rendered = case PrettyPrintEnv
-> [(Referent, HashQualified Name, Type Symbol Ann)]
-> [Pretty ColorText]
forall v a.
Var v =>
PrettyPrintEnv
-> [(Referent, HashQualified Name, Type v a)] -> [Pretty ColorText]
TypePrinter.prettySignaturesCT PrettyPrintEnv
ppe [(Referent
ref, Name -> HashQualified Name
forall n. n -> HashQualified n
HQ.NameOnly Name
name, Type Symbol Ann
typ)] of
            [Pretty ColorText
sig] -> Width -> Pretty ColorText -> Text
CT.toPlain Width
80 (Pretty ColorText -> Text) -> Pretty ColorText -> Text
forall a b. (a -> b) -> a -> b
$ Pretty ColorText
sig
            [Pretty ColorText]
_ -> String -> Text
forall a. HasCallStack => String -> a
error String
"codeLensHandler: prettySignaturesCT returned more than one signature"
      let insertLocation =
            Range
range
              Range -> (Range -> Range) -> Range
forall a b. a -> (a -> b) -> b
& (Position -> Identity Position) -> Range -> Identity Range
forall s a. HasStart s a => Lens' s a
Lens' Range Position
start ((Position -> Identity Position) -> Range -> Identity Range)
-> ((UInt -> Identity UInt) -> Position -> Identity Position)
-> (UInt -> Identity UInt)
-> Range
-> Identity Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UInt -> Identity UInt) -> Position -> Identity Position
forall s a. HasCharacter s a => Lens' s a
Lens' Position UInt
character ((UInt -> Identity UInt) -> Range -> Identity Range)
-> UInt -> Range -> Range
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UInt
0
              Range -> (Range -> Range) -> Range
forall a b. a -> (a -> b) -> b
& (Position -> Identity Position) -> Range -> Identity Range
forall s a. HasEnd s a => Lens' s a
Lens' Range Position
end ((Position -> Identity Position) -> Range -> Identity Range)
-> ((UInt -> Identity UInt) -> Position -> Identity Position)
-> (UInt -> Identity UInt)
-> Range
-> Identity Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UInt -> Identity UInt) -> Position -> Identity Position
forall s a. HasCharacter s a => Lens' s a
Lens' Position UInt
character ((UInt -> Identity UInt) -> Range -> Identity Range)
-> UInt -> Range -> Range
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UInt
0
      pure $
        CodeLens
          range
          (Just $ replaceText rendered $ TextReplacement insertLocation "Insert type signature" (rendered <> "\n") fileUri)
          Nothing
    pure (InL $ Map.elems codeLenses)