Skip to content

Commit

Permalink
colored hovers
Browse files Browse the repository at this point in the history
  • Loading branch information
@TimWhiting
TimWhiting committed Dec 5, 2023
1 parent 895f01e commit d2654d0
Show file tree
Hide file tree
Showing 6 changed files with 144 additions and 44 deletions.
2 changes: 1 addition & 1 deletion src/LanguageServer/Handler/Completion.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -167,7 +167,7 @@ typeUnifies :: Type -> Maybe Type -> Bool
typeUnifies t1 t2 =
case t2 of
Nothing -> True
Just t2 -> let (res, _, _) = (runUnifyEx 0 $ matchArguments True rangeNull tvsEmpty t1 [t2] []) in isRight res
Just t2 -> let (res, _, _) = (runUnifyEx 0 $ matchArguments True rangeNull tvsEmpty t1 [t2] [] Nothing) in isRight res

valueCompletions :: Name -> Gamma -> PositionInfo -> [J.CompletionItem]
valueCompletions curModName gamma pinfo@PositionInfo{argumentType=tp, searchTerm=search, isFunctionCompletion} = map toItem . filter matchInfo $ filter (\(n, ni) -> filterInfix pinfo $ T.pack $ nameId n) $ gammaList gamma
Expand Down
59 changes: 37 additions & 22 deletions src/LanguageServer/Handler/Hover.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
-- The LSP handler that provides hover tooltips
-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module LanguageServer.Handler.Hover (hoverHandler, formatRangeInfoHover) where

Expand All @@ -13,39 +14,53 @@ import Language.LSP.Server (Handlers, sendNotification, requestHandler)
import qualified Language.LSP.Protocol.Types as J
import qualified Language.LSP.Protocol.Lens as J
import LanguageServer.Conversions (fromLspPos, toLspRange)
import LanguageServer.Monad (LSM, getLoaded, getLoadedModule)
import Lib.PPrint (Pretty (..))
import LanguageServer.Monad (LSM, getLoaded, getLoadedModule, getHtmlPrinter, getFlags)
import Lib.PPrint (Pretty (..), Doc, text, (<+>), color)
import Syntax.RangeMap (NameInfo (..), RangeInfo (..), rangeMapFindAt)
import qualified Language.LSP.Protocol.Message as J
import Control.Monad.Cont (liftIO)
import Type.Pretty (ppScheme, defaultEnv, Env(..))
import Common.ColorScheme (ColorScheme (colorNameQual))
import Kind.Pretty (prettyKind)
import Common.Name (nameNil)
import Kind.ImportMap (importsEmpty)
import Compiler.Options (Flags, colorSchemeFromFlags, prettyEnvFromFlags)

hoverHandler :: Handlers LSM
hoverHandler = requestHandler J.SMethod_TextDocumentHover $ \req responder -> do
let J.HoverParams doc pos _ = req ^. J.params
uri = doc ^. J.uri
loaded <- getLoadedModule uri
let rsp = do
flags <- getFlags
let res = do
l <- loaded
rmap <- modRangeMap l
(r, rinfo) <- rangeMapFindAt (fromLspPos uri pos) rmap
let hc = J.InL $ J.mkMarkdown $ T.pack $ formatRangeInfoHover rinfo
hover = J.Hover hc $ Just $ toLspRange r
return hover
case rsp of
rangeMapFindAt (fromLspPos uri pos) rmap
case res of
Just (r, rinfo) -> do
print <- getHtmlPrinter
x <- liftIO $ formatRangeInfoHover print flags rinfo
let hc = J.InL $ J.mkMarkdown x
rsp = J.Hover hc $ Just $ toLspRange r
responder $ Right $ J.InL rsp
Nothing -> responder $ Right $ J.InR J.Null
Just rsp -> responder $ Right $ J.InL rsp

prettyEnv flags ctx imports = (prettyEnvFromFlags flags){ context = ctx, importsMap = imports }

-- Pretty-prints type/kind information to a hover tooltip
formatRangeInfoHover :: RangeInfo -> String
formatRangeInfoHover rinfo = case rinfo of
formatRangeInfoHover :: (Doc -> IO T.Text) -> Flags -> RangeInfo -> IO T.Text
formatRangeInfoHover print flags rinfo =
let colors = colorSchemeFromFlags flags in
case rinfo of
Id qname info isdef ->
show (pretty qname) ++ " : " ++ case info of
NIValue tp -> show $ pretty tp
NICon tp -> show $ pretty tp
NITypeCon k -> show $ pretty k
NITypeVar k -> show $ pretty k
NIModule -> "module"
NIKind -> "kind"
Decl s name mname -> s ++ " " ++ show (pretty name)
Block s -> s
Error doc -> "Error: " ++ show doc
Warning doc -> "Warning: " ++ show doc
print $ (color (colorNameQual colors) $ pretty qname) <+> text " : " <+> case info of
NIValue tp -> ppScheme (prettyEnv flags nameNil importsEmpty) tp
NICon tp -> ppScheme (prettyEnv flags nameNil importsEmpty) tp
NITypeCon k -> prettyKind colors k
NITypeVar k -> prettyKind colors k
NIModule -> text "module"
NIKind -> text "kind"
Decl s name mname -> print $ text s <+> text " " <+> pretty name
Block s -> return $ T.pack s
Error doc -> print $ text "Error: " <+> doc
Warning doc -> print $ text "Warning: " <+> doc
26 changes: 21 additions & 5 deletions src/LanguageServer/Monad.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,8 @@ module LanguageServer.Monad
getLoaded,
putLoaded,removeLoaded,
getLoadedModule,
getColorScheme,
getHtmlPrinter,
runLSM,
)
where
Expand All @@ -31,15 +33,15 @@ import qualified Language.LSP.Protocol.Types as J
import qualified Language.LSP.Protocol.Message as J

import Compiler.Compile (Terminal (..), Loaded (..), Module (..))
import Lib.PPrint (Pretty(..), asString, writePrettyLn)
import Lib.PPrint (Pretty(..), asString, writePrettyLn, Doc)
import Control.Concurrent.Chan (readChan)
import Type.Pretty (ppType, defaultEnv, Env (context, importsMap), ppScheme)
import qualified Language.LSP.Server as J
import GHC.Base (Type)
import Lib.Printer (withColorPrinter, withColor, writeLn, ansiDefault, AnsiStringPrinter (AnsiString), Color (Red), ColorPrinter (PAnsiString))
import Lib.Printer (withColorPrinter, withColor, writeLn, ansiDefault, AnsiStringPrinter (AnsiString), Color (Red), ColorPrinter (PAnsiString, PHtmlText), withHtmlTextPrinter, HtmlTextPrinter (..))
import Compiler.Options (Flags (..), prettyEnvFromFlags, verbose)
import Common.Error (ppErrorMessage)
import Common.ColorScheme (colorSource)
import Common.ColorScheme (colorSource, ColorScheme)
import Common.Name (nameNil)
import Kind.ImportMap (importsEmpty)
import Platform.Var (newVar, takeVar)
Expand All @@ -62,6 +64,7 @@ data LSState = LSState {
messages :: TChan (String, J.MessageType),
flags:: Flags,
terminal:: Terminal,
htmlPrinter :: Doc -> IO T.Text,
pendingRequests :: TVar (Set.Set J.SomeLspId),
cancelledRequests :: TVar (Set.Set J.SomeLspId),
documentVersions :: TVar (M.Map J.Uri J.Int32),
Expand All @@ -70,6 +73,14 @@ data LSState = LSState {
trimnl :: [Char] -> [Char]
trimnl str = reverse $ dropWhile (`elem` "\n\r\t ") $ reverse str

htmlTextColorPrinter :: Doc -> IO T.Text
htmlTextColorPrinter doc
= do
stringVar <- newVar (T.pack "")
let printer = PHtmlText (HtmlTextPrinter stringVar)
writePrettyLn printer doc
takeVar stringVar

defaultLSState :: Flags -> IO LSState
defaultLSState flags = do
msgChan <- atomically newTChan :: IO (TChan (String, J.MessageType))
Expand All @@ -83,7 +94,6 @@ defaultLSState flags = do
tp <- (f . PAnsiString) p
ansiString <- takeVar stringVar
atomically $ writeTChan msgChan (trimnl ansiString, tp)

let cscheme = colorScheme flags
prettyEnv flags ctx imports = (prettyEnvFromFlags flags){ context = ctx, importsMap = imports }
term = Terminal (\err -> withNewPrinter $ \p -> do putErrorMessage p (showSpan flags) cscheme err; return J.MessageType_Error)
Expand All @@ -92,7 +102,7 @@ defaultLSState flags = do
(if verbose flags > 0 then (\msg -> withNewPrinter $ \p -> do writePrettyLn p msg; return J.MessageType_Info) else (\_ -> return ()))
(\tp -> withNewPrinter $ \p -> do putScheme p (prettyEnv flags nameNil importsEmpty) tp; return J.MessageType_Info)
(\msg -> withNewPrinter $ \p -> do writePrettyLn p msg; return J.MessageType_Info)
return LSState {lsLoaded = Nothing, messages = msgChan, terminal = term, flags = flags, pendingRequests=pendingRequests, cancelledRequests=cancelledRequests, documentInfos = M.empty, documentVersions = fileVersions}
return LSState {lsLoaded = Nothing, messages = msgChan, terminal = term, htmlPrinter = htmlTextColorPrinter, flags = flags, pendingRequests=pendingRequests, cancelledRequests=cancelledRequests, documentInfos = M.empty, documentVersions = fileVersions}

putScheme p env tp
= writePrettyLn p (ppScheme env tp)
Expand Down Expand Up @@ -132,6 +142,12 @@ getLoaded = lsLoaded <$> getLSState
getFlags :: LSM Flags
getFlags = flags <$> getLSState

getHtmlPrinter :: LSM (Doc -> IO T.Text)
getHtmlPrinter = htmlPrinter <$> getLSState

getColorScheme :: LSM ColorScheme
getColorScheme = colorScheme <$> getFlags

-- Replaces the loaded state holding compiled modules
putLoaded :: Loaded -> LSM ()
putLoaded l = modifyLSState $ \s -> s {lsLoaded = case lsLoaded s of {Nothing -> Just l; Just l' -> Just $ mergeLoaded l l'}}
Expand Down
95 changes: 80 additions & 15 deletions src/Lib/Printer.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,9 +22,9 @@ module Lib.Printer(
, MonoPrinter, withMonoPrinter
, ColorPrinter(..), withColorPrinter, withNoColorPrinter, withFileNoColorPrinter, isAnsiPrinter, isConsolePrinter
, AnsiPrinter, withAnsiPrinter
, AnsiStringPrinter(..)
, AnsiStringPrinter(..), HtmlTextPrinter(..)
, withFilePrinter, withNewFilePrinter
, withHtmlPrinter, withHtmlColorPrinter
, withHtmlPrinter, withHtmlColorPrinter, withHtmlTextPrinter
-- * Misc.
, ansiWithColor
, ansiDefault
Expand Down Expand Up @@ -359,6 +359,7 @@ data ColorPrinter = PCon ConsolePrinter
| PMono MonoPrinter
| PFile FilePrinter
| PHTML HtmlPrinter
| PHtmlText HtmlTextPrinter

-- | Use a color-enabled printer.
withColorPrinter :: (ColorPrinter -> IO b) -> IO b
Expand Down Expand Up @@ -401,26 +402,27 @@ isConsolePrinter cp


instance Printer ColorPrinter where
write p s = cmap p write write write write write write s
writeLn p s = cmap p writeLn writeLn writeLn writeLn writeLn writeLn s
flush p = cmap p flush flush flush flush flush flush
withColor p c io = cmap p withColor withColor withColor withColor withColor withColor c io
withBackColor p c io = cmap p withBackColor withBackColor withBackColor withBackColor withBackColor withBackColor c io
withReverse p r io = cmap p withReverse withReverse withReverse withReverse withReverse withReverse r io
withUnderline p u io = cmap p withUnderline withUnderline withUnderline withUnderline withUnderline withUnderline u io
setColor p c = cmap p setColor setColor setColor setColor setColor setColor c
setBackColor p c = cmap p setBackColor setBackColor setBackColor setBackColor setBackColor setBackColor c
setReverse p r = cmap p setReverse setReverse setReverse setReverse setReverse setReverse r
setUnderline p u = cmap p setUnderline setUnderline setUnderline setUnderline setUnderline setUnderline u

cmap p f g h i j k
write p s = cmap p write write write write write write write s
writeLn p s = cmap p writeLn writeLn writeLn writeLn writeLn writeLn writeLn s
flush p = cmap p flush flush flush flush flush flush flush
withColor p c io = cmap p withColor withColor withColor withColor withColor withColor withColor c io
withBackColor p c io = cmap p withBackColor withBackColor withBackColor withBackColor withBackColor withBackColor withBackColor c io
withReverse p r io = cmap p withReverse withReverse withReverse withReverse withReverse withReverse withReverse r io
withUnderline p u io = cmap p withUnderline withUnderline withUnderline withUnderline withUnderline withUnderline withUnderline u io
setColor p c = cmap p setColor setColor setColor setColor setColor setColor setColor c
setBackColor p c = cmap p setBackColor setBackColor setBackColor setBackColor setBackColor setBackColor setBackColor c
setReverse p r = cmap p setReverse setReverse setReverse setReverse setReverse setReverse setReverse r
setUnderline p u = cmap p setUnderline setUnderline setUnderline setUnderline setUnderline setUnderline setUnderline u

cmap p f g h i j k l
= case p of
PCon cp -> f cp
PAnsi ap -> g ap
PMono mp -> h mp
PFile fp -> i fp
PHTML hp -> j hp
PAnsiString as -> k as
PHtmlText ht -> l ht


{--------------------------------------------------------------------------
Expand Down Expand Up @@ -469,6 +471,39 @@ instance Printer HtmlPrinter where
setReverse p r = return ()
setUnderline p u = return ()


{--------------------------------------------------------------------------
HTML Text printer
--------------------------------------------------------------------------}
data HtmlTextPrinter = HtmlTextPrinter (Var T.Text)

withHtmlTextPrinter :: (HtmlTextPrinter -> IO a) -> IO a
withHtmlTextPrinter f
= do
stringVar <- newVar (T.pack "")
f (HtmlTextPrinter stringVar)

addHtml :: HtmlTextPrinter -> T.Text -> IO ()
addHtml (HtmlTextPrinter stringVar) s = do
old <- takeVar stringVar
putVar stringVar (old <> s)

instance Printer HtmlTextPrinter where
write p s = addHtml p $ T.pack $ htmlEscape s
writeText p s = addHtml p s
writeLn p s = addHtml p $ T.pack $ htmlEscape (s ++ "\n")
writeTextLn p s = addHtml p (s <> T.pack "\n")
flush p = return ()
withColor p c io = htmlTextSpan p (T.pack "color") (htmlColor2 c) io
withBackColor p c io = htmlTextSpan p (T.pack "background-color") (htmlColor2 c) io
withReverse p r io = {- no supported -} io
withUnderline p u io = htmlTextSpan p (T.pack "text-decoration") (T.pack "underline") io
setColor p c = return ()
setBackColor p c = return ()
setReverse p r = return ()
setUnderline p u = return ()


htmlSpan :: T.Text -> T.Text -> IO a -> IO a
htmlSpan prop val io
= do T.putStr $ T.pack "<span style='"
Expand All @@ -480,12 +515,42 @@ htmlSpan prop val io
T.putStr $ T.pack "</span>"
return x

htmlTextSpan :: HtmlTextPrinter -> T.Text -> T.Text -> IO a -> IO a
htmlTextSpan p prop val io
= do
addHtml p (T.pack "<span style='" <> prop <> T.pack ":" <> val <> T.pack ";'>")
x <- io
addHtml p (T.pack "</span>")
return x

htmlColor :: Color -> T.Text
htmlColor c
= case c of
ColorDefault -> T.pack "black"
_ -> T.toLower (T.pack $ show c)

-- VSCode sanitizes spans to only allow colors with hex codes
htmlColor2 :: Color -> T.Text
htmlColor2 c
= case c of
ColorDefault -> T.pack "#000000"
Black -> T.pack "#000000"
White -> T.pack "#ffffff"
DarkRed -> T.pack "#8B0000"
DarkGreen -> T.pack "#006400"
DarkYellow -> T.pack "#8B8000"
DarkBlue -> T.pack "#00008B"
DarkMagenta -> T.pack "#8B008B"
DarkCyan -> T.pack "#008B8B"
Gray -> T.pack "#808080"
DarkGray -> T.pack "#A9A9A9"
Red -> T.pack "#FF0000"
Green -> T.pack "#008000"
Yellow -> T.pack "#FFFF00"
Blue -> T.pack "#0000FF"
Magenta -> T.pack "#FF00FF"
Cyan -> T.pack "#00FFFF"

htmlEscape s
= concatMap escape s
where
Expand Down
2 changes: 1 addition & 1 deletion support/vscode/koka.language-koka/package.json
View file
Original file line number Diff line number Diff line change
Expand Up @@ -211,7 +211,7 @@
"devDependencies": {
"@types/node": "^20.5.6",
"@types/vscode": "1.81.0",
"@vscode/vsce": "^2.20.1",
"@vscode/vsce": "^2.22.0",
"typescript": "^5.2.2"
},
"dependencies": {
Expand Down
4 changes: 4 additions & 0 deletions support/vscode/koka.language-koka/src/extension.ts
View file
Original file line number Diff line number Diff line change
Expand Up @@ -154,6 +154,10 @@ class KokaLanguageServer {
documentSelector: [{ language: 'koka', scheme: 'file' }],
outputChannel: this.outputChannel,
revealOutputChannelOn: RevealOutputChannelOn.Never,
markdown: {
isTrusted: true,
supportHtml: true,
}
}
this.languageClient = new LanguageClient(
'Koka Language Client',
Expand Down

0 comments on commit d2654d0

Please sign in to comment.