Skip to content

Commit 6f9a903

Browse files
soulomoonsoulomoon
committed
use customize logger, add test for unicode
1 parent dc8fd6d commit 6f9a903

File tree

7 files changed

+64
-29
lines changed

7 files changed

+64
-29
lines changed

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -2,20 +2,18 @@
22
module Ide.Plugin.SemanticTokens (descriptor) where
33

44
import Development.IDE
5-
import Development.IDE.Core.Rules (Log)
65
import qualified Ide.Plugin.SemanticTokens.Internal as Internal
6+
import Ide.Plugin.SemanticTokens.Types
77
import Ide.Types
88
import Language.LSP.Protocol.Message
99

1010

1111

12-
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
12+
descriptor :: Recorder (WithPriority SemanticLog) -> PluginId -> PluginDescriptor IdeState
1313
descriptor recorder plId = (defaultPluginDescriptor plId "Provides semantic tokens")
1414
{ Ide.Types.pluginHandlers =
1515
mkPluginHandler SMethod_TextDocumentSemanticTokensFull Internal.semanticTokensFull
1616
, Ide.Types.pluginRules =
1717
Internal.getSemanticTokensRule recorder
1818
<> Internal.persistentGetSemanticTokensRule
1919
}
20-
21-

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs

Lines changed: 35 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@
1313
{-# LANGUAGE ScopedTypeVariables #-}
1414
{-# LANGUAGE TupleSections #-}
1515
{-# LANGUAGE TypeFamilies #-}
16+
{-# LANGUAGE UnicodeSyntax #-}
1617

1718
-- |
1819
-- This module provides the core functionality of the plugin.
@@ -22,6 +23,8 @@ import Control.Lens ((^.))
2223
import Control.Monad.Except (ExceptT, liftEither,
2324
withExceptT)
2425
import Control.Monad.IO.Class (MonadIO, liftIO)
26+
import Control.Monad.Trans (lift)
27+
import Control.Monad.Trans.Except (runExceptT)
2528
import Data.Either (fromRight)
2629
import qualified Data.Map as Map
2730
import Data.Maybe (listToMaybe, mapMaybe)
@@ -30,21 +33,25 @@ import Development.IDE (Action,
3033
GetDocMap (GetDocMap),
3134
GetHieAst (GetHieAst),
3235
HieAstResult (HAR, hieAst, hieModule, refMap),
33-
IdeState, Priority (..),
34-
Recorder, Rules,
35-
WithPriority,
36+
IdeResult, IdeState,
37+
Pretty (pretty),
38+
Priority (..), Recorder,
39+
Rules, WithPriority,
3640
cmapWithPrio, define,
3741
hieKind, ideLogger,
3842
logPriority, use_)
3943
import Development.IDE.Core.PluginUtils (runActionE,
4044
useWithStaleE)
4145
import Development.IDE.Core.PositionMapping (idDelta, toCurrentRange)
42-
import Development.IDE.Core.Rules (Log (LogShake))
46+
import Development.IDE.Core.Rules (toIdeResult)
4347
import Development.IDE.Core.RuleTypes (DocAndKindMap (..))
44-
import Development.IDE.Core.Shake (addPersistentRule)
45-
import Development.IDE.GHC.Compat
48+
import Development.IDE.Core.Shake (addPersistentRule,
49+
useWithStale_)
50+
import Development.IDE.GHC.Compat hiding (Warning)
51+
import Ide.Logger (logWith)
4652
import Ide.Plugin.Error (PluginError (PluginInternalError),
47-
getNormalizedFilePathE)
53+
getNormalizedFilePathE,
54+
handleMaybe)
4855
import Ide.Plugin.SemanticTokens.Mappings
4956
import Ide.Plugin.SemanticTokens.Query
5057
import Ide.Plugin.SemanticTokens.Types
@@ -56,16 +63,16 @@ import Language.LSP.Protocol.Types (NormalizedFilePath,
5663
type (|?) (InL))
5764
import Prelude hiding (span)
5865

59-
logWith :: (MonadIO m) => IdeState -> Priority -> String -> m ()
60-
logWith st prior = liftIO . logPriority (ideLogger st) prior . T.pack
66+
logActionWith :: (MonadIO m) => IdeState -> Priority -> String -> m ()
67+
logActionWith st prior = liftIO . logPriority (ideLogger st) prior . T.pack
6168

6269
-----------------------
6370
---- the api
6471
-----------------------
6572

6673
computeSemanticTokens :: IdeState -> NormalizedFilePath -> ExceptT PluginError Action SemanticTokens
6774
computeSemanticTokens state nfp = do
68-
let dbg = logWith state Debug
75+
let dbg = logActionWith state Debug
6976
dbg $ "Computing semantic tokens for: " <> show nfp
7077
(RangeHsSemanticTokenTypes {tokens}, mapping) <- useWithStaleE GetSemanticTokens nfp
7178
let rangeTokens = mapMaybe (\(span, name) -> (,name) <$> toCurrentRange mapping span) tokens
@@ -77,6 +84,7 @@ semanticTokensFull state _ param = do
7784
items <- runActionE "SemanticTokens.semanticTokensFull" state $ computeSemanticTokens state nfp
7885
return $ InL items
7986

87+
8088
-- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file.
8189
--
8290
-- This Rule collects information from various sources, including:
@@ -87,13 +95,12 @@ semanticTokensFull state _ param = do
8795
-- Visible names from 'tmrRenamed'
8896
--
8997
-- It then combines this information to compute the semantic tokens for the file.
90-
getSemanticTokensRule :: Recorder (WithPriority Log) -> Rules ()
98+
getSemanticTokensRule :: Recorder (WithPriority SemanticLog) -> Rules ()
9199
getSemanticTokensRule recorder =
92-
define (cmapWithPrio LogShake recorder) $ \GetSemanticTokens nfp -> do
93-
-- (hscEnv -> hsc) <- use_ GhcSessionDeps nfp
94-
(HAR {..}) <- use_ GetHieAst nfp
95-
(DKMap{getKindMap}) <- use_ GetDocMap nfp
96-
Just (_, ast) <- return $ listToMaybe $ Map.toList $ getAsts hieAst
100+
define (cmapWithPrio LogShake recorder) $ \GetSemanticTokens nfp -> handleError recorder $ do
101+
(HAR {..}) <- lift $ use_ GetHieAst nfp
102+
(DKMap{getKindMap}, _) <- lift $ useWithStale_ GetDocMap nfp
103+
(_, ast) <- handleMaybe LogNoAST $ listToMaybe $ Map.toList $ getAsts hieAst
97104
-- get current location from the old ones
98105
let spanNamesMap = hieAstSpanNames ast
99106
let names = nameSetElemsStable $ unionNameSets $ Map.elems spanNamesMap
@@ -104,7 +111,7 @@ getSemanticTokensRule recorder =
104111
-- let importedNameSemanticMap = computeImportedNameSemanticMap $ nameSetElemsStable nameSet
105112
let sMap = plusNameEnv_C (<>) importedNameSemanticMap localSemanticMap
106113
let rangeTokenType = extractSemanticTokensFromNames sMap spanNamesMap
107-
return ([], Just $ RangeHsSemanticTokenTypes rangeTokenType)
114+
return $ RangeHsSemanticTokenTypes rangeTokenType
108115
where
109116
-- ignore one already in discovered in local
110117
getTypeExclude :: NameEnv a
@@ -121,3 +128,14 @@ getSemanticTokensRule recorder =
121128
-- | Persistent rule to ensure that semantic tokens doesn't block on startup
122129
persistentGetSemanticTokensRule :: Rules ()
123130
persistentGetSemanticTokensRule = addPersistentRule GetSemanticTokens $ \_ -> pure $ Just (RangeHsSemanticTokenTypes mempty, idDelta, Nothing)
131+
132+
-- taken from /haskell-language-server/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs
133+
-- | Handle error in 'Action'. Returns an 'IdeResult' with no value and no diagnostics on error. (but writes log)
134+
handleError :: Recorder (WithPriority msg) -> ExceptT msg Action a -> Action (IdeResult a)
135+
handleError recorder action' = do
136+
valueEither <- runExceptT action'
137+
case valueEither of
138+
Left msg -> do
139+
logWith recorder Warning msg
140+
pure $ toIdeResult (Left [])
141+
Right value -> pure $ toIdeResult (Right value)

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -92,7 +92,7 @@ isFunType a = case a of
9292
ForAllTy _ t -> isFunType t
9393
-- Development.IDE.GHC.Compat.Core.FunTy(pattern synonym), FunTyFlag which is used to distinguish
9494
-- (->, =>, etc..)
95-
FunTy flg _ rhs-> if isVisibleFunArg flg then True else isFunType rhs
95+
FunTy flg _ rhs-> isVisibleFunArg flg || isFunType rhs
9696
_x -> isFunTy a
9797

9898
hieKindFunMasksKind :: HieKind a -> HieFunMaskKind a

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs

Lines changed: 17 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,16 @@
1-
{-# LANGUAGE DeriveGeneric #-}
2-
{-# LANGUAGE GADTs #-}
3-
{-# LANGUAGE StrictData #-}
4-
{-# LANGUAGE TypeFamilies #-}
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE GADTs #-}
3+
{-# LANGUAGE OverloadedStrings #-}
4+
{-# LANGUAGE StrictData #-}
5+
{-# LANGUAGE TypeFamilies #-}
56

67
module Ide.Plugin.SemanticTokens.Types where
78

89
import Control.DeepSeq (NFData (rnf), rwhnf)
910
import qualified Data.Array as A
1011
import Data.Generics (Typeable)
11-
import Development.IDE (RuleResult)
12+
import Development.IDE (Pretty (pretty), RuleResult)
13+
import qualified Development.IDE.Core.Shake as Shake
1214
import Development.IDE.GHC.Compat hiding (loc)
1315
import Development.IDE.Graph.Classes (Hashable)
1416
import GHC.Generics (Generic)
@@ -78,3 +80,13 @@ type instance RuleResult GetSemanticTokens = RangeHsSemanticTokenTypes
7880
data HieFunMaskKind kind where
7981
HieFreshFun :: HieFunMaskKind Type
8082
HieFromDiskFun :: A.Array TypeIndex Bool -> HieFunMaskKind TypeIndex
83+
84+
data SemanticLog = LogShake Shake.Log
85+
| LogNoAST
86+
deriving Show
87+
88+
instance Pretty SemanticLog where
89+
pretty theLog = case theLog of
90+
LogShake shakeLog -> pretty shakeLog
91+
LogNoAST -> "no HieAst exist for file"
92+

‎plugins/hls-semantic-tokens-plugin/test/Main.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -61,7 +61,7 @@ testDataDir = "test" </> "testdata"
6161
mkFs :: [FS.FileTree] -> FS.VirtualFileTree
6262
mkFs = FS.mkVirtualFileTree testDataDir
6363

64-
semanticTokensPlugin :: Test.Hls.PluginTestDescriptor Log
64+
semanticTokensPlugin :: Test.Hls.PluginTestDescriptor SemanticLog
6565
semanticTokensPlugin = Test.Hls.mkPluginTestDescriptor Ide.Plugin.SemanticTokens.descriptor "SemanticTokens"
6666

6767
mkSemanticTokensParams :: TextDocumentIdentifier -> SemanticTokensParams
@@ -160,7 +160,8 @@ semanticTokensTests =
160160
liftIO $ 1 @?= 1,
161161
goldenWithSemanticTokens "mixed constancy test result generated from one ghc version" "T1",
162162
goldenWithSemanticTokens "pattern bind" "TPatternSyn",
163-
goldenWithSemanticTokens "type family" "TTypefamily"
163+
goldenWithSemanticTokens "type family" "TTypefamily",
164+
goldenWithSemanticTokens "TUnicodeSyntax" "TUnicodeSyntax"
164165
]
165166

166167
semanticTokensDataTypeTests =

‎plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
3:1-4 TVariable "a\66560b"

‎plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module TUnicodeSyntax where
2+
3+
a𐐀b = "a𐐀b"
4+
5+

0 commit comments

Comments
 (0)