revert cacheLookup

Author: soulomoon

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

@@ -3,12 +3,11 @@
 
 module Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) where
 
-import           Control.Lens                     (Identity (Identity, runIdentity))
+import           Control.Lens                     (Identity (runIdentity))
 import           Control.Monad                    (foldM, guard)
 import           Control.Monad.State.Strict       (MonadState (get),
                                                    MonadTrans (lift),
-                                                   evalStateT, gets, mapStateT,
-                                                   modify', put)
+                                                   evalStateT, modify, put)
 import           Control.Monad.Trans.State.Strict (StateT, runStateT)
 import           Data.Char                        (isAlphaNum)
 import           Data.DList                       (DList)
@@ -32,25 +31,13 @@ import           Prelude                          hiding (length, span)
 
 type Tokenizer m a = StateT PTokenState m a
 type HsSemanticLookup = Identifier -> Maybe HsSemanticTokenType
-type CachedHsSemanticLookup m = Identifier -> Tokenizer m (Maybe HsSemanticTokenType)
-
-cacheLookup :: (Monad m) => HsSemanticLookup -> CachedHsSemanticLookup m
-cacheLookup _ (Left _) = return $ Just TModule
-cacheLookup lk idt@(Right n) = do
-  ne  <- gets semanticLookupCache
-  case lookupNameEnv ne n of
-    Nothing -> do
-      let hsSemanticTy = lk idt
-      modify' (\x -> x{ semanticLookupCache= extendNameEnv ne n hsSemanticTy })
-      return hsSemanticTy
-    Just x -> return x
+
 
 data PTokenState = PTokenState
   {
-    rope                  :: !Rope -- the remains of rope we are working on
-    , cursor              :: !Char.Position -- the cursor position of the current rope to the start of the original file in code point position
-    , columnsInUtf16      :: !UInt -- the column of the start of the current rope in utf16
-    , semanticLookupCache :: !(NameEnv (Maybe HsSemanticTokenType)) -- the cache for semantic lookup result of the current file
+    rope             :: !Rope -- the remains of rope we are working on
+    , cursor         :: !Char.Position -- the cursor position of the current rope to the start of the original file in code point position
+    , columnsInUtf16 :: !UInt -- the column of the start of the current rope in utf16
   }
 
 data SplitResult
@@ -62,14 +49,14 @@ getSplitTokenText :: SplitResult -> Text
 getSplitTokenText (NoSplit (t, _))  = t
 getSplitTokenText (Split (t, _, _)) = t
 
+
 mkPTokenState :: VirtualFile -> PTokenState
 mkPTokenState vf =
   PTokenState
     {
       rope = vf._file_text,
       cursor = Char.Position 0 0,
-      columnsInUtf16 = 0,
-      semanticLookupCache = emptyNameEnv
+      columnsInUtf16 = 0
     }
 
 -- lift a Tokenizer Maybe a to Tokenizer m a,
@@ -85,15 +72,15 @@ foldMapM f ta = foldM (\b a -> mappend b <$> f a) mempty ta
 
 computeRangeHsSemanticTokenTypeList :: HsSemanticLookup -> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes
 computeRangeHsSemanticTokenTypeList lookupHsTokenType vf ast =
-    RangeHsSemanticTokenTypes $ DL.toList $ runIdentity $ evalStateT (foldAst (cacheLookup lookupHsTokenType) ast) (mkPTokenState vf)
+    RangeHsSemanticTokenTypes $ DL.toList $ runIdentity $ evalStateT (foldAst lookupHsTokenType ast) (mkPTokenState vf)
 -- | foldAst
 -- visit every leaf node in the ast in depth first order
-foldAst :: (Monad m) => CachedHsSemanticLookup Identity -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType))
+foldAst :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType))
 foldAst lookupHsTokenType ast = if null (nodeChildren ast)
-  then visitLeafIds lookupHsTokenType ast
+  then liftMaybeM (visitLeafIds lookupHsTokenType ast)
   else foldMapM (foldAst lookupHsTokenType) $ nodeChildren ast
 
-visitLeafIds :: (Monad m) => CachedHsSemanticLookup Identity -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType))
+visitLeafIds :: HsSemanticLookup -> HieAST t -> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
 visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do
   let span = nodeSpan leaf
   (ran, token) <- focusTokenAt leaf
@@ -103,23 +90,21 @@ visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do
     -- only handle the leaf node with single column token
     guard $ srcSpanStartLine span == srcSpanEndLine span
     splitResult <- lift $ splitRangeByText token ran
-    mapStateT hoistIdMaybe
-        $ foldMapM (combineNodeIds lookupHsTokenType ran splitResult)
-        $ Map.filterWithKey (\k _ -> k == SourceInfo) $ getSourcedNodeInfo $ sourcedNodeInfo leaf
+    foldMapM (combineNodeIds lookupHsTokenType ran splitResult) $ Map.filterWithKey (\k _ -> k == SourceInfo) $ getSourcedNodeInfo $ sourcedNodeInfo leaf
   where
-    hoistIdMaybe :: Identity (a, s) -> Maybe (a, s)
-    hoistIdMaybe (Identity x) = Just x
-    combineNodeIds :: CachedHsSemanticLookup Identity -> Range -> SplitResult -> NodeInfo a -> Tokenizer Identity (DList (Range, HsSemanticTokenType))
-    combineNodeIds lookupHsTokenType ran ranSplit (NodeInfo _ _ bd) = do
-        maybeTokenType <- foldMapM (maybe (return Nothing) lookupHsTokenType . getIdentifier ranSplit) (M.keys bd)
+    combineNodeIds :: (Monad m) => HsSemanticLookup -> Range -> SplitResult -> NodeInfo a -> Tokenizer m (DList (Range, HsSemanticTokenType))
+    combineNodeIds lookupHsTokenType ran ranSplit (NodeInfo _ _ bd) =
         case (maybeTokenType, ranSplit) of
             (Nothing, _) -> return mempty
             (Just TModule, _) -> return $ DL.singleton (ran, TModule)
             (Just tokenType, NoSplit (_, tokenRan)) -> return $ DL.singleton (tokenRan, tokenType)
             (Just tokenType, Split (_, ranPrefix, tokenRan)) -> return $ DL.fromList [(ranPrefix, TModule),(tokenRan, tokenType)]
-    getIdentifier ranSplit idt = do
+        where maybeTokenType = foldMap (getIdentifier lookupHsTokenType ranSplit) (M.keys bd)
+
+    getIdentifier :: HsSemanticLookup -> SplitResult -> Identifier -> Maybe HsSemanticTokenType
+    getIdentifier lookupHsTokenType ranSplit idt = do
       case idt of
-        Left _moduleName -> Just idt
+        Left _moduleName -> Just TModule
         Right name -> do
           occStr <- T.pack <$> case (occNameString . nameOccName) name of
             -- the generated selector name with {-# LANGUAGE DuplicateRecordFields #-}
@@ -129,7 +114,7 @@ visitLeafIds lookupHsTokenType leaf = liftMaybeM $ do
             c : ':' : _ | isAlphaNum c       -> Nothing
             ns                               -> Just ns
           guard $ getSplitTokenText ranSplit == occStr
-          return idt
+          lookupHsTokenType idt
 
 
 focusTokenAt ::
@@ -153,7 +138,7 @@ focusTokenAt leaf = do
   let nce = newColumn ncs token
   -- compute the new range for utf16, tuning the columns is enough
   let ran = codePointRangeToRangeWith ncs nce $ realSrcSpanToCodePointRange span
-  modify' $ \s -> s {columnsInUtf16 = nce, rope = remains, cursor = tokenEndPos}
+  modify $ \s -> s {columnsInUtf16 = nce, rope = remains, cursor = tokenEndPos}
   return (ran, token)
   where
     srcSpanCharPositions :: RealSrcSpan -> (Char.Position, Char.Position)

plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs

@@ -270,7 +270,6 @@ semanticTokensDataTypeTests =
     "get semantic Tokens"
     [ goldenWithSemanticTokensWithDefaultConfig "simple datatype" "TDataType",
       goldenWithSemanticTokensWithDefaultConfig "record" "TRecord",
-      goldenWithSemanticTokensWithDefaultConfig "TRecordWildCards" "TRecordWildCards",
       goldenWithSemanticTokensWithDefaultConfig "record With DuplicateRecordFields" "TRecordDuplicateRecordFields",
       goldenWithSemanticTokensWithDefaultConfig "datatype import" "TDatatypeImported",
       goldenWithSemanticTokensWithDefaultConfig "datatype family" "TDataFamily",