diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs index 7fb9264422..0dd10fc9a3 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs @@ -79,9 +79,9 @@ import qualified Outputable as Out import SrcLoc #endif #if MIN_VERSION_ghc(9,3,0) -import GHC.Utils.Logger -import GHC.Driver.Config.Diagnostic -import Data.Maybe +import Data.Maybe +import GHC.Driver.Config.Diagnostic +import GHC.Utils.Logger #endif -- | A compatible function to print `Outputable` instances diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index 8dd99b8bde..69cc2adf77 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -81,6 +81,7 @@ import GHC.IO.Exception import GHC.IO.Handle.Internals import GHC.IO.Handle.Types import GHC.Stack +import Ide.PluginUtils (unescape) import System.Environment.Blank (getEnvDefault) import System.FilePath import System.IO.Unsafe @@ -287,10 +288,17 @@ instance Outputable SDoc where #endif -- | Print a GHC value in `defaultUserStyle` without unique symbols. +-- It uses `showSDocUnsafe` with `unsafeGlobalDynFlags` internally. -- --- This is the most common print utility, will print with a user-friendly style like: `a_a4ME` as `a`. +-- This is the most common print utility. +-- It will do something additionally compared to what the 'Outputable' instance does. -- --- It internal using `showSDocUnsafe` with `unsafeGlobalDynFlags`. +-- 1. print with a user-friendly style: `a_a4ME` as `a`. +-- 2. unescape escape sequences of printable unicode characters within a pair of double quotes printOutputable :: Outputable a => a -> T.Text -printOutputable = T.pack . printWithoutUniques +printOutputable = + -- IfaceTyLit from GHC.Iface.Type implements Outputable with 'show'. + -- Showing a String escapes non-ascii printable characters. We unescape it here. + -- More discussion at https://github.com/haskell/haskell-language-server/issues/3115. + unescape . T.pack . printWithoutUniques {-# INLINE printOutputable #-} diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 4b451bda42..217e7ae30f 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -56,6 +56,7 @@ library , text , transformers , unordered-containers + , megaparsec > 9 if os(windows) build-depends: Win32 @@ -91,4 +92,5 @@ test-suite tests , tasty , tasty-hunit , tasty-rerun + , text , lsp-types diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 7f8b1c2a7f..5c93407974 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -32,6 +32,7 @@ module Ide.PluginUtils handleMaybe, handleMaybeM, throwPluginError, + unescape, ) where @@ -43,10 +44,12 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import Data.Bifunctor (Bifunctor (first)) +import Data.Char (isPrint, showLitChar) +import Data.Functor (void) import qualified Data.HashMap.Strict as H -import Data.List (find) import Data.String (IsString (fromString)) import qualified Data.Text as T +import Data.Void (Void) import Ide.Plugin.Config import Ide.Plugin.Properties import Ide.Types @@ -57,6 +60,9 @@ import Language.LSP.Types hiding SemanticTokensEdit (_start)) import qualified Language.LSP.Types as J import Language.LSP.Types.Capabilities +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import qualified Text.Megaparsec.Char.Lexer as P -- --------------------------------------------------------------------- @@ -255,3 +261,34 @@ pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a) pluginResponse = fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) . runExceptT + +-- --------------------------------------------------------------------- + +type TextParser = P.Parsec Void T.Text + +-- | Unescape printable escape sequences within double quotes. +-- This is useful if you have to call 'show' indirectly, and it escapes some characters which you would prefer to +-- display as is. +unescape :: T.Text -> T.Text +unescape input = + case P.runParser escapedTextParser "inline" input of + Left _ -> input + Right strs -> T.pack strs + +-- | Parser for a string that contains double quotes. Returns unescaped string. +escapedTextParser :: TextParser String +escapedTextParser = concat <$> P.many (outsideStringLiteral P.<|> stringLiteral) + where + outsideStringLiteral :: TextParser String + outsideStringLiteral = P.someTill (P.anySingleBut '"') (P.lookAhead (void (P.char '"') P.<|> P.eof)) + + stringLiteral :: TextParser String + stringLiteral = do + inside <- P.char '"' >> P.manyTill P.charLiteral (P.char '"') + let f '"' = "\\\"" -- double quote should still be escaped + -- Despite the docs, 'showLitChar' and 'showLitString' from 'Data.Char' DOES ESCAPE unicode printable + -- characters. So we need to call 'isPrint' from 'Data.Char' manually. + f ch = if isPrint ch then [ch] else showLitChar ch "" + inside' = concatMap f inside + + pure $ "\"" <> inside' <> "\"" diff --git a/hls-plugin-api/test/Ide/PluginUtilsTest.hs b/hls-plugin-api/test/Ide/PluginUtilsTest.hs index f868a067d1..bad3c1dfbc 100644 --- a/hls-plugin-api/test/Ide/PluginUtilsTest.hs +++ b/hls-plugin-api/test/Ide/PluginUtilsTest.hs @@ -1,13 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + module Ide.PluginUtilsTest ( tests ) where -import Ide.PluginUtils (positionInRange) +import Data.Char (isPrint) +import qualified Data.Text as T +import Ide.PluginUtils (positionInRange, unescape) import Language.LSP.Types (Position (Position), Range (Range)) import Test.Tasty import Test.Tasty.HUnit tests :: TestTree tests = testGroup "PluginUtils" - [ + [ unescapeTest + ] + +unescapeTest :: TestTree +unescapeTest = testGroup "unescape" + [ testCase "no double quote" $ + unescape "hello世界" @?= "hello世界" + , testCase "whole string quoted" $ + unescape "\"hello\\19990\\30028\"" @?= "\"hello世界\"" + , testCase "text before quotes should not be unescaped" $ + unescape "\\19990a\"hello\\30028\"" @?= "\\19990a\"hello界\"" + , testCase "some text after quotes" $ + unescape "\"hello\\19990\\30028\"abc" @?= "\"hello世界\"abc" + , testCase "many pairs of quote" $ + unescape "oo\"hello\\19990\\30028\"abc\"\1087\1088\1080\1074\1077\1090\"hh" @?= "oo\"hello世界\"abc\"привет\"hh" + , testCase "double quote itself should not be unescaped" $ + unescape "\"\\\"\\19990o\"" @?= "\"\\\"世o\"" + , testCase "control characters should not be escaped" $ + unescape "\"\\n\\t\"" @?= "\"\\n\\t\"" ]