From c463bc7bbdde137c2cb9640c7fd4169da567e12e Mon Sep 17 00:00:00 2001 From: Daniel Brice Date: Sun, 6 Jul 2025 08:43:12 -0700 Subject: [PATCH 1/2] Additional code actions/quick fixes... * Add required extension * Insert associated type * Insert cases * Insert fields * Insert missing methods * Use valid hole fit --- CHANGELOG.md | 9 ++ src/StaticLS/HIE/File.hs | 13 +- src/StaticLS/Handlers.hs | 6 +- src/StaticLS/IDE/CodeActions.hs | 57 +++++++- .../IDE/CodeActions/AddRequiredExtension.hs | 25 ++++ .../IDE/CodeActions/InsertAssociatedType.hs | 14 ++ src/StaticLS/IDE/CodeActions/InsertCases.hs | 16 +++ src/StaticLS/IDE/CodeActions/InsertFields.hs | 33 +++++ .../IDE/CodeActions/InsertMissingMethods.hs | 15 ++ src/StaticLS/IDE/CodeActions/Parse.hs | 136 ++++++++++++++++++ .../IDE/CodeActions/UseValidHoleFit.hs | 12 ++ src/StaticLS/IDE/CodeActions/Utils.hs | 44 ++++++ static-ls.cabal | 8 ++ 13 files changed, 378 insertions(+), 10 deletions(-) create mode 100644 src/StaticLS/IDE/CodeActions/AddRequiredExtension.hs create mode 100644 src/StaticLS/IDE/CodeActions/InsertAssociatedType.hs create mode 100644 src/StaticLS/IDE/CodeActions/InsertCases.hs create mode 100644 src/StaticLS/IDE/CodeActions/InsertFields.hs create mode 100644 src/StaticLS/IDE/CodeActions/InsertMissingMethods.hs create mode 100644 src/StaticLS/IDE/CodeActions/Parse.hs create mode 100644 src/StaticLS/IDE/CodeActions/UseValidHoleFit.hs create mode 100644 src/StaticLS/IDE/CodeActions/Utils.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 934ca00a..e34b6df7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for static-ls +## Unreleased -- 2025-07-06 + * New code actions/quick fixes + * Add required extension + * Insert associated type + * Insert cases + * Insert fields + * Insert missing methods + * Use valid hole fit + ## 1.0.0 -- 2024-09-24 * Re-architect to use tree-sitter and in memory representation of file system * New features: diff --git a/src/StaticLS/HIE/File.hs b/src/StaticLS/HIE/File.hs index 687670c8..b041c611 100644 --- a/src/StaticLS/HIE/File.hs +++ b/src/StaticLS/HIE/File.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module StaticLS.HIE.File ( + getHieFileFromTdi, modToHieFile, modToSrcFile, srcFilePathToHieFilePath, @@ -25,7 +26,7 @@ import Control.Monad.IO.Unlift (MonadIO, liftIO) import Control.Monad.Trans.Maybe import Data.Bifunctor (first, second) import Data.Map qualified as Map -import Data.Path (AbsPath) +import Data.Path (AbsPath, filePathToAbs) import Data.Path qualified as Path import Data.Text qualified as T import Data.Text.Encoding qualified as T.Encoding @@ -33,6 +34,7 @@ import GHC.Iface.Ext.Binary qualified as GHC import GHC.Iface.Ext.Types qualified as GHC import GHC.Types.Name.Cache qualified as GHC import HieDb qualified +import Language.LSP.Protocol.Types qualified as LSP import StaticLS.FilePath import StaticLS.HIE.File.Except import StaticLS.HieDb qualified as HieDb @@ -46,6 +48,13 @@ import System.FilePath (()) type HieFile = GHC.HieFile +-- | Retrieve a hie info from a lsp text document identifier +getHieFileFromTdi :: (HasStaticEnv m, HasLogger m, MonadIO m) => LSP.TextDocumentIdentifier -> MaybeT m GHC.HieFile +getHieFileFromTdi = getHieFileFromPath <=< tdiToHieFilePath + +tdiToHieFilePath :: (HasStaticEnv m, MonadIO m) => LSP.TextDocumentIdentifier -> MaybeT m AbsPath +tdiToHieFilePath = srcFilePathToHieFilePath <=< filePathToAbs <=< (MaybeT . pure . LSP.uriToFilePath . (._uri)) + getHieSource :: GHC.HieFile -> T.Text getHieSource hieFile = T.Encoding.decodeUtf8 $ GHC.hie_hs_src hieFile @@ -53,7 +62,7 @@ getHieSource hieFile = T.Encoding.decodeUtf8 $ GHC.hie_hs_src hieFile -- Returns a Maybe instead of throwing because we want to handle -- the case when there is no hie file and do something reasonable -- Most functions that get the file text will throw if the file text is not found -getHieFileFromPath :: (HasStaticEnv m, HasLogger m, MonadIO m, HasLogger m) => AbsPath -> MaybeT m HieFile +getHieFileFromPath :: (HasStaticEnv m, HasLogger m, MonadIO m) => AbsPath -> MaybeT m HieFile getHieFileFromPath = ((exceptToMaybeT . getHieFileFromHiePath) <=< srcFilePathToHieFilePath) -- | Retrieve an hie file from a module name diff --git a/src/StaticLS/Handlers.hs b/src/StaticLS/Handlers.hs index e99a88a9..98c5911c 100644 --- a/src/StaticLS/Handlers.hs +++ b/src/StaticLS/Handlers.hs @@ -219,12 +219,12 @@ handleCodeAction = LSP.requestHandler LSP.SMethod_TextDocumentCodeAction $ \req _ <- lift $ logInfo "handleCodeAction" let params = req._params let tdi = params._textDocument + let ctx = params._context path <- ProtoLSP.uriToAbsPath tdi._uri let range = params._range let lineCol = (ProtoLSP.lineColFromProto range._start) - assists <- lift $ getCodeActions path lineCol - codeActions <- lift $ traverse ProtoLSP.assistToCodeAction assists - res (Right (LSP.InL (fmap LSP.InR codeActions))) + codeActions <- lift $ getCodeActions tdi ctx path lineCol + res $ Right $ LSP.InL $ fmap LSP.InR codeActions pure () handleResolveCodeAction :: Handlers (LspT c StaticLsM) diff --git a/src/StaticLS/IDE/CodeActions.hs b/src/StaticLS/IDE/CodeActions.hs index 52ac6d08..73920420 100644 --- a/src/StaticLS/IDE/CodeActions.hs +++ b/src/StaticLS/IDE/CodeActions.hs @@ -5,28 +5,51 @@ module StaticLS.IDE.CodeActions where +import Control.Error (mapMaybe) +import Control.Monad (join) import Data.LineCol (LineCol (..)) import Data.Path (AbsPath) import Data.Rope qualified as Rope +import Data.Set qualified as S +import Language.LSP.Protocol.Types qualified as LSP +import StaticLS.IDE.CodeActions.AddRequiredExtension qualified as AddRequiredExtension 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.InsertAssociatedType qualified as InsertAssociatedType +import StaticLS.IDE.CodeActions.InsertCases qualified as InsertCases +import StaticLS.IDE.CodeActions.InsertFields qualified as InsertFields +import StaticLS.IDE.CodeActions.InsertMissingMethods qualified as InsertMissingMethods +import StaticLS.IDE.CodeActions.Parse qualified as Parse +import StaticLS.IDE.CodeActions.RemoveRedundantImports qualified as RemoveRedundantImports import StaticLS.IDE.CodeActions.Types +import StaticLS.IDE.CodeActions.UseValidHoleFit qualified as UseValidHoleFit import StaticLS.IDE.Monad import StaticLS.IDE.SourceEdit (SourceEdit) import StaticLS.IDE.SourceEdit qualified as SourceEdit import StaticLS.Monad (StaticLsM) +import StaticLS.ProtoLSP (assistToCodeAction) -getCodeActions :: AbsPath -> LineCol -> StaticLsM [Assist] -getCodeActions path lineCol = do +getCodeActions :: + LSP.TextDocumentIdentifier -> + LSP.CodeActionContext -> + AbsPath -> + LineCol -> + StaticLsM [LSP.CodeAction] +getCodeActions tdi ctx path lineCol = do rope <- getSourceRope path let pos = Rope.lineColToPos rope lineCol let cx = CodeActionContext {path, pos, lineCol} typesCodeActions <- AddTypeSig.codeAction cx importCodeActions <- AutoImport.codeAction cx removeRedundantImports <- RemoveRedundantImports.codeAction cx - let codeActions = typesCodeActions ++ importCodeActions ++ removeRedundantImports - pure codeActions + let issues = S.fromList (mapMaybe Parse.actionableIssue ctx._diagnostics) + issueActions <- join <$> traverse (issueToActions tdi) (S.toList issues) + assistActions <- + traverse assistToCodeAction $ + typesCodeActions + ++ importCodeActions + ++ removeRedundantImports + pure $ assistActions ++ issueActions resolveLazyAssist :: CodeActionMessage -> StaticLsM SourceEdit resolveLazyAssist (CodeActionMessage {kind, path}) = do @@ -34,3 +57,27 @@ resolveLazyAssist (CodeActionMessage {kind, path}) = do AutoImportActionMessage toImport -> AutoImport.resolveLazy path toImport NoMessage -> do pure SourceEdit.empty + +issueToActions :: + LSP.TextDocumentIdentifier -> + Parse.ActionableIssue -> + StaticLsM [LSP.CodeAction] +issueToActions tdi issue = + case issue of + Parse.MissingMethods (Parse.Ignored diag) methods -> + pure [InsertMissingMethods.codeAction tdi diag methods] + + Parse.MissingAssociatedType (Parse.Ignored diag) ty -> + pure [InsertAssociatedType.codeAction tdi diag ty] + + Parse.MissingFields (Parse.Ignored diag) ctor ext flds -> + pure [InsertFields.codeAction tdi diag ctor ext flds] + + Parse.MissingCasses (Parse.Ignored diag) pats -> + pure [InsertCases.codeAction tdi diag pats] + + Parse.RequiredExtension (Parse.Ignored diag) ext -> + pure [AddRequiredExtension.codeAction tdi diag ext] + + Parse.TypedHoleFits (Parse.Ignored diag) fits -> + pure $ UseValidHoleFit.codeAction tdi diag <$> fits diff --git a/src/StaticLS/IDE/CodeActions/AddRequiredExtension.hs b/src/StaticLS/IDE/CodeActions/AddRequiredExtension.hs new file mode 100644 index 00000000..661b9e03 --- /dev/null +++ b/src/StaticLS/IDE/CodeActions/AddRequiredExtension.hs @@ -0,0 +1,25 @@ +module StaticLS.IDE.CodeActions.AddRequiredExtension where + +import StaticLS.IDE.CodeActions.Utils + +import Data.Text qualified as T +import Language.LSP.Protocol.Types qualified as LSP +import StaticLS.IDE.CodeActions.Parse qualified as Parse + +codeAction :: + LSP.TextDocumentIdentifier -> + LSP.Diagnostic -> + Parse.KnownExtension -> + LSP.CodeAction +codeAction = addRequiredExtension + +addRequiredExtension :: + LSP.TextDocumentIdentifier -> + LSP.Diagnostic -> + Parse.KnownExtension -> + LSP.CodeAction +addRequiredExtension tdi diag (Parse.KnownExtension _ text) = + let title = "Add language extension: " <> text + txt = T.concat ["{-# LANGUAGE ", text, " #-}\n"] + rng = insertAt 0 0 + in prefer $ quickFix tdi diag title rng txt diff --git a/src/StaticLS/IDE/CodeActions/InsertAssociatedType.hs b/src/StaticLS/IDE/CodeActions/InsertAssociatedType.hs new file mode 100644 index 00000000..f0c8173f --- /dev/null +++ b/src/StaticLS/IDE/CodeActions/InsertAssociatedType.hs @@ -0,0 +1,14 @@ +module StaticLS.IDE.CodeActions.InsertAssociatedType where + +import Data.Text qualified as T +import Language.LSP.Protocol.Types qualified as LSP +import StaticLS.IDE.CodeActions.Utils (insertBelow, prefer, quickFix) + +codeAction :: LSP.TextDocumentIdentifier -> LSP.Diagnostic -> T.Text -> LSP.CodeAction +codeAction = insertAssociatedType + +insertAssociatedType :: LSP.TextDocumentIdentifier -> LSP.Diagnostic -> T.Text -> LSP.CodeAction +insertAssociatedType tdi diag ty = + let rng = insertBelow diag._range + txt = T.concat [" type ", ty, " = ()\n"] + in prefer $ quickFix tdi diag "Insert associated type." rng txt diff --git a/src/StaticLS/IDE/CodeActions/InsertCases.hs b/src/StaticLS/IDE/CodeActions/InsertCases.hs new file mode 100644 index 00000000..1b64e1c0 --- /dev/null +++ b/src/StaticLS/IDE/CodeActions/InsertCases.hs @@ -0,0 +1,16 @@ +module StaticLS.IDE.CodeActions.InsertCases where + +import StaticLS.IDE.CodeActions.Utils + +import Data.Text qualified as T +import Language.LSP.Protocol.Types qualified as LSP + +codeAction :: LSP.TextDocumentIdentifier -> LSP.Diagnostic -> [T.Text] -> LSP.CodeAction +codeAction = insertCases + +insertCases :: LSP.TextDocumentIdentifier -> LSP.Diagnostic -> [T.Text] -> LSP.CodeAction +insertCases tdi diag pats = + let spaces = indentation diag._range + rng = insertBelow diag._range + cases = foldMap (\pat -> spaces <> pat <> " -> _") pats + in prefer $ quickFix tdi diag "Insert cases." rng cases diff --git a/src/StaticLS/IDE/CodeActions/InsertFields.hs b/src/StaticLS/IDE/CodeActions/InsertFields.hs new file mode 100644 index 00000000..cb3d069e --- /dev/null +++ b/src/StaticLS/IDE/CodeActions/InsertFields.hs @@ -0,0 +1,33 @@ +module StaticLS.IDE.CodeActions.InsertFields where + +import Data.Text qualified as T +import Language.LSP.Protocol.Types qualified as LSP +import StaticLS.IDE.CodeActions.Utils (indentation, prefer, quickFix) + +codeAction :: + LSP.TextDocumentIdentifier -> + LSP.Diagnostic -> + T.Text -> + Maybe T.Text -> + [T.Text] -> + LSP.CodeAction +codeAction = insertFields + +insertFields :: + LSP.TextDocumentIdentifier -> + LSP.Diagnostic -> + T.Text -> + Maybe T.Text -> + [T.Text] -> + LSP.CodeAction +insertFields tdi diag ctor existingFields missingFields = + let spaces = indentation diag._range + seps = "{ " : repeat ", " + formatNewField sep fld = T.concat [spaces, sep, fld, " = _"] + formatOldFields flds = T.concat [spaces, ", ", flds] + newFields = zipWith formatNewField seps missingFields + allFields = case existingFields of + Nothing -> newFields + Just flds -> newFields <> [formatOldFields flds] + renderedExpr = T.concat [ctor, "\n" <> T.unlines allFields <> spaces <> "}\n"] + in prefer $ quickFix tdi diag "Insert fields." (diag._range) renderedExpr diff --git a/src/StaticLS/IDE/CodeActions/InsertMissingMethods.hs b/src/StaticLS/IDE/CodeActions/InsertMissingMethods.hs new file mode 100644 index 00000000..28e05c84 --- /dev/null +++ b/src/StaticLS/IDE/CodeActions/InsertMissingMethods.hs @@ -0,0 +1,15 @@ +module StaticLS.IDE.CodeActions.InsertMissingMethods where + +import StaticLS.IDE.CodeActions.Utils + +import Data.Text qualified as T +import Language.LSP.Protocol.Types qualified as LSP + +codeAction :: LSP.TextDocumentIdentifier -> LSP.Diagnostic -> [T.Text] -> LSP.CodeAction +codeAction = insertMissingMethods + +insertMissingMethods :: LSP.TextDocumentIdentifier -> LSP.Diagnostic -> [T.Text] -> LSP.CodeAction +insertMissingMethods tdi diag methods = + let rng = insertBelow diag._range + txt = T.concat [" ", T.intercalate " = _\n " methods, "\n"] + in prefer $ quickFix tdi diag "Insert missing methods." rng txt diff --git a/src/StaticLS/IDE/CodeActions/Parse.hs b/src/StaticLS/IDE/CodeActions/Parse.hs new file mode 100644 index 00000000..582565c7 --- /dev/null +++ b/src/StaticLS/IDE/CodeActions/Parse.hs @@ -0,0 +1,136 @@ +module StaticLS.IDE.CodeActions.Parse ( + ActionableIssue (..), + Ignored (..), + KnownExtension (..), + actionableIssue, +) where + +import Control.Applicative ((<|>)) +import Control.Monad (guard, (<=<)) +import Data.Foldable (asum, toList) +import Data.Functor (($>)) +import Data.Text qualified as T +import Language.Haskell.TH.LanguageExtensions (Extension) +import Language.LSP.Protocol.Types qualified as LSP +import Text.Regex.TDFA (getAllTextMatches, (=~), (=~~)) + +-- This allows us to ignore diagnostics when comparing `ActionableIssue`s. +-- Otherwise, we end up with duplicates with slightly different wording. +newtype Ignored a = Ignored a deriving (Show) +instance Eq (Ignored a) where (==) _ _ = True +instance Ord (Ignored a) where compare _ _ = EQ + +data KnownExtension = KnownExtension {-# UNPACK #-} !Extension {-# UNPACK #-} !T.Text + deriving (Eq, Ord, Show) + +{-# NOINLINE knownExtensions #-} +knownExtensions :: [KnownExtension] +knownExtensions = (\ext -> KnownExtension ext $ T.pack $ show ext) <$> [minBound .. maxBound] + +data ActionableIssue + = RequiredExtension (Ignored LSP.Diagnostic) KnownExtension + | TypedHoleFits (Ignored LSP.Diagnostic) [T.Text] + | MissingFields (Ignored LSP.Diagnostic) T.Text (Maybe T.Text) [T.Text] + | MissingMethods (Ignored LSP.Diagnostic) [T.Text] + | MissingAssociatedType (Ignored LSP.Diagnostic) T.Text + | MissingCasses (Ignored LSP.Diagnostic) [T.Text] + deriving (Eq, Ord, Show) + +actionableIssue :: LSP.Diagnostic -> Maybe ActionableIssue +actionableIssue diag = + asum + [ checkRequiredExtensions + , checkValidHoleFits + , checkMissingFields + , checkMissingCases + , checkMissingMethods + , checkMissingAssociatedType + ] + where + message :: NormalText + message = normalize diag._message + + checkRequiredExtensions :: Maybe ActionableIssue + checkRequiredExtensions = + let checkExt ext@(KnownExtension _ text) = + guard (T.isInfixOf text $ getNormalText message) $> RequiredExtension (Ignored diag) ext + in asum $ map checkExt knownExtensions + + checkMissingFields :: Maybe ActionableIssue + checkMissingFields = do + (ctor, ext, flds) <- requiredStrictFields message <|> fieldsNotInitialized message + Just $ MissingFields (Ignored diag) (getNormalText ctor) (fmap getNormalText ext) (map getNormalText flds) + + checkMissingCases :: Maybe ActionableIssue + checkMissingCases = MissingCasses (Ignored diag) . map getNormalText <$> nonExhaustivePatterns message + + checkValidHoleFits :: Maybe ActionableIssue + checkValidHoleFits = TypedHoleFits (Ignored diag) . map getNormalText <$> validHoleFits message + + checkMissingMethods :: Maybe ActionableIssue + checkMissingMethods = MissingMethods (Ignored diag) . map getNormalText <$> missingMethods message + + checkMissingAssociatedType :: Maybe ActionableIssue + checkMissingAssociatedType = MissingAssociatedType (Ignored diag) . getNormalText <$> missingAssociatedType message + +newtype NormalText = Normal T.Text + deriving (Eq, Ord, Show) + +getNormalText :: NormalText -> T.Text +getNormalText (Normal txt) = txt + +normalize :: T.Text -> NormalText +normalize = Normal . T.unwords . T.words + +capture :: T.Text -> T.Text -> T.Text -> NormalText -> Maybe NormalText +capture pfx pat sfx = fmap Normal . (=~~ pat) . getNormalText <=< between pfx sfx + +captures :: T.Text -> T.Text -> T.Text -> NormalText -> [NormalText] +captures pfx pat sfx (Normal text) = do + pfxCapSfx <- getAllTextMatches (text =~ T.concat [pfx, pat, sfx]) + cap <- toList (T.stripPrefix pfx =<< T.stripSuffix sfx pfxCapSfx) + [Normal cap] + +between :: T.Text -> T.Text -> NormalText -> Maybe NormalText +between pfx sfx text = do + (_, _, afterPfx) <- cut pfx text + (betweenPfxSfx, _, _) <- cut sfx afterPfx + pure betweenPfxSfx + +cut :: T.Text -> NormalText -> Maybe (NormalText, NormalText, NormalText) +cut pat (Normal txt) = (\(x, y, z) -> (Normal x, Normal y, Normal z)) <$> txt =~~ pat + +ident :: T.Text +ident = "[0-9A-Z'\\._a-z]+" + +validHoleFits :: NormalText -> Maybe [NormalText] +validHoleFits = fmap (captures " " ident " ::\\>") . between "Valid hole fits include" "\\| " + +missingMethods :: NormalText -> Maybe [NormalText] +missingMethods = fmap (captures "‘" ident "’") . between "No explicit implementation for " " • In the instance declaration" + +missingAssociatedType :: NormalText -> Maybe NormalText +missingAssociatedType = capture "No explicit associated type or default declaration for ‘" ident "’" + +nonExhaustivePatterns :: NormalText -> Maybe [NormalText] +nonExhaustivePatterns = fmap (captures " " (ident <> "( _)*") " ") . between "not matched:" " \\| " + +fieldsNotInitialized :: NormalText -> Maybe (NormalText, Maybe NormalText, [NormalText]) +fieldsNotInitialized t1 = do + (_, _, t2) <- cut "Fields of ‘" t1 + (constructor, _, t3) <- cut "’ not initialised: " t2 + (fieldsSection, _, t4) <- cut " • In the expression: " t3 + let missingFields = captures " " ident " :: " fieldsSection + braces <- between "\\{" "\\}" t4 + let existingFields = if T.null (getNormalText braces) then Nothing else Just braces + pure ( constructor, existingFields, missingFields) + +requiredStrictFields :: NormalText -> Maybe (NormalText, Maybe NormalText, [NormalText]) +requiredStrictFields t1 = do + (_, _, t2) <- cut "Constructor ‘" t1 + (constructor, _, t3) <- cut "’ does not have the required strict field\\(s\\):" t2 + (fieldsSection, _, t4) <- cut "• In the expression:" t3 + let missingFields = captures " " ident " ::" fieldsSection + braces <- between "\\{" "\\}" t4 + let existingFields = if T.null (getNormalText braces) then Nothing else Just braces + pure ( constructor, existingFields, missingFields) diff --git a/src/StaticLS/IDE/CodeActions/UseValidHoleFit.hs b/src/StaticLS/IDE/CodeActions/UseValidHoleFit.hs new file mode 100644 index 00000000..0bd5f5de --- /dev/null +++ b/src/StaticLS/IDE/CodeActions/UseValidHoleFit.hs @@ -0,0 +1,12 @@ +module StaticLS.IDE.CodeActions.UseValidHoleFit where + +import Data.Text qualified as T +import Language.LSP.Protocol.Types qualified as LSP +import StaticLS.IDE.CodeActions.Utils (quickFix) + +codeAction :: LSP.TextDocumentIdentifier -> LSP.Diagnostic -> T.Text -> LSP.CodeAction +codeAction = useValidHoleFit + +useValidHoleFit :: LSP.TextDocumentIdentifier -> LSP.Diagnostic -> T.Text -> LSP.CodeAction +useValidHoleFit tdi diag sym = + quickFix tdi diag ("Valid hole fit: " <> sym) (diag._range) sym diff --git a/src/StaticLS/IDE/CodeActions/Utils.hs b/src/StaticLS/IDE/CodeActions/Utils.hs new file mode 100644 index 00000000..6b9328ae --- /dev/null +++ b/src/StaticLS/IDE/CodeActions/Utils.hs @@ -0,0 +1,44 @@ +module StaticLS.IDE.CodeActions.Utils where + +import Data.Text qualified as T +import Language.LSP.Protocol.Types qualified as LSP + +insertAt :: LSP.UInt -> LSP.UInt -> LSP.Range +insertAt line col = + let p = LSP.Position line col + in LSP.Range p p + +insertBelow :: LSP.Range -> LSP.Range +insertBelow (LSP.Range start _) = + insertAt (start._line + 1) 0 + +indentation :: LSP.Range -> T.Text +indentation (LSP.Range start _) = + T.replicate (fromIntegral start._character + 4) " " + +prefer :: LSP.CodeAction -> LSP.CodeAction +prefer action = + action{LSP._isPreferred = Just True} + +quickFix :: + LSP.TextDocumentIdentifier -> + LSP.Diagnostic -> + T.Text -> + LSP.Range -> + T.Text -> + LSP.CodeAction +quickFix tdi diag title range newText = + LSP.CodeAction + { _title = title + , _kind = Just LSP.CodeActionKind_QuickFix + , _diagnostics = Just [diag] + , _edit = Just wsEdit + , _isPreferred = Nothing + , _command = Nothing + , _disabled = Nothing + , _data_ = Nothing + } + where + wsEdit = LSP.WorkspaceEdit Nothing (Just [LSP.InL txtDocEdit]) Nothing + txtDocEdit = LSP.TextDocumentEdit txtDoc [LSP.InL $ LSP.TextEdit range newText] + txtDoc = LSP.OptionalVersionedTextDocumentIdentifier tdi._uri (LSP.InR LSP.Null) diff --git a/static-ls.cabal b/static-ls.cabal index 5d47cdd1..2133315e 100644 --- a/static-ls.cabal +++ b/static-ls.cabal @@ -132,11 +132,19 @@ library StaticLS.Hir.Types StaticLS.IDE.AllExtensions StaticLS.IDE.CodeActions + StaticLS.IDE.CodeActions.AddRequiredExtension StaticLS.IDE.CodeActions.AddTypeSig StaticLS.IDE.CodeActions.AutoExport StaticLS.IDE.CodeActions.AutoImport + StaticLS.IDE.CodeActions.InsertAssociatedType + StaticLS.IDE.CodeActions.InsertCases + StaticLS.IDE.CodeActions.InsertFields + StaticLS.IDE.CodeActions.InsertMissingMethods + StaticLS.IDE.CodeActions.Parse StaticLS.IDE.CodeActions.RemoveRedundantImports StaticLS.IDE.CodeActions.Types + StaticLS.IDE.CodeActions.UseValidHoleFit + StaticLS.IDE.CodeActions.Utils StaticLS.IDE.Completion StaticLS.IDE.Definition StaticLS.IDE.Diagnostics From 7c211180d2854c555e31f117be9eca10966c1bc3 Mon Sep 17 00:00:00 2001 From: Daniel Brice Date: Sun, 6 Jul 2025 08:45:46 -0700 Subject: [PATCH 2/2] Run code formatter --- src/StaticLS/IDE/CodeActions.hs | 5 - src/StaticLS/IDE/CodeActions/InsertFields.hs | 4 +- src/StaticLS/IDE/CodeActions/Parse.hs | 126 +++++++++---------- src/StaticLS/IDE/CodeActions/Utils.hs | 12 +- 4 files changed, 71 insertions(+), 76 deletions(-) diff --git a/src/StaticLS/IDE/CodeActions.hs b/src/StaticLS/IDE/CodeActions.hs index 73920420..99a24a9c 100644 --- a/src/StaticLS/IDE/CodeActions.hs +++ b/src/StaticLS/IDE/CodeActions.hs @@ -66,18 +66,13 @@ issueToActions tdi issue = case issue of Parse.MissingMethods (Parse.Ignored diag) methods -> pure [InsertMissingMethods.codeAction tdi diag methods] - Parse.MissingAssociatedType (Parse.Ignored diag) ty -> pure [InsertAssociatedType.codeAction tdi diag ty] - Parse.MissingFields (Parse.Ignored diag) ctor ext flds -> pure [InsertFields.codeAction tdi diag ctor ext flds] - Parse.MissingCasses (Parse.Ignored diag) pats -> pure [InsertCases.codeAction tdi diag pats] - Parse.RequiredExtension (Parse.Ignored diag) ext -> pure [AddRequiredExtension.codeAction tdi diag ext] - Parse.TypedHoleFits (Parse.Ignored diag) fits -> pure $ UseValidHoleFit.codeAction tdi diag <$> fits diff --git a/src/StaticLS/IDE/CodeActions/InsertFields.hs b/src/StaticLS/IDE/CodeActions/InsertFields.hs index cb3d069e..291a3845 100644 --- a/src/StaticLS/IDE/CodeActions/InsertFields.hs +++ b/src/StaticLS/IDE/CodeActions/InsertFields.hs @@ -27,7 +27,7 @@ insertFields tdi diag ctor existingFields missingFields = formatOldFields flds = T.concat [spaces, ", ", flds] newFields = zipWith formatNewField seps missingFields allFields = case existingFields of - Nothing -> newFields - Just flds -> newFields <> [formatOldFields flds] + Nothing -> newFields + Just flds -> newFields <> [formatOldFields flds] renderedExpr = T.concat [ctor, "\n" <> T.unlines allFields <> spaces <> "}\n"] in prefer $ quickFix tdi diag "Insert fields." (diag._range) renderedExpr diff --git a/src/StaticLS/IDE/CodeActions/Parse.hs b/src/StaticLS/IDE/CodeActions/Parse.hs index 582565c7..86a1725a 100644 --- a/src/StaticLS/IDE/CodeActions/Parse.hs +++ b/src/StaticLS/IDE/CodeActions/Parse.hs @@ -21,60 +21,60 @@ instance Eq (Ignored a) where (==) _ _ = True instance Ord (Ignored a) where compare _ _ = EQ data KnownExtension = KnownExtension {-# UNPACK #-} !Extension {-# UNPACK #-} !T.Text - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show) {-# NOINLINE knownExtensions #-} knownExtensions :: [KnownExtension] knownExtensions = (\ext -> KnownExtension ext $ T.pack $ show ext) <$> [minBound .. maxBound] data ActionableIssue - = RequiredExtension (Ignored LSP.Diagnostic) KnownExtension - | TypedHoleFits (Ignored LSP.Diagnostic) [T.Text] - | MissingFields (Ignored LSP.Diagnostic) T.Text (Maybe T.Text) [T.Text] - | MissingMethods (Ignored LSP.Diagnostic) [T.Text] - | MissingAssociatedType (Ignored LSP.Diagnostic) T.Text - | MissingCasses (Ignored LSP.Diagnostic) [T.Text] - deriving (Eq, Ord, Show) + = RequiredExtension (Ignored LSP.Diagnostic) KnownExtension + | TypedHoleFits (Ignored LSP.Diagnostic) [T.Text] + | MissingFields (Ignored LSP.Diagnostic) T.Text (Maybe T.Text) [T.Text] + | MissingMethods (Ignored LSP.Diagnostic) [T.Text] + | MissingAssociatedType (Ignored LSP.Diagnostic) T.Text + | MissingCasses (Ignored LSP.Diagnostic) [T.Text] + deriving (Eq, Ord, Show) actionableIssue :: LSP.Diagnostic -> Maybe ActionableIssue actionableIssue diag = - asum - [ checkRequiredExtensions - , checkValidHoleFits - , checkMissingFields - , checkMissingCases - , checkMissingMethods - , checkMissingAssociatedType - ] - where - message :: NormalText - message = normalize diag._message - - checkRequiredExtensions :: Maybe ActionableIssue - checkRequiredExtensions = - let checkExt ext@(KnownExtension _ text) = - guard (T.isInfixOf text $ getNormalText message) $> RequiredExtension (Ignored diag) ext - in asum $ map checkExt knownExtensions - - checkMissingFields :: Maybe ActionableIssue - checkMissingFields = do - (ctor, ext, flds) <- requiredStrictFields message <|> fieldsNotInitialized message - Just $ MissingFields (Ignored diag) (getNormalText ctor) (fmap getNormalText ext) (map getNormalText flds) - - checkMissingCases :: Maybe ActionableIssue - checkMissingCases = MissingCasses (Ignored diag) . map getNormalText <$> nonExhaustivePatterns message - - checkValidHoleFits :: Maybe ActionableIssue - checkValidHoleFits = TypedHoleFits (Ignored diag) . map getNormalText <$> validHoleFits message - - checkMissingMethods :: Maybe ActionableIssue - checkMissingMethods = MissingMethods (Ignored diag) . map getNormalText <$> missingMethods message - - checkMissingAssociatedType :: Maybe ActionableIssue - checkMissingAssociatedType = MissingAssociatedType (Ignored diag) . getNormalText <$> missingAssociatedType message + asum + [ checkRequiredExtensions + , checkValidHoleFits + , checkMissingFields + , checkMissingCases + , checkMissingMethods + , checkMissingAssociatedType + ] + where + message :: NormalText + message = normalize diag._message + + checkRequiredExtensions :: Maybe ActionableIssue + checkRequiredExtensions = + let checkExt ext@(KnownExtension _ text) = + guard (T.isInfixOf text $ getNormalText message) $> RequiredExtension (Ignored diag) ext + in asum $ map checkExt knownExtensions + + checkMissingFields :: Maybe ActionableIssue + checkMissingFields = do + (ctor, ext, flds) <- requiredStrictFields message <|> fieldsNotInitialized message + Just $ MissingFields (Ignored diag) (getNormalText ctor) (fmap getNormalText ext) (map getNormalText flds) + + checkMissingCases :: Maybe ActionableIssue + checkMissingCases = MissingCasses (Ignored diag) . map getNormalText <$> nonExhaustivePatterns message + + checkValidHoleFits :: Maybe ActionableIssue + checkValidHoleFits = TypedHoleFits (Ignored diag) . map getNormalText <$> validHoleFits message + + checkMissingMethods :: Maybe ActionableIssue + checkMissingMethods = MissingMethods (Ignored diag) . map getNormalText <$> missingMethods message + + checkMissingAssociatedType :: Maybe ActionableIssue + checkMissingAssociatedType = MissingAssociatedType (Ignored diag) . getNormalText <$> missingAssociatedType message newtype NormalText = Normal T.Text - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show) getNormalText :: NormalText -> T.Text getNormalText (Normal txt) = txt @@ -87,15 +87,15 @@ capture pfx pat sfx = fmap Normal . (=~~ pat) . getNormalText <=< between pfx sf captures :: T.Text -> T.Text -> T.Text -> NormalText -> [NormalText] captures pfx pat sfx (Normal text) = do - pfxCapSfx <- getAllTextMatches (text =~ T.concat [pfx, pat, sfx]) - cap <- toList (T.stripPrefix pfx =<< T.stripSuffix sfx pfxCapSfx) - [Normal cap] + pfxCapSfx <- getAllTextMatches (text =~ T.concat [pfx, pat, sfx]) + cap <- toList (T.stripPrefix pfx =<< T.stripSuffix sfx pfxCapSfx) + [Normal cap] between :: T.Text -> T.Text -> NormalText -> Maybe NormalText between pfx sfx text = do - (_, _, afterPfx) <- cut pfx text - (betweenPfxSfx, _, _) <- cut sfx afterPfx - pure betweenPfxSfx + (_, _, afterPfx) <- cut pfx text + (betweenPfxSfx, _, _) <- cut sfx afterPfx + pure betweenPfxSfx cut :: T.Text -> NormalText -> Maybe (NormalText, NormalText, NormalText) cut pat (Normal txt) = (\(x, y, z) -> (Normal x, Normal y, Normal z)) <$> txt =~~ pat @@ -117,20 +117,20 @@ nonExhaustivePatterns = fmap (captures " " (ident <> "( _)*") " ") . between "no fieldsNotInitialized :: NormalText -> Maybe (NormalText, Maybe NormalText, [NormalText]) fieldsNotInitialized t1 = do - (_, _, t2) <- cut "Fields of ‘" t1 - (constructor, _, t3) <- cut "’ not initialised: " t2 - (fieldsSection, _, t4) <- cut " • In the expression: " t3 - let missingFields = captures " " ident " :: " fieldsSection - braces <- between "\\{" "\\}" t4 - let existingFields = if T.null (getNormalText braces) then Nothing else Just braces - pure ( constructor, existingFields, missingFields) + (_, _, t2) <- cut "Fields of ‘" t1 + (constructor, _, t3) <- cut "’ not initialised: " t2 + (fieldsSection, _, t4) <- cut " • In the expression: " t3 + let missingFields = captures " " ident " :: " fieldsSection + braces <- between "\\{" "\\}" t4 + let existingFields = if T.null (getNormalText braces) then Nothing else Just braces + pure (constructor, existingFields, missingFields) requiredStrictFields :: NormalText -> Maybe (NormalText, Maybe NormalText, [NormalText]) requiredStrictFields t1 = do - (_, _, t2) <- cut "Constructor ‘" t1 - (constructor, _, t3) <- cut "’ does not have the required strict field\\(s\\):" t2 - (fieldsSection, _, t4) <- cut "• In the expression:" t3 - let missingFields = captures " " ident " ::" fieldsSection - braces <- between "\\{" "\\}" t4 - let existingFields = if T.null (getNormalText braces) then Nothing else Just braces - pure ( constructor, existingFields, missingFields) + (_, _, t2) <- cut "Constructor ‘" t1 + (constructor, _, t3) <- cut "’ does not have the required strict field\\(s\\):" t2 + (fieldsSection, _, t4) <- cut "• In the expression:" t3 + let missingFields = captures " " ident " ::" fieldsSection + braces <- between "\\{" "\\}" t4 + let existingFields = if T.null (getNormalText braces) then Nothing else Just braces + pure (constructor, existingFields, missingFields) diff --git a/src/StaticLS/IDE/CodeActions/Utils.hs b/src/StaticLS/IDE/CodeActions/Utils.hs index 6b9328ae..20d81458 100644 --- a/src/StaticLS/IDE/CodeActions/Utils.hs +++ b/src/StaticLS/IDE/CodeActions/Utils.hs @@ -6,7 +6,7 @@ import Language.LSP.Protocol.Types qualified as LSP insertAt :: LSP.UInt -> LSP.UInt -> LSP.Range insertAt line col = let p = LSP.Position line col - in LSP.Range p p + in LSP.Range p p insertBelow :: LSP.Range -> LSP.Range insertBelow (LSP.Range start _) = @@ -18,7 +18,7 @@ indentation (LSP.Range start _) = prefer :: LSP.CodeAction -> LSP.CodeAction prefer action = - action{LSP._isPreferred = Just True} + action {LSP._isPreferred = Just True} quickFix :: LSP.TextDocumentIdentifier -> @@ -38,7 +38,7 @@ quickFix tdi diag title range newText = , _disabled = Nothing , _data_ = Nothing } - where - wsEdit = LSP.WorkspaceEdit Nothing (Just [LSP.InL txtDocEdit]) Nothing - txtDocEdit = LSP.TextDocumentEdit txtDoc [LSP.InL $ LSP.TextEdit range newText] - txtDoc = LSP.OptionalVersionedTextDocumentIdentifier tdi._uri (LSP.InR LSP.Null) + where + wsEdit = LSP.WorkspaceEdit Nothing (Just [LSP.InL txtDocEdit]) Nothing + txtDocEdit = LSP.TextDocumentEdit txtDoc [LSP.InL $ LSP.TextEdit range newText] + txtDoc = LSP.OptionalVersionedTextDocumentIdentifier tdi._uri (LSP.InR LSP.Null)