Greg/remove redundant imports

src/StaticLS/Except.hs

@@ -3,8 +3,6 @@ module StaticLS.Except where
 import Control.Error.Util
 import Control.Monad.Trans.Except
 import Data.Pos (Pos (..))
-import Data.Text (Text)
-import StaticLS.HieView.View
 
 exceptToMaybe :: Except a b -> Maybe b
 exceptToMaybe = hush . runExcept

src/StaticLS/Handlers.hs

@@ -35,6 +35,7 @@ import StaticLS.IDE.DocumentSymbols (getDocumentSymbols)
 import StaticLS.IDE.Format qualified as IDE.Format
 import StaticLS.IDE.Hover
 import StaticLS.IDE.Implementation qualified as IDE.Implementation
+import StaticLS.IDE.InlayHints
 import StaticLS.IDE.Monad qualified as IDE
 import StaticLS.IDE.References
 import StaticLS.IDE.Rename qualified as IDE.Rename
@@ -133,6 +134,16 @@ handlePrepareRenameRequest = LSP.requestHandler LSP.SMethod_TextDocumentPrepareR
       res $ Right $ InL resp
       pure ()
 
+handleInlayHintRequest :: Handlers (LspT c StaticLsM)
+handleInlayHintRequest = LSP.requestHandler LSP.SMethod_TextDocumentInlayHint $ \req res -> do
+  lift $ logInfo "Received inlay hint request"
+  let params = req._params
+  path <- ProtoLSP.tdiToAbsPath params._textDocument
+  inlayHints <- lift $ getInlayHints path
+  let resp = ProtoLSP.inlayHintToProto <$> inlayHints
+  res $ Right $ InL resp
+  pure ()
+
 handleCancelNotification :: Handlers (LspT c StaticLsM)
 handleCancelNotification = LSP.notificationHandler LSP.SMethod_CancelRequest $ \_ -> pure ()
 

src/StaticLS/IDE/CodeActions.hs

@@ -10,6 +10,7 @@ import Data.Path (AbsPath)
 import Data.Rope qualified as Rope
 import StaticLS.IDE.CodeActions.AddTypeSig qualified as AddTypeSig
 import StaticLS.IDE.CodeActions.AutoImport qualified as AutoImport
+import StaticLS.IDE.CodeActions.RemoveRedundantImports as RemoveRedundantImports
 import StaticLS.IDE.CodeActions.Types
 import StaticLS.IDE.Monad
 import StaticLS.IDE.SourceEdit (SourceEdit)
@@ -23,7 +24,8 @@ getCodeActions path lineCol = do
   let cx = CodeActionContext {path, pos, lineCol}
   typesCodeActions <- AddTypeSig.codeAction cx
   importCodeActions <- AutoImport.codeAction cx
-  let codeActions = typesCodeActions ++ importCodeActions
+  removeRedundantImports <- RemoveRedundantImports.codeAction cx
+  let codeActions = typesCodeActions ++ importCodeActions ++ removeRedundantImports
   pure codeActions
 
 resolveLazyAssist :: CodeActionMessage -> StaticLsM SourceEdit

src/StaticLS/IDE/CodeActions/RemoveRedundantImports.hs

@@ -0,0 +1,185 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module StaticLS.IDE.CodeActions.RemoveRedundantImports where
+
+import AST qualified
+import AST.Haskell qualified as Haskell
+import Control.Applicative
+import Control.Exception
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Maybe
+import Data.Edit
+import Data.Foldable
+import Data.LineCol
+import Data.List qualified as List
+import Data.Map ()
+import Data.Maybe
+import Data.Path
+import Data.Pos (Pos (..))
+import Data.Range (Range (..))
+import Data.Range qualified as Range
+import Data.Rope (Rope)
+import Data.Rope qualified as Rope
+import Data.Text qualified as Text
+import Data.Text.IO qualified as TextIO
+import StaticLS.IDE.CodeActions.Types
+import StaticLS.IDE.Diagnostics
+import StaticLS.IDE.Diagnostics.ParseGHC
+import StaticLS.IDE.FileWith
+import StaticLS.IDE.Monad as Monad
+import StaticLS.IDE.SourceEdit as SourceEdit
+import StaticLS.Monad
+import StaticLS.Semantic
+import StaticLS.StaticEnv
+import StaticLS.Tree
+import System.FilePath
+
+ghcidFile :: FilePath
+ghcidFile = "ghcid.txt"
+
+codeAction :: CodeActionContext -> StaticLsM [Assist]
+codeAction CodeActionContext {path, lineCol, pos} = do
+  diagnostics <- getDiagnostics
+  let relevantDiagnostics = filter isRedundantImportDiagnostic diagnostics
+  deletionInfos <- traverse mkDeletionInfo relevantDiagnostics
+  globalRedundantImportDiagnostics <- filterM (\case Full f -> isFileSaved f.path; Partial _ -> pure False) deletionInfos
+  let localRedundantImportDiagnostics = filter (isDeletionInFile path) deletionInfos
+  let globalAssist = deletionsToAssist "Remove redundant imports in project" globalRedundantImportDiagnostics
+  let localAssist = deletionsToAssist "Remove redundant imports in file" localRedundantImportDiagnostics
+  pure [localAssist, globalAssist]
+
+getDiagnostics :: StaticLsM [Diagnostic]
+getDiagnostics = do
+  staticEnv <- getStaticEnv
+  let wsRootPath = toFilePath staticEnv.wsRoot
+  let makeAbsPath = unsafeFilePathToAbs . (wsRootPath System.FilePath.</>) . toFilePath
+  let ghcidPath = wsRootPath System.FilePath.</> ghcidFile
+  info <- liftIO $ catch @IOException (TextIO.readFile ghcidPath) (const $ pure "")
+  let diagnostics = parse makeAbsPath info
+  pure diagnostics
+
+data DeletionInfo = Partial PartialDeletionInfo | Full FullDeletionInfo
+
+data PartialDeletionInfo = PartialDeletionInfo {}
+
+data FullDeletionInfo = FullDeletionInfo
+  { path :: AbsPath
+  , sourceRope :: Rope
+  , haskell :: Haskell.Haskell
+  , loc :: Range
+  , node :: Maybe Haskell.Import
+  , isPartial :: Bool
+  }
+
+mkDeletionInfo :: Diagnostic -> StaticLsM DeletionInfo
+mkDeletionInfo diagnostic
+  | isPartialDiagnostic diagnostic = pure $ Partial PartialDeletionInfo {}
+  | otherwise = Full <$> mkFullDeletionInfo diagnostic
+
+mkFullDeletionInfo :: Diagnostic -> StaticLsM FullDeletionInfo
+mkFullDeletionInfo diagnostic = do
+  let path = diagnostic.range.path
+  sourceRope <- getSourceRope path
+  haskell <- getHaskell path
+  let loc = Rope.lineColRangeToRange sourceRope diagnostic.range.loc
+  node <- getImportAtLoc path loc
+  pure FullDeletionInfo {..}
+
+getImportAtLoc :: AbsPath -> Range -> StaticLsM (Maybe Haskell.Import)
+getImportAtLoc path loc = do
+  haskell <- getHaskell path
+  let imports = getImports haskell
+  let importList = case imports of
+        Right (Just imp) -> imp.imports
+        _ -> []
+  let hsImport = find (\imp -> (AST.nodeToRange imp) `Range.containsRange` loc) importList
+  pure hsImport
+
+isFileSaved :: AbsPath -> StaticLsM Bool
+isFileSaved absPath = do
+  fileState <- getFileState absPath
+  hieSource <- runMaybeT $ Monad.getHieSource absPath
+  let contentsText = fileState.contentsText
+  pure $ case hieSource of
+    Just src -> src == contentsText
+    Nothing -> False
+
+deletionsToAssist :: Text.Text -> [DeletionInfo] -> Assist
+deletionsToAssist message deletions = do
+  let numFixes = length deletions
+  let fixCase = if numFixes == 1 then "fix" else "fixes"
+  let message' = message <> " (" <> (Text.pack . show) numFixes <> " " <> fixCase <> ")"
+  mkAssist message' $ actOnDeletions deletions
+
+actOnDeletions :: [DeletionInfo] -> SourceEdit
+actOnDeletions deletionInfos = do
+  let deletions = createDeletion <$> deletionInfos
+  let sourceEdit = mconcat deletions
+  sourceEdit
+
+isRedundantImportDiagnostic :: Diagnostic -> Bool
+isRedundantImportDiagnostic diagnostic = do
+  let dmessage = diagnostic.message
+  let isPrefixCorrect = Text.isPrefixOf "The import of" dmessage || Text.isPrefixOf "The qualified import of" dmessage
+  let isSuffixCorrect = Text.isInfixOf "is redundant" dmessage
+  isPrefixCorrect && isSuffixCorrect
+
+isPartialDiagnostic :: Diagnostic -> Bool
+isPartialDiagnostic diagnostic = Text.isInfixOf "from module" diagnostic.message
+
+isDeletionInFile :: AbsPath -> DeletionInfo -> Bool
+isDeletionInFile curPath = \case
+  Partial PartialDeletionInfo -> False
+  Full FullDeletionInfo {..} -> do
+    toFilePath path == toFilePath curPath
+
+createDeletion :: DeletionInfo -> SourceEdit
+createDeletion = \case
+  Partial pdi -> SourceEdit.empty
+  Full fdi -> createFullDeletion fdi
+
+createFullDeletion :: FullDeletionInfo -> SourceEdit
+createFullDeletion FullDeletionInfo {..} = do
+  let edit = case node of
+        Nothing -> SourceEdit.empty
+        Just hsImport -> single path (delete $ extend sourceRope haskell $ AST.nodeToRange hsImport)
+  edit
+
+createPartialDeletion :: DeletionInfo -> SourceEdit
+createPartialDeletion diagnostic = do
+  -- let startChar = '‘'
+  -- let endChar = '’'
+  SourceEdit.empty
+
+extend :: Rope -> Haskell.Haskell -> Range -> Range
+extend rope haskell range@(Range start end) = do
+  let newEnd = fromMaybe end $ lastPosOnLine rope end
+  let nodePred node = if (AST.nodeRange node).start.pos > start.pos then Just node else Nothing
+  let node = getDeepestContainingSatisfying nodePred (Range.point newEnd) haskell.dynNode
+  let newEnd' = case node of
+        Nothing -> newEnd
+        Just cmt -> (AST.nodeToRange cmt).end
+  Range (Pos $ start.pos - 1) newEnd'
+
+lastPosOnLine :: Rope -> Pos -> Maybe Pos
+lastPosOnLine rope pos@(Pos posidx) = do
+  let lineCol = Rope.posToLineCol rope pos
+  lineLen <- Text.length . Rope.toText <$> Rope.getLine rope lineCol.line
+  let (Pos col) = lineCol.col
+  let diff = lineLen - col
+  let newPos = Pos (posidx + diff - 1)
+  pure newPos
+
+-- This function is copy-pasted from tree-sitter-haskell.
+getDeepestContainingSatisfying :: (AST.DynNode -> Maybe b) -> Range -> AST.DynNode -> Maybe b
+getDeepestContainingSatisfying f range node = go node
+ where
+  go n =
+    ( do
+        n' <- List.find (\n -> n.nodeRange `Range.containsRange` range) n.nodeChildren
+        go n'
+    )
+      <|> f n

src/StaticLS/IDE/InlayHints.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE LambdaCase #-}
+
+module StaticLS.IDE.InlayHints where
+
+import AST.Cast
+import AST.Haskell.Generated qualified as Haskell
+import AST.Node
+import Control.Monad.Trans.Maybe
+import Data.Change
+import Data.LineCol
+import Data.LineColRange qualified as LineColRange
+import Data.Maybe
+import Data.Path
+import Data.Range
+import Data.Rope
+import Data.Text (Text)
+import Data.Text qualified as Text
+import StaticLS.HieView.Query qualified as HieView.Query
+import StaticLS.HieView.Type qualified as HieView.Type
+import StaticLS.IDE.Monad
+import StaticLS.Monad
+
+data InlayHint = InlayHint
+  { position :: LineCol
+  , label :: Text
+  , -- TODO add kind kind :: ??
+    textEdits :: Maybe (Rope, [Change]) -- we need the rope to convert ranges in changes to lineColRanges
+    -- TODO add tooltip
+  }
+
+mkInlayText :: LineCol -> Text -> InlayHint
+mkInlayText lineCol text = InlayHint {position = lineCol, label = text, textEdits = Nothing}
+
+getInlayHints :: AbsPath -> StaticLsM [InlayHint]
+getInlayHints path = getTypedefInlays_ path
+
+getTypedefInlays :: AbsPath -> (LineCol -> [Text]) -> StaticLsM [InlayHint]
+getTypedefInlays absPath getTypes = do
+  haskell <- getHaskell absPath
+  rope <- getSourceRope absPath
+  let targetNodes = selectNodesToType (getDynNode haskell)
+  let ranges = nodeToRange <$> targetNodes
+  let posns = posToLineCol rope . (.start) <$> ranges
+  let endPosns = posToLineCol rope . (.end) <$> ranges
+  let typeStrs = getTypes <$> posns
+  let posnTypes = zip endPosns (fmtTypeStr . mconcat <$> typeStrs)
+  let inlayHints = uncurry mkInlayText <$> posnTypes
+  pure inlayHints
+
+fmtTypeStr :: Text -> Text
+fmtTypeStr text
+  | text == "" = ""
+  | Text.length text > 50 = "" -- hide overly long inlays and buggy inlays
+  | otherwise = " :: " <> text
+
+getTypedefInlays_ :: AbsPath -> StaticLsM [InlayHint]
+getTypedefInlays_ absPath = do
+  hieView' <- runMaybeT $ getHieView absPath
+  case hieView' of
+    Nothing -> pure []
+    Just hieView -> do
+      let getTypes lineCol = do
+            let tys = HieView.Query.fileTysAtRangeList hieView (LineColRange.point lineCol)
+            fmap HieView.Type.printType tys
+      getTypedefInlays absPath getTypes
+
+nodeToDescendants :: DynNode -> [DynNode]
+nodeToDescendants node = node : (nodeToDescendants. getDynNode =<< node.nodeChildren)
+
+selectNodesToType :: DynNode -> [DynNode]
+selectNodesToType root = do
+  let allDescendants = nodeToDescendants root
+  let varDescendants = fmap getDynNode $ mapMaybe (cast @Haskell.Variable) allDescendants
+  let notableVarDescendants = filter (\n -> n.nodeFieldName `elem` [Just "name", Just "pattern", Just "element"]) varDescendants
+  notableVarDescendants

src/StaticLS/ProtoLSP.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
 module StaticLS.ProtoLSP (
   lineColToProto,
   lineColFromProto,
@@ -20,6 +22,7 @@ module StaticLS.ProtoLSP (
   completionToProto,
   diagnosticToProto,
   diagnosticsToProto,
+  inlayHintToProto,
 )
 where
 
@@ -38,13 +41,15 @@ import Data.Path qualified as Path
 import Data.Pos
 import Data.Rope (Rope)
 import Data.Rope qualified as Rope
+import Data.Text qualified as Text
 import Data.Traversable (for)
 import Language.LSP.Protocol.Types qualified as LSP
 import StaticLS.IDE.CodeActions.Types (Assist (..))
 import StaticLS.IDE.Completion qualified as IDE.Completion
 import StaticLS.IDE.Diagnostics qualified as IDE.Diagnostics
 import StaticLS.IDE.DocumentSymbols (SymbolTree (..))
 import StaticLS.IDE.FileWith (FileLcRange, FileWith' (..))
+import StaticLS.IDE.InlayHints qualified as IDE.InlayHints
 import StaticLS.IDE.Monad qualified as IDE.Monad
 import StaticLS.IDE.SourceEdit (SourceEdit (..))
 import StaticLS.IDE.SymbolKind (SymbolKind)
@@ -251,3 +256,18 @@ diagnosticsToProto diags =
     diag <- diags
     let path = diag.range.path
     pure (path, [diagnosticToProto diag])
+
+inlayHintToProto :: IDE.InlayHints.InlayHint -> LSP.InlayHint
+inlayHintToProto IDE.InlayHints.InlayHint {position = p', label = l', textEdits = te'} =
+  LSP.InlayHint
+    { _position = lineColToProto p'
+    , _label = LSP.InL l'
+    , _kind = Nothing
+    , _textEdits = fmap convert te'
+    , _tooltip = Nothing
+    , _paddingLeft = Nothing
+    , _paddingRight = Nothing
+    , _data_ = Nothing
+    }
+ where
+  convert (rope, changes) = fmap (changeToProto rope) changes

src/StaticLS/Semantic.hs

@@ -1,10 +1,7 @@
 module StaticLS.Semantic where
 
 import AST.Haskell qualified as Haskell
-import Control.Monad.Trans (lift)
-import Control.Monad.Trans.Maybe (MaybeT)
 import Data.HashMap.Strict (HashMap)
-import Data.HashMap.Strict qualified as HashMap
 import Data.Path (AbsPath)
 import Data.RangeMap (RangeMap)
 import Data.Rope (Rope)