colored hovers

src/LanguageServer/Handler/Completion.hs

@@ -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

src/LanguageServer/Handler/Hover.hs

@@ -14,42 +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, getHtmlPrinter)
-import Lib.PPrint (Pretty (..), Doc, text, (<+>))
+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
+  flags <- getFlags
   let res = do
         l <- loaded
         rmap <- modRangeMap l
         rangeMapFindAt (fromLspPos uri pos) rmap
   case res of
     Just (r, rinfo) -> do
       print <- getHtmlPrinter
-      x <- liftIO $ formatRangeInfoHover print rinfo
+      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
 
+prettyEnv flags ctx imports = (prettyEnvFromFlags flags){ context = ctx, importsMap = imports }
+
 -- Pretty-prints type/kind information to a hover tooltip
-formatRangeInfoHover :: (Doc -> IO T.Text) -> RangeInfo -> IO T.Text
-formatRangeInfoHover print 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 ->
-    print $ pretty qname <+> text " : " <+> case info of
-      NIValue tp -> pretty tp
-      NICon tp -> pretty tp
-      NITypeCon k -> pretty k
-      NITypeVar k -> pretty k
+    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 -> return $ T.pack $ s ++ " " ++ show (pretty name)
+  Decl s name mname -> print $ text s <+> text " " <+> pretty name
   Block s -> return $ T.pack s
-  Error doc -> return $ T.pack $ "Error: " ++ show doc
-  Warning doc -> return $ T.pack $ "Warning: " ++ show doc
+  Error doc -> print $ text "Error: " <+> doc
+  Warning doc -> print $ text "Warning: " <+> doc

src/LanguageServer/Monad.hs

@@ -17,6 +17,7 @@ module LanguageServer.Monad
     getLoaded,
     putLoaded,removeLoaded,
     getLoadedModule,
+    getColorScheme,
     getHtmlPrinter,
     runLSM,
   )
@@ -40,7 +41,7 @@ import GHC.Base (Type)
 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)
@@ -144,6 +145,9 @@ 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'}}

src/Lib/Printer.hs

@@ -491,11 +491,11 @@ addHtml (HtmlTextPrinter stringVar) s = do
 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
-  writeTextLn 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") (htmlColor c) io
-  withBackColor p c io  = htmlTextSpan p (T.pack "background-color") (htmlColor c) io
+  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 ()
@@ -518,7 +518,7 @@ htmlSpan prop val io
 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 "'>")
+    addHtml p (T.pack "<span style='" <> prop <> T.pack ":" <> val <> T.pack ";'>")
     x <- io
     addHtml p (T.pack "</span>")
     return x
@@ -529,6 +529,28 @@ htmlColor c
       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

support/vscode/koka.language-koka/package.json

@@ -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": {

support/vscode/koka.language-koka/src/extension.ts

@@ -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',