Merge pull request #419 from vekatze/better-highlighting

improve symbol highlighting

Author: vekatze

src/Command/LSP/Internal/FindDefinition.hs

@@ -32,7 +32,7 @@ findDefinition ::
   (J.HasTextDocument p a1, J.HasUri a1 Uri, J.HasPosition p Position) =>
   Handle ->
   p ->
-  App ((LT.LocType, DefinitionLink), LocationTree)
+  App ((LT.SymbolName, DefinitionLink), LocationTree)
 findDefinition h params = do
   src <- GetSource.getSource (getSourceHandle h) params
   locTree <- GetLocationTree.getLocationTree (getLocationTreeHandle h) src
@@ -43,19 +43,19 @@ _findDefinition ::
   (J.HasPosition p Position) =>
   p ->
   LT.LocationTree ->
-  Maybe (LT.LocType, DefinitionLink)
+  Maybe (LT.SymbolName, DefinitionLink)
 _findDefinition params locationTree = do
   let line = fromEnum (params ^. J.position . J.line) + 1
   let col = fromEnum (params ^. J.position . J.character) + 1
-  (locType, m, _, symbolLen) <- LT.find line col locationTree
+  (symbolName, m, _, symbolLen) <- LT.find line col locationTree
   let defPath = H.metaFileName m
   let (defLine, defCol) = H.metaLocation m
   let defFilePath' = filePathToUri defPath
   let _start = Position {_line = fromIntegral (defLine - 1), _character = fromIntegral (defCol - 1)}
   let _end = _start {_character = _character _start + fromIntegral symbolLen}
   let range = Range {_start, _end}
   return
-    ( locType,
+    ( symbolName,
       DefinitionLink $
         LocationLink
           { _originSelectionRange = Nothing,

src/Command/LSP/Internal/GetSymbolInfo.hs

@@ -40,8 +40,7 @@ getSymbolInfo params = do
       liftMaybe Nothing
     Just handle -> do
       let findDefHandle = FindDefinition.new h
-      ((locType, _), _) <- FindDefinition.findDefinition findDefHandle params
-      symbolName <- liftMaybe $ getSymbolLoc locType
+      ((symbolName, _), _) <- FindDefinition.findDefinition findDefHandle params
       case symbolName of
         LT.Local varID _ -> do
           weakTypeEnv <- liftIO $ Elaborate.getWeakTypeEnv handle
@@ -54,11 +53,7 @@ getSymbolInfo params = do
           return $ toTextType t
         LT.Foreign {} -> do
           liftMaybe Nothing
-
-getSymbolLoc :: LT.LocType -> Maybe LT.SymbolName
-getSymbolLoc locType =
-  case locType of
-    LT.FileLoc ->
-      Nothing
-    LT.SymbolLoc symbolName ->
-      return symbolName
+        LT.StaticFile {} -> do
+          liftMaybe Nothing
+        LT.SourceFile {} -> do
+          liftMaybe Nothing

src/Kernel/Common/Handle/Local/Tag.hs

@@ -2,12 +2,13 @@ module Kernel.Common.Handle.Local.Tag
   ( Handle (..),
     new,
     get,
-    insertFileLoc,
     insertLocalVar,
     insertGlobalVar,
     insertBinder,
     insertLocator,
     insertExternalName,
+    insertStaticFile,
+    insertSourceFile,
   )
 where
 
@@ -36,18 +37,11 @@ get :: Handle -> IO LT.LocationTree
 get h =
   readIORef $ _tagMapRef h
 
-insertFileLoc :: Handle -> Hint -> Int -> Hint -> IO ()
-insertFileLoc h mUse nameLength mDef = do
-  when (metaShouldSaveLocation mUse) $ do
-    let (l, c) = metaLocation mUse
-    modifyIORef' (_tagMapRef h) $ LT.insert LT.FileLoc (l, (c, c + nameLength)) mDef
-
 insertLocalVar :: Handle -> Hint -> Ident -> Hint -> IO ()
 insertLocalVar h mUse ident@(I (var, varID)) mDef = do
   unless (isHole ident) $ do
     let nameLength = T.length var
-    let symbolLoc = LT.SymbolLoc (LT.Local varID nameLength)
-    insert h mUse symbolLoc nameLength mDef
+    insert h mUse (LT.Local varID nameLength) nameLength mDef
 
 insertBinder :: Handle -> BinderF a -> IO ()
 insertBinder h (m, _, ident, _) =
@@ -56,21 +50,29 @@ insertBinder h (m, _, ident, _) =
 insertGlobalVar :: Handle -> Hint -> DD.DefiniteDescription -> IsConstLike -> Hint -> IO ()
 insertGlobalVar h mUse dd isConstLike mDef = do
   let nameLength = T.length (DD.localLocator dd)
-  let symbolLoc = LT.SymbolLoc (LT.Global dd isConstLike)
-  insert h mUse symbolLoc nameLength mDef
+  insert h mUse (LT.Global dd isConstLike) nameLength mDef
 
-insert :: Handle -> Hint -> LT.LocType -> Int -> Hint -> IO ()
-insert h mUse locType nameLength mDef = do
+insert :: Handle -> Hint -> LT.SymbolName -> Int -> Hint -> IO ()
+insert h mUse symbolName nameLength mDef = do
   when (metaShouldSaveLocation mUse) $ do
     let (l, c) = metaLocation mUse
-    modifyIORef' (_tagMapRef h) $ LT.insert locType (l, (c, c + nameLength)) mDef
+    modifyIORef' (_tagMapRef h) $ LT.insert symbolName (l, (c, c + nameLength)) mDef
 
 insertLocator :: Handle -> Hint -> DD.DefiniteDescription -> IsConstLike -> Int -> Hint -> IO ()
 insertLocator h mUse dd isConstLike nameLength mDef = do
-  insert h mUse (LT.SymbolLoc (LT.Global dd isConstLike)) nameLength mDef
+  insert h mUse (LT.Global dd isConstLike) nameLength mDef
 
 insertExternalName :: Handle -> Hint -> EN.ExternalName -> Hint -> IO ()
 insertExternalName h mUse externalName mDef = do
-  let symbolLoc = LT.SymbolLoc (LT.Foreign externalName)
   let nameLength = T.length $ EN.reify externalName
-  insert h mUse symbolLoc nameLength mDef
+  insert h mUse (LT.Foreign externalName) nameLength mDef
+
+insertStaticFile :: Handle -> Hint -> T.Text -> Hint -> IO ()
+insertStaticFile h mUse key mDef = do
+  let nameLength = T.length key
+  insert h mUse (LT.StaticFile key) nameLength mDef
+
+insertSourceFile :: Handle -> Hint -> T.Text -> Hint -> IO ()
+insertSourceFile h mUse locator mDef = do
+  let nameLength = T.length locator
+  insert h mUse (LT.SourceFile locator) nameLength mDef

src/Kernel/Common/LocationTree.hs

@@ -1,6 +1,5 @@
 module Kernel.Common.LocationTree
   ( LocationTree,
-    LocType (..),
     SymbolName (..),
     empty,
     insert,
@@ -35,39 +34,29 @@ data SymbolName
   = Local Int DefSymbolLen
   | Global DD.DefiniteDescription IsConstLike
   | Foreign EN.ExternalName
-  deriving (Show, Eq, Generic)
-
-data LocType
-  = FileLoc
-  | SymbolLoc SymbolName
+  | StaticFile T.Text
+  | SourceFile T.Text
   deriving (Show, Eq, Generic)
 
 instance Binary SymbolName
 
-instance Binary LocType
-
 type LocationTree =
-  M.Map (Line, ColFrom) (Line, ColInterval, LocType, SavedHint)
+  M.Map (Line, ColFrom) (Line, ColInterval, SymbolName, SavedHint)
 
 empty :: LocationTree
 empty =
   M.empty
 
-insert :: LocType -> (Line, ColInterval) -> Hint -> LocationTree -> LocationTree
-insert lt (l, (cFrom, cTo)) m =
-  M.insert (l, cFrom) (l, (cFrom, cTo), lt, SavedHint m)
+insert :: SymbolName -> (Line, ColInterval) -> Hint -> LocationTree -> LocationTree
+insert sym (l, (cFrom, cTo)) m =
+  M.insert (l, cFrom) (l, (cFrom, cTo), sym, SavedHint m)
 
-find :: Line -> Column -> LocationTree -> Maybe (LocType, Hint, ColInterval, DefSymbolLen)
+find :: Line -> Column -> LocationTree -> Maybe (SymbolName, Hint, ColInterval, DefSymbolLen)
 find l c mp = do
-  (line, colInterval@(colFrom, colTo), lt, SavedHint m) <- snd <$> M.lookupLE (l, c) mp
+  (line, colInterval@(_, colTo), sym, SavedHint m) <- snd <$> M.lookupLE (l, c) mp
   if colTo < c || line /= l
     then Nothing
-    else do
-      case lt of
-        FileLoc ->
-          return (lt, m, colInterval, colTo - colFrom)
-        SymbolLoc sym ->
-          return (lt, m, colInterval, getLength sym)
+    else return (sym, m, colInterval, getLength sym)
 
 getLength :: SymbolName -> DefSymbolLen
 getLength s =
@@ -78,19 +67,15 @@ getLength s =
       T.length $ DD.localLocator dd
     Foreign externalName ->
       T.length $ EN.reify externalName
-
-isSymLoc :: LocType -> Bool
-isSymLoc lt =
-  case lt of
-    SymbolLoc _ ->
-      True
-    FileLoc ->
-      False
+    StaticFile key ->
+      T.length key
+    SourceFile locator ->
+      T.length locator
 
 findRef :: Loc -> LocationTree -> [(FilePath, (Line, ColInterval))]
 findRef loc t = do
   let kvs = M.toList t
-  flip mapMaybe kvs $ \((line, _), (_, colInterval, lt, SavedHint m)) -> do
-    if isSymLoc lt && loc == metaLocation m
+  flip mapMaybe kvs $ \((line, _), (_, colInterval, _, SavedHint m)) -> do
+    if loc == metaLocation m
       then return (metaFileName m, (line, colInterval))
       else Nothing

src/Kernel/Parse/Internal/Discern.hs

@@ -649,7 +649,7 @@ discern h term =
           case contentOrNone of
             Just (path, content) -> do
               liftIO $ Unused.deleteStaticFile (H.unusedHandle h) key
-              liftIO $ Tag.insertFileLoc (H.tagHandle h) mKey (T.length key) (newSourceHint path)
+              liftIO $ Tag.insertStaticFile (H.tagHandle h) mKey key (newSourceHint path)
               return $ m :< WT.Prim (WPV.Text content)
             Nothing ->
               raiseError m $ "No such static file is defined: `" <> key <> "`"

src/Kernel/Parse/Internal/Import.hs

@@ -101,7 +101,7 @@ interpretImportItemTextFile h currentModule keyList = do
     case Map.lookup key (moduleTextFiles currentModule') of
       Just path -> do
         let fullPath = moduleRootDir </> path
-        liftIO $ Tag.insertFileLoc (tagHandle h) mKey (T.length key) (newSourceHint fullPath)
+        liftIO $ Tag.insertStaticFile (tagHandle h) mKey key (newSourceHint fullPath)
         liftIO $ Unused.insertStaticFile (unusedHandle h) key mKey
         return (key, (mKey, fullPath))
       Nothing ->
@@ -143,7 +143,7 @@ getSource h mustUpdateTag m sgl locatorText = do
   let nextPath = getSourceDir nextModule </> relPath
   when mustUpdateTag $
     liftIO $
-      Tag.insertFileLoc (tagHandle h) m (T.length locatorText) (newSourceHint nextPath)
+      Tag.insertSourceFile (tagHandle h) m locatorText (newSourceHint nextPath)
   STL.shiftToLatest
     (shiftToLatestHandle h)
     Source.Source