{-# 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 Data.Text qualified as Text
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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
Aeson..= Range
range,
        Key
"typeSignature" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
Aeson..= Text
typeSignature,
        Key
"fileUri" Key -> Uri -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
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.ResponseError ([CodeLens] |? Null) -> Lsp ()) -> Lsp ()
codeLensHandler :: TRequestMessage 'Method_TextDocumentCodeLens
-> (Either ResponseError ([CodeLens] |? Null) -> Lsp ()) -> Lsp ()
codeLensHandler TRequestMessage 'Method_TextDocumentCodeLens
m Either ResponseError ([CodeLens] |? Null) -> Lsp ()
respond =
  Either ResponseError ([CodeLens] |? Null) -> Lsp ()
respond (Either ResponseError ([CodeLens] |? Null) -> Lsp ())
-> (Maybe ([CodeLens] |? Null)
    -> Either ResponseError ([CodeLens] |? Null))
-> Maybe ([CodeLens] |? Null)
-> Lsp ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ResponseError ([CodeLens] |? Null)
-> (([CodeLens] |? Null)
    -> Either ResponseError ([CodeLens] |? Null))
-> Maybe ([CodeLens] |? Null)
-> Either ResponseError ([CodeLens] |? Null)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (([CodeLens] |? Null) -> Either ResponseError ([CodeLens] |? Null)
forall a b. b -> Either a b
Right (([CodeLens] |? Null) -> Either ResponseError ([CodeLens] |? Null))
-> ([CodeLens] |? Null)
-> Either ResponseError ([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 ResponseError ([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 {Map Symbol TypeSignatureHint
typeSignatureHints :: Map Symbol TypeSignatureHint
$sel:typeSignatureHints:FileAnalysis :: FileAnalysis -> Map Symbol TypeSignatureHint
typeSignatureHints} <- Uri -> MaybeT Lsp FileAnalysis
getFileAnalysis Uri
fileUri
    Map Symbol CodeLens
codeLenses <- Map Symbol TypeSignatureHint
-> (Symbol -> TypeSignatureHint -> MaybeT Lsp CodeLens)
-> MaybeT Lsp (Map Symbol CodeLens)
forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
t a -> (i -> a -> f b) -> f (t b)
ifor Map Symbol TypeSignatureHint
typeSignatureHints \Symbol
_v (TypeSignatureHint Name
name Referent
ref Range
range Type Symbol Ann
typ) -> do
      PrettyPrintEnv
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
ppedForFile Uri
fileUri)
      let rendered :: Text
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] -> String -> Text
Text.pack (String -> Text)
-> (Pretty ColorText -> String) -> Pretty ColorText -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Width -> Pretty ColorText -> String
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
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 $
        Range -> Maybe Command -> Maybe Value -> CodeLens
CodeLens
          Range
range
          (Command -> Maybe Command
forall a. a -> Maybe a
Just (Command -> Maybe Command) -> Command -> Maybe Command
forall a b. (a -> b) -> a -> b
$ Text -> TextReplacement -> Command
replaceText Text
rendered (TextReplacement -> Command) -> TextReplacement -> Command
forall a b. (a -> b) -> a -> b
$ Range -> Text -> Text -> Uri -> TextReplacement
TextReplacement Range
insertLocation Text
"Insert type signature" (Text
rendered Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n") Uri
fileUri)
          Maybe Value
forall a. Maybe a
Nothing
    pure ([CodeLens] -> [CodeLens] |? Null
forall a b. a -> a |? b
InL ([CodeLens] -> [CodeLens] |? Null)
-> [CodeLens] -> [CodeLens] |? Null
forall a b. (a -> b) -> a -> b
$ Map Symbol CodeLens -> [CodeLens]
forall k a. Map k a -> [a]
Map.elems Map Symbol CodeLens
codeLenses)