diff --git a/curry-language-server.cabal b/curry-language-server.cabal index 628e4c1..ee28bfe 100644 --- a/curry-language-server.cabal +++ b/curry-language-server.cabal @@ -31,6 +31,7 @@ library Curry.LanguageServer.CPM.Deps Curry.LanguageServer.CPM.Monad Curry.LanguageServer.CPM.Process + Curry.LanguageServer.Extension Curry.LanguageServer.FileLoader Curry.LanguageServer.Handlers Curry.LanguageServer.Handlers.Cancel diff --git a/src/Curry/LanguageServer/Config.hs b/src/Curry/LanguageServer/Config.hs index c8cdc7b..8277663 100644 --- a/src/Curry/LanguageServer/Config.hs +++ b/src/Curry/LanguageServer/Config.hs @@ -5,6 +5,7 @@ module Curry.LanguageServer.Config ) where import Colog.Core (Severity (..)) +import Curry.LanguageServer.Extension (Extension (..)) import Data.Aeson ( FromJSON (..) , ToJSON (..) @@ -26,6 +27,7 @@ data Config = Config { forceRecompilation :: Bool , logLevel :: LogLevel , curryPath :: String , useSnippetCompletions :: Bool + , extensions :: [Extension] } deriving (Show, Eq) @@ -36,6 +38,7 @@ instance Default Config where , logLevel = LogLevel Info , curryPath = "pakcs" , useSnippetCompletions = False + , extensions = [] } instance FromJSON Config where @@ -46,6 +49,7 @@ instance FromJSON Config where logLevel <- l .:? "logLevel" .!= (def @Config).logLevel curryPath <- l .:? "curryPath" .!= (def @Config).curryPath useSnippetCompletions <- l .:? "useSnippetCompletions" .!= (def @Config).useSnippetCompletions + extensions <- l .:? "extensions" .!= (def @Config).extensions return Config {..} instance ToJSON Config where @@ -56,6 +60,7 @@ instance ToJSON Config where , "logLevel" .= logLevel , "curryPath" .= curryPath , "useSnippetCompletions" .= useSnippetCompletions + , "extensions" .= extensions ] instance FromJSON LogLevel where diff --git a/src/Curry/LanguageServer/Extension.hs b/src/Curry/LanguageServer/Extension.hs new file mode 100644 index 0000000..2fd86ab --- /dev/null +++ b/src/Curry/LanguageServer/Extension.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedRecordDot, OverloadedStrings, RecordWildCards, TypeApplications #-} +module Curry.LanguageServer.Extension + ( ExtensionPoint (..), ExtensionOutputFormat (..), Extension (..) + ) where + +import Data.Aeson (FromJSON (..), ToJSON (..), (.:?), (.!=), (.=), object, withObject) +import Data.Default (Default (..)) +import qualified Data.Text as T + +data ExtensionPoint = ExtensionPointHover + | ExtensionPointUnknown T.Text + deriving (Show, Eq) + +data ExtensionOutputFormat = ExtensionOutputFormatPlaintext + | ExtensionOutputFormatMarkdown + | ExtensionOutputFormatUnknown T.Text + deriving (Show, Eq) + +data Extension = Extension + { name :: T.Text + , extensionPoint :: ExtensionPoint + , outputFormat :: ExtensionOutputFormat + , showOutputOnError :: Bool + , executable :: T.Text + , args :: [T.Text] + } + deriving (Show, Eq) + +instance Default Extension where + def = Extension + { name = "Anonymous Extension" + , extensionPoint = ExtensionPointHover + , outputFormat = ExtensionOutputFormatPlaintext + , showOutputOnError = False + , executable = "echo" + , args = [] + } + +instance FromJSON Extension where + parseJSON = withObject "Extension" $ \e -> do + name <- e .:? "name" .!= (def @Extension).name + extensionPoint <- e .:? "extensionPoint" .!= (def @Extension).extensionPoint + outputFormat <- e .:? "outputFormat" .!= (def @Extension).outputFormat + showOutputOnError <- e .:? "showOutputOnError" .!= (def @Extension).showOutputOnError + executable <- e .:? "executable" .!= (def @Extension).executable + args <- e .:? "args" .!= (def @Extension).args + return Extension {..} + +instance ToJSON Extension where + toJSON Extension {..} = object + [ "name" .= name + , "extensionPoint" .= extensionPoint + , "outputFormat" .= outputFormat + , "showOutputOnError" .= showOutputOnError + , "executable" .= executable + , "args" .= args + ] + +instance FromJSON ExtensionPoint where + parseJSON v = do + s <- parseJSON v + return $ case s :: T.Text of + "hover" -> ExtensionPointHover + _ -> ExtensionPointUnknown s + +instance ToJSON ExtensionPoint where + toJSON p = toJSON @T.Text $ case p of + ExtensionPointHover -> "hover" + ExtensionPointUnknown s -> s + +instance FromJSON ExtensionOutputFormat where + parseJSON v = do + s <- parseJSON v + return $ case s :: T.Text of + "plaintext" -> ExtensionOutputFormatPlaintext + "markdown" -> ExtensionOutputFormatMarkdown + _ -> ExtensionOutputFormatUnknown s + +instance ToJSON ExtensionOutputFormat where + toJSON p = toJSON @T.Text $ case p of + ExtensionOutputFormatPlaintext -> "plaintext" + ExtensionOutputFormatMarkdown -> "markdown" + ExtensionOutputFormatUnknown s -> s diff --git a/src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs b/src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs index ee80d5d..bb64e86 100644 --- a/src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs +++ b/src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs @@ -1,32 +1,37 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot, TypeOperators, ViewPatterns #-} +{-# LANGUAGE FlexibleContexts, NumericUnderscores, OverloadedStrings, OverloadedRecordDot, TypeOperators, ViewPatterns #-} +{-# OPTIONS_GHC -Wno-deprecations #-} module Curry.LanguageServer.Handlers.TextDocument.Hover (hoverHandler) where --- Curry Compiler Libraries + Dependencies - import Control.Applicative ((<|>)) import Control.Lens ((^.)) +import Control.Monad.Extra (mapMaybeM) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..)) import qualified Curry.LanguageServer.Config as CFG import qualified Curry.LanguageServer.Index.Store as I import qualified Curry.LanguageServer.Index.Symbol as I -import Curry.LanguageServer.Utils.Convert (ppPredTypeToText, currySpanInfo2Range) +import Curry.LanguageServer.Extension (ExtensionPoint (..), ExtensionOutputFormat (..), Extension (..)) +import Curry.LanguageServer.Utils.Convert (ppPredTypeToText, currySpanInfo2Range, ppToText) import Curry.LanguageServer.Index.Resolve (resolveAtPos) import Curry.LanguageServer.Utils.General (liftMaybe) import Curry.LanguageServer.Utils.Logging (debugM, infoM) import Curry.LanguageServer.Utils.Lookup (findTypeAtPos) +import Curry.LanguageServer.Index.Symbol (symbolParentIdent) import Curry.LanguageServer.Utils.Syntax (moduleIdentifier) import Curry.LanguageServer.Utils.Sema (ModuleAST, TypedSpanInfo (..)) -import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath) +import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath, uriToFilePath) import Curry.LanguageServer.Monad (LSM, getStore) -import Data.Maybe (listToMaybe) +import Data.Maybe (listToMaybe, maybeToList, fromMaybe) import qualified Data.Text as T import qualified Language.LSP.Server as S import qualified Language.LSP.Protocol.Types as J import qualified Language.LSP.Protocol.Lens as J import qualified Language.LSP.Protocol.Message as J import Language.LSP.Server (MonadLsp) +import System.Exit (ExitCode (..)) +import System.Process (readCreateProcessWithExitCode, proc) +import System.Timeout (timeout) hoverHandler :: S.Handlers LSM hoverHandler = S.requestHandler J.SMethod_TextDocumentHover $ \req responder -> do @@ -37,13 +42,16 @@ hoverHandler = S.requestHandler J.SMethod_TextDocumentHover $ \req responder -> store <- getStore hover <- runMaybeT $ do entry <- I.getModule normUri - MaybeT $ fetchHover store entry pos + MaybeT $ fetchHover store entry pos uri responder $ Right $ maybe (J.InR J.Null) J.InL hover -fetchHover :: (MonadIO m, MonadLsp CFG.Config m) => I.IndexStore -> I.ModuleStoreEntry -> J.Position -> m (Maybe J.Hover) -fetchHover store entry pos = runMaybeT $ do +fetchHover :: (MonadIO m, MonadLsp CFG.Config m) => I.IndexStore -> I.ModuleStoreEntry -> J.Position -> J.Uri -> m (Maybe J.Hover) +fetchHover store entry pos uri = runMaybeT $ do ast <- liftMaybe entry.moduleAST - hover <- liftMaybe $ qualIdentHover store ast pos <|> typedSpanInfoHover ast pos + cfg <- lift S.getConfig + let baseHover = maybeToList $ qualIdentHover store ast pos <|> typedSpanInfoHover ast pos + extHovers <- mapMaybeM (extensionHover store ast pos uri) cfg.extensions + hover <- liftMaybe . joinHovers $ baseHover ++ extHovers lift $ infoM $ "Found hover: " <> previewHover hover return hover @@ -65,10 +73,93 @@ typedSpanInfoHover ast@(moduleIdentifier -> mid) pos = do return $ J.Hover contents range +extensionHover :: MonadIO m => I.IndexStore -> ModuleAST -> J.Position -> J.Uri -> Extension -> m (Maybe J.Hover) +extensionHover store ast@(moduleIdentifier -> mid) pos@(J.Position l c) uri e = case e.extensionPoint of + ExtensionPointHover -> runMaybeT $ do + let symbol = listToMaybe . fst =<< resolveAtPos store ast pos + timeoutSecs = 10 + timeoutMicros = timeoutSecs * 1_000_000 + templateParams = [ ("currentFile", T.pack (fromMaybe "" (uriToFilePath uri))) + , ("currentUri", J.getUri uri) + , ("currentModule", ppToText mid) + , ("line", T.pack (show l)) + , ("column", T.pack (show c)) + , ("type", fromMaybe "" ((.printedType) =<< symbol)) + , ("identifier", maybe "" (.ident) symbol) + , ("module", maybe "" symbolParentIdent symbol) + ] :: [(T.Text, T.Text)] + applyParam p = T.replace ("{" <> p <> "}") + evalTemplate t = foldr (uncurry applyParam) t templateParams + procOpts = proc (T.unpack e.executable) (T.unpack . (evalTemplate :: T.Text -> T.Text) <$> e.args) + + (exitCode, out, err) <- MaybeT $ liftIO $ timeout timeoutMicros $ readCreateProcessWithExitCode procOpts "" + + let simpleCodeBlock t + | T.null t = "" + | otherwise = "```\n" <> t <> "\n```" + + text <- case exitCode of + ExitSuccess -> return $ T.unlines + [ "**" <> e.name <> "**" + , "" + , case e.outputFormat of + ExtensionOutputFormatMarkdown -> T.pack out + _ -> simpleCodeBlock (T.pack out) + ] + _ | e.showOutputOnError -> return $ T.unlines + [ "_Extension **" <> e.name <> "** exited with " <> T.pack (show exitCode) <> "_" + , "" + , simpleCodeBlock (T.pack err) + ] + | otherwise -> liftMaybe Nothing + + let contents = J.InL $ J.MarkupContent J.MarkupKind_Markdown text + + return $ J.Hover contents Nothing + _ -> return Nothing + previewHover :: J.Hover -> T.Text -previewHover ((^. J.contents) -> J.InL (J.MarkupContent k t)) = case k of J.MarkupKind_Markdown -> markdownToPlain t - J.MarkupKind_PlainText -> t -previewHover _ = "?" +previewHover = T.unlines . (previewMarkupContent <$>) . normalizeHoverContents . (^. J.contents) + +previewMarkupContent :: J.MarkupContent -> T.Text +previewMarkupContent (J.MarkupContent k t) = case k of + J.MarkupKind_Markdown -> markdownToPlain t + J.MarkupKind_PlainText -> t + +joinHovers :: [J.Hover] -> Maybe J.Hover +joinHovers [] = Nothing +joinHovers hs = Just $ foldr1 mergeHovers hs + +mergeHovers :: J.Hover -> J.Hover -> J.Hover +mergeHovers (J.Hover (normalizeHoverContents -> cs1) r1) (J.Hover (normalizeHoverContents -> cs2) r2) = + J.Hover (J.InL (joinMarkupContent (cs1 ++ cs2))) (r1 <|> r2) + +joinMarkupContent :: [J.MarkupContent] -> J.MarkupContent +joinMarkupContent [] = emptyMarkupContent +joinMarkupContent cs = foldr1 mergeMarkupContent cs + +mergeMarkupContent :: J.MarkupContent -> J.MarkupContent -> J.MarkupContent +mergeMarkupContent (normalizeToMarkdown -> J.MarkupContent _ t1) (normalizeToMarkdown -> J.MarkupContent _ t2) = + J.MarkupContent J.MarkupKind_Markdown $ T.unlines [t1, "", "---", "", t2] + +emptyMarkupContent :: J.MarkupContent +emptyMarkupContent = J.MarkupContent J.MarkupKind_PlainText "" + +normalizeToMarkdown :: J.MarkupContent -> J.MarkupContent +normalizeToMarkdown (J.MarkupContent k t) = case k of + J.MarkupKind_Markdown -> J.MarkupContent k t + J.MarkupKind_PlainText -> J.mkMarkdownCodeBlock "text" t + +normalizeHoverContents :: J.MarkupContent J.|? (J.MarkedString J.|? [J.MarkedString]) -> [J.MarkupContent] +normalizeHoverContents m = case m of + J.InL c -> [c] + J.InR (J.InL s) -> [markedStringToContent s] + J.InR (J.InR ss) -> markedStringToContent <$> ss + +markedStringToContent :: J.MarkedString -> J.MarkupContent +markedStringToContent (J.MarkedString m) = case m of + J.InL t -> J.MarkupContent J.MarkupKind_PlainText t + J.InR (J.MarkedStringWithLanguage l t) -> J.mkMarkdownCodeBlock l t markdownToPlain :: T.Text -> T.Text markdownToPlain t = T.intercalate ", " $ filter includeLine $ T.lines t diff --git a/src/Curry/LanguageServer/Utils/Sema.hs b/src/Curry/LanguageServer/Utils/Sema.hs index 34f319d..04fa9f3 100644 --- a/src/Curry/LanguageServer/Utils/Sema.hs +++ b/src/Curry/LanguageServer/Utils/Sema.hs @@ -27,7 +27,11 @@ untypedTopLevelDecls (CS.Module _ _ _ _ _ _ decls) = untypedDecls where typeSigIdents = S.fromList [i | CS.TypeSig _ is _ <- decls, i <- is] untypedDecls = [(spi, i, t) | CS.FunctionDecl spi t i _ <- decls, i `S.notMember` typeSigIdents] -data TypedSpanInfo a = TypedSpanInfo T.Text a CSPI.SpanInfo +data TypedSpanInfo a = TypedSpanInfo + { exprText :: T.Text + , typeAnnotation :: a + , spanInfo :: CSPI.SpanInfo + } deriving (Show, Eq) class HasTypedSpanInfos e a where