hls-hlint-plugin (empty) → 0.1.0.0
raw patch · 3 files changed
+677/−0 lines, 3 filesdep +Diffdep +aesondep +apply-refact
Dependencies added: Diff, aeson, apply-refact, base, binary, bytestring, containers, data-default, deepseq, directory, extra, filepath, ghc, ghc-lib, ghc-lib-parser-ex, ghcide, hashable, haskell-lsp, hlint, hls-plugin-api, hslogger, lens, regex-tdfa, shake, temporary, text, transformers, unordered-containers
Files
- LICENSE +201/−0
- hls-hlint-plugin.cabal +71/−0
- src/Ide/Plugin/Hlint.hs +405/−0
+ LICENSE view
@@ -0,0 +1,201 @@+ Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License.
+ hls-hlint-plugin.cabal view
@@ -0,0 +1,71 @@+cabal-version: 2.2 +name: hls-hlint-plugin +version: 0.1.0.0 +synopsis: Hlint integration plugin with Haskell Language Server +description: Please see Haskell Language Server Readme (https://github.com/haskell/haskell-language-server#readme) +license: Apache-2.0 +license-file: LICENSE +author: https://github.com/haskell/haskell-language-server/contributors +maintainer: https://github.com/haskell/haskell-language-server/contributors +copyright: Alan Zimmerman +category: Web +build-type: Simple + +flag pedantic + description: Enable -Werror + default: False + manual: True + +flag ghc-lib + default: False + manual: True + description: + Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported + +library + exposed-modules: Ide.Plugin.Hlint + hs-source-dirs: src + build-depends: + , aeson + , apply-refact + , base >=4.12 && <5 + , binary + , bytestring + , containers + , data-default + , deepseq + , Diff + , directory + , extra + , filepath + , ghcide + , hashable + , haskell-lsp + , hlint >=3.2 + , hls-plugin-api + , hslogger + , lens + , regex-tdfa + , shake + , temporary + , text + , transformers + , unordered-containers + + if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <8.11.0)) + build-depends: ghc ^>= 8.10 + + else + build-depends: + , ghc + , ghc-lib ^>= 8.10.2.20200916 + , ghc-lib-parser-ex ^>= 8.10 + + cpp-options: -DGHC_LIB + + ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing + + if flag(pedantic) + ghc-options: -Werror + + default-language: Haskell2010
+ src/Ide/Plugin/Hlint.hs view
@@ -0,0 +1,405 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Hlint + ( + descriptor + --, provider + ) where +import Refact.Apply +import Control.Arrow ((&&&)) +import Control.DeepSeq +import Control.Exception +import Control.Lens ((^.)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..)) +import Data.Binary +import Data.Hashable +import qualified Data.HashMap.Strict as Map +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Typeable +import Development.IDE +import Development.IDE.Core.Rules (defineNoFile) +import Development.IDE.Core.Shake (getDiagnostics) + +#ifdef GHC_LIB +import Data.List (nub) +import "ghc-lib" GHC hiding (DynFlags(..)) +import "ghc" GHC as RealGHC (DynFlags(..)) +import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags) +import qualified "ghc" EnumSet as EnumSet +import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension) +#else +import Development.IDE.GHC.Compat hiding (DynFlags(..)) +#endif + +import Ide.Logger +import Ide.Types +import Ide.Plugin.Config +import Ide.PluginUtils +import Language.Haskell.HLint as Hlint +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.Haskell.LSP.Types.Lens as LSP +import System.FilePath (takeFileName) +import System.IO (hPutStr, noNewlineTranslation, hSetNewlineMode, utf8, hSetEncoding, IOMode(WriteMode), withFile, hClose) +import System.IO.Temp +import Text.Regex.TDFA.Text() +import GHC.Generics (Generic) + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginRules = rules plId + , pluginCommands = + [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd + , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd + ] + , pluginCodeActionProvider = Just codeActionProvider + } + +-- This rule only exists for generating file diagnostics +-- so the RuleResult is empty +data GetHlintDiagnostics = GetHlintDiagnostics + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetHlintDiagnostics +instance NFData GetHlintDiagnostics +instance Binary GetHlintDiagnostics + +type instance RuleResult GetHlintDiagnostics = () + +-- | Hlint rules to generate file diagnostics based on hlint hints +-- | This rule is recomputed when: +-- | - The files of interest have changed via `getFilesOfInterest` +-- | - One of those files has been edited via +-- | - `getIdeas` -> `getParsedModule` in any case +-- | - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc +-- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction` +-- | - The hlint specific settings have changed, via `getHlintSettingsRule` +rules :: PluginId -> Rules () +rules plugin = do + define $ \GetHlintDiagnostics file -> do + config <- getClientConfigAction + let pluginConfig = configForPlugin config plugin + let hlintOn' = hlintOn config && pluginEnabled pluginConfig plcDiagnosticsOn + ideas <- if hlintOn' then getIdeas file else return (Right []) + return (diagnostics file ideas, Just ()) + + getHlintSettingsRule (HlintEnabled []) + + action $ do + files <- getFilesOfInterest + void $ uses GetHlintDiagnostics $ Map.keys files + + where + + diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic] + diagnostics file (Right ideas) = + [(file, ShowDiag, ideaToDiagnostic i) | i <- ideas, ideaSeverity i /= Ignore] + diagnostics file (Left parseErr) = + [(file, ShowDiag, parseErrorToDiagnostic parseErr)] + + ideaToDiagnostic :: Idea -> Diagnostic + ideaToDiagnostic idea = + LSP.Diagnostic { + _range = srcSpanToRange $ ideaSpan idea + , _severity = Just LSP.DsInfo + -- we are encoding the fact that idea has refactorings in diagnostic code + , _code = Just (LSP.StringValue $ T.pack $ codePre ++ ideaHint idea) + , _source = Just "hlint" + , _message = idea2Message idea + , _relatedInformation = Nothing + , _tags = Nothing + } + where codePre = if null $ ideaRefactoring idea then "" else "refact:" + + idea2Message :: Idea -> T.Text + idea2Message idea = T.unlines $ [T.pack $ ideaHint idea, "Found:", " " <> T.pack (ideaFrom idea)] + <> toIdea <> map (T.pack . show) (ideaNote idea) + where + toIdea :: [T.Text] + toIdea = case ideaTo idea of + Nothing -> [] + Just i -> [T.pack "Why not:", T.pack $ " " ++ i] + + + parseErrorToDiagnostic :: ParseError -> Diagnostic + parseErrorToDiagnostic (Hlint.ParseError l msg contents) = + LSP.Diagnostic { + _range = srcSpanToRange l + , _severity = Just LSP.DsInfo + , _code = Just (LSP.StringValue "parser") + , _source = Just "hlint" + , _message = T.unlines [T.pack msg,T.pack contents] + , _relatedInformation = Nothing + , _tags = Nothing + } + + -- This one is defined in Development.IDE.GHC.Error but here + -- the types could come from ghc-lib or ghc + srcSpanToRange :: SrcSpan -> LSP.Range + srcSpanToRange (RealSrcSpan span) = Range { + _start = LSP.Position { + _line = srcSpanStartLine span - 1 + , _character = srcSpanStartCol span - 1} + , _end = LSP.Position { + _line = srcSpanEndLine span - 1 + , _character = srcSpanEndCol span - 1} + } + srcSpanToRange (UnhelpfulSpan _) = noRange + +getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea]) +getIdeas nfp = do + logm $ "hlint:getIdeas:file:" ++ show nfp + (flags, classify, hint) <- useNoFile_ GetHlintSettings + + let applyHints' (Just (Right modEx)) = Right $ applyHints classify hint [modEx] + applyHints' (Just (Left err)) = Left err + applyHints' Nothing = Right [] + + fmap applyHints' (moduleEx flags) + + where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx)) +#ifdef GHC_LIB + moduleEx flags = do + mbpm <- getParsedModule nfp + -- If ghc was not able to parse the module, we disable hlint diagnostics + if isNothing mbpm + then return Nothing + else do + flags' <- setExtensions flags + (_, contents) <- getFileContents nfp + let fp = fromNormalizedFilePath nfp + let contents' = T.unpack <$> contents + Just <$> (liftIO $ parseModuleEx flags' fp contents') + + setExtensions flags = do + hsc <- hscEnv <$> use_ GhcSession nfp + let dflags = hsc_dflags hsc + let hscExts = EnumSet.toList (extensionFlags dflags) + let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts + let hlintExts = nub $ enabledExtensions flags ++ hscExts' + logm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts + return $ flags { enabledExtensions = hlintExts } +#else + moduleEx _flags = do + mbpm <- getParsedModule nfp + return $ createModule <$> mbpm + where createModule pm = Right (createModuleEx anns modu) + where anns = pm_annotations pm + modu = pm_parsed_source pm +#endif + +-- --------------------------------------------------------------------- + +data HlintUsage + = HlintEnabled { cmdArgs :: [String] } + | HlintDisabled + deriving Show + +data GetHlintSettings = GetHlintSettings + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetHlintSettings +instance NFData GetHlintSettings +instance NFData Hint where rnf = rwhnf +instance NFData Classify where rnf = rwhnf +instance NFData ParseFlags where rnf = rwhnf +instance Show Hint where show = const "<hint>" +instance Show ParseFlags where show = const "<parseFlags>" +instance Binary GetHlintSettings + +type instance RuleResult GetHlintSettings = (ParseFlags, [Classify], Hint) + +getHlintSettingsRule :: HlintUsage -> Rules () +getHlintSettingsRule usage = + defineNoFile $ \GetHlintSettings -> + liftIO $ case usage of + HlintEnabled cmdArgs -> argsSettings cmdArgs + HlintDisabled -> fail "hlint configuration unspecified" + +-- --------------------------------------------------------------------- + +codeActionProvider :: CodeActionProvider IdeState +codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CACodeAction <$> getCodeActions + where + + getCodeActions = do + applyOne <- applyOneActions + diags <- getDiagnostics ideState + let docNfp = toNormalizedFilePath' <$> uriToFilePath' (docId ^. LSP.uri) + numHintsInDoc = length + [d | (nfp, _, d) <- diags + , validCommand d + , Just nfp == docNfp + ] + -- We only want to show the applyAll code action if there is more than 1 + -- hint in the current document + if numHintsInDoc > 1 then do + applyAll <- applyAllAction + pure $ applyAll:applyOne + else + pure applyOne + + applyAllAction = do + let args = Just [toJSON (docId ^. LSP.uri)] + cmd <- mkLspCommand plId "applyAll" "Apply all hints" args + pure $ LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing (Just cmd) + + applyOneActions :: IO [LSP.CodeAction] + applyOneActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags) + + -- |Some hints do not have an associated refactoring + validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _ _) = + "refact:" `T.isPrefixOf` code + validCommand _ = + False + + LSP.List diags = context ^. LSP.diagnostics + + mkHlintAction :: LSP.Diagnostic -> IO (Maybe LSP.CodeAction) + mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") _ _ _) = + Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args) + where + codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd) + -- we have to recover the original ideaHint removing the prefix + ideaHint = T.replace "refact:" "" code + title = "Apply hint: " <> ideaHint + -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location) + args = [toJSON (AOP (docId ^. LSP.uri) start ideaHint)] + mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = return Nothing + +-- --------------------------------------------------------------------- + +applyAllCmd :: CommandFunction IdeState Uri +applyAllCmd lf ide uri = do + let file = maybe (error $ show uri ++ " is not a file.") + toNormalizedFilePath' + (uriToFilePath' uri) + withIndefiniteProgress lf "Applying all hints" Cancellable $ do + logm $ "hlint:applyAllCmd:file=" ++ show file + res <- applyHint ide file Nothing + logm $ "hlint:applyAllCmd:res=" ++ show res + return $ + case res of + Left err -> (Left (responseError (T.pack $ "hlint:applyAll: " ++ show err)), Nothing) + Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs)) + +-- --------------------------------------------------------------------- + +data ApplyOneParams = AOP + { file :: Uri + , start_pos :: Position + -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them. + , hintTitle :: HintTitle + } deriving (Eq,Show,Generic,FromJSON,ToJSON) + +type HintTitle = T.Text + +data OneHint = OneHint + { oneHintPos :: Position + , oneHintTitle :: HintTitle + } deriving (Eq, Show) + +applyOneCmd :: CommandFunction IdeState ApplyOneParams +applyOneCmd lf ide (AOP uri pos title) = do + let oneHint = OneHint pos title + let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' + (uriToFilePath' uri) + let progTitle = "Applying hint: " <> title + withIndefiniteProgress lf progTitle Cancellable $ do + logm $ "hlint:applyOneCmd:file=" ++ show file + res <- applyHint ide file (Just oneHint) + logm $ "hlint:applyOneCmd:res=" ++ show res + return $ + case res of + Left err -> (Left (responseError (T.pack $ "hlint:applyOne: " ++ show err)), Nothing) + Right fs -> (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams fs)) + +applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) +applyHint ide nfp mhint = + runExceptT $ do + ideas <- bimapExceptT showParseError id $ ExceptT $ liftIO $ runAction "applyHint" ide $ getIdeas nfp + let ideas' = maybe ideas (`filterIdeas` ideas) mhint + let commands = map (show &&& ideaRefactoring) ideas' + liftIO $ logm $ "applyHint:apply=" ++ show commands + -- set Nothing as "position" for "applyRefactorings" because + -- applyRefactorings expects the provided position to be _within_ the scope + -- of each refactoring it will apply. + -- But "Idea"s returned by HLint point to starting position of the expressions + -- that contain refactorings, so they are often outside the refactorings' boundaries. + -- Example: + -- Given an expression "hlintTest = reid $ (myid ())" + -- Hlint returns an idea at the position (1,13) + -- That contains "Redundant brackets" refactoring at position (1,20): + -- + -- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n reid $ (myid ())\nWhy not:\n reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])] + -- + -- If we provide "applyRefactorings" with "Just (1,13)" then + -- the "Redundant bracket" hint will never be executed + -- because SrcSpan (1,20,??,??) doesn't contain position (1,13). + let fp = fromNormalizedFilePath nfp + (_, mbOldContent) <- liftIO $ runAction "hlint" ide $ getFileContents nfp + oldContent <- maybe (liftIO $ T.readFile fp) return mbOldContent + -- We need to save a file with last edited contents cause `apply-refact` + -- doesn't expose a function taking directly contents instead a file path. + -- Ideally we should try to expose that function upstream and remove this. + res <- liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do + hClose h + writeFileUTF8NoNewLineTranslation temp oldContent + (Right <$> applyRefactorings Nothing commands temp) `catches` + [ Handler $ \e -> return (Left (show (e :: IOException))) + , Handler $ \e -> return (Left (show (e :: ErrorCall))) + ] + case res of + Right appliedFile -> do + let uri = fromNormalizedUri (filePathToUri' nfp) + let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions + liftIO $ logm $ "hlint:applyHint:diff=" ++ show wsEdit + ExceptT $ return (Right wsEdit) + Left err -> + throwE (show err) + where + -- | If we are only interested in applying a particular hint then + -- let's filter out all the irrelevant ideas + filterIdeas :: OneHint -> [Idea] -> [Idea] + filterIdeas (OneHint (Position l c) title) ideas = + let title' = T.unpack title + ideaPos = (srcSpanStartLine &&& srcSpanStartCol) . toRealSrcSpan . ideaSpan + in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas + + toRealSrcSpan (RealSrcSpan real) = real + toRealSrcSpan (UnhelpfulSpan x) = error $ "No real source span: " ++ show x + + showParseError :: Hlint.ParseError -> String + showParseError (Hlint.ParseError location message content) = + unlines [show location, message, content] + +-- | Map over both failure and success. +bimapExceptT :: Functor m => (e -> f) -> (a -> b) -> ExceptT e m a -> ExceptT f m b +bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where + h (Left e) = Left (f e) + h (Right a) = Right (g a) +{-# INLINE bimapExceptT #-} + +writeFileUTF8NoNewLineTranslation :: FilePath -> T.Text -> IO() +writeFileUTF8NoNewLineTranslation file txt = + withFile file WriteMode $ \h -> do + hSetEncoding h utf8 + hSetNewlineMode h noNewlineTranslation + hPutStr h (T.unpack txt)