Merge pull request #77 from fwcd/extensions

Add support for hover extensions

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

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

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

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

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