Skip to content

Instantly share code, notes, and snippets.

@jneira
Created Jul 13, 2020
Embed
What would you like to do?
refactor issues
PS D:\dev\ws\haskell\hls> hlint .\plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs
plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs:8:1-34: Warning: Unused LANGUAGE pragma
Found:
{-# LANGUAGE RecordWildCards #-}
Perhaps you should remove it.
Note: may require `{-# LANGUAGE DisambiguateRecordFields #-}` adding to the top of the file
plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs:9:1-34: Warning: Unused LANGUAGE pragma
Found:
{-# LANGUAGE TupleSections #-}
Perhaps you should remove it.
plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs:11:1-34: Warning: Unused LANGUAGE pragma
Found:
{-# LANGUAGE ViewPatterns #-}
Perhaps you should remove it.
plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs:88:12: Suggestion: Redundant $
Found:
return $ (diagnostics file ideas, Just ())
Perhaps:
return (diagnostics file ideas, Just ())
plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs:206:47-83: Suggestion: Redundant bracket
Found:
Perhaps:
Right . LSP.List . map CACodeAction <$> hlintActions
plugins\hlint-hls-plugin\src\Ide\Plugin\Hlint.hs:308:29-43: Suggestion: Redundant bracket
Found:
Right <$> (return wsEdit)
Perhaps:
Right <$> return wsEdit
6 hints
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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 qualified Data.HashSet as HashSet
import Data.Hashable
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Typeable
import Development.IDE.Core.OfInterest
import Development.IDE.Core.Rules
import Development.IDE.Core.Shake
import Development.IDE.Types.Diagnostics as D
import Development.IDE.Types.Location
import Development.Shake
-- import Development.Shake hiding ( Diagnostic )
import GHC hiding (DynFlags(..))
#ifndef GHC_LIB
import GHC (DynFlags(..))
import HscTypes (hsc_dflags)
#else
import RealGHC (DynFlags(..))
import RealGHC.HscTypes (hsc_dflags)
import qualified RealGHC.EnumSet as EnumSet
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
#endif
import Ide.Logger
import Ide.Types
import Ide.Plugin
import Ide.PluginUtils
import Language.Haskell.HLint as Hlint
import Language.Haskell.LSP.Types
import qualified Language.Haskell.LSP.Types as LSP
import qualified Language.Haskell.LSP.Types.Lens as LSP
import Text.Regex.TDFA.Text()
import GHC.Generics (Generic)
-- ---------------------------------------------------------------------
descriptor :: PluginId -> PluginDescriptor
descriptor plId = (defaultPluginDescriptor plId)
{ pluginRules = rules
, pluginCommands =
[ PluginCommand "applyOne" "Apply a single hint" applyOneCmd
, PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd
]
, pluginCodeActionProvider = Just codeActionProvider
}
data GetHlintDiagnostics = GetHlintDiagnostics
deriving (Eq, Show, Typeable, Generic)
instance Hashable GetHlintDiagnostics
instance NFData GetHlintDiagnostics
instance Binary GetHlintDiagnostics
type instance RuleResult GetHlintDiagnostics = ()
rules :: Rules ()
rules = do
define $ \GetHlintDiagnostics file -> do
ideas <- getIdeas file
return $ (diagnostics file ideas, Just ())
getHlintSettingsRule (HlintEnabled [])
action $ do
files <- getFilesOfInterest
void $ uses GetHlintDiagnostics $ HashSet.toList 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
, _code = Just (LSP.StringValue $ T.pack $ ideaHint idea)
, _source = Just "hlint"
, _message = T.pack $ show idea
, _relatedInformation = Nothing
, _tags = Nothing
}
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 $ "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))
#ifndef GHC_LIB
moduleEx _flags = do
mbpm <- getParsedModule nfp
case mbpm of
Nothing -> return Nothing
Just pm -> do
let anns = pm_annotations pm
let modu = pm_parsed_source pm
return $ Just $ Right (createModuleEx anns modu)
#else
moduleEx flags = do
flags' <- setExtensions flags
Just <$> (liftIO $ parseModuleEx flags' (fromNormalizedFilePath nfp) Nothing)
setExtensions flags = do
hsc <- hscEnv <$> use_ GhcSession nfp
let dflags = hsc_dflags hsc
let hscExts = EnumSet.toList (extensionFlags dflags)
logm $ "getIdeas:setExtensions:hscExtensions:" ++ show hscExts
let hlintExts = mapMaybe (GhclibParserEx.readExtension . show) hscExts
logm $ "getIdeas:setExtensions:hlintExtensions:" ++ show hlintExts
return $ flags { enabledExtensions = hlintExts }
#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
codeActionProvider _ _ plId docId _ context = (Right . LSP.List . map CACodeAction) <$> hlintActions
where
hlintActions :: IO [LSP.CodeAction]
hlintActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags)
-- |Some hints do not have an associated refactoring
validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _ _) =
code /= "Eta reduce"
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") m _ _) =
Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args)
where
codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd)
title = "Apply hint:" <> head (T.lines m)
-- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
args = [toJSON (AOP (docId ^. LSP.uri) start code)]
mkHlintAction (LSP.Diagnostic _r _s _c _source _m _ _) = return Nothing
-- ---------------------------------------------------------------------
applyAllCmd :: CommandFunction Uri
applyAllCmd _lf ide uri = do
let file = maybe (error $ show uri ++ " is not a file.")
toNormalizedFilePath'
(uriToFilePath' uri)
logm $ "applyAllCmd:file=" ++ show file
res <- applyHint ide file Nothing
logm $ "applyAllCmd:res=" ++ show res
return $
case res of
Left err -> (Left (responseError (T.pack $ "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 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)
res <- applyHint ide file (Just oneHint)
logm $ "applyOneCmd:file=" ++ show file
logm $ "applyOneCmd:res=" ++ show res
return $
case res of
Left err -> (Left (responseError (T.pack $ "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
res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `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)
oldContent <- liftIO $ T.readFile fp
liftIO $ logm $ "applyHint:oldContent=" ++ show oldContent
liftIO $ logm $ "applyHint:appliedFile=" ++ show (T.pack appliedFile)
let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions
liftIO $ logm $ "applyHint:diff=" ++ show wsEdit
ExceptT $ Right <$> (return 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 #-}
-- ---------------------------------------------------------------------
{-
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
-- | apply-refact applies refactorings specified by the refact package. It is
-- currently integrated into hlint to enable the automatic application of
-- suggestions.
module Haskell.Ide.Engine.Plugin.ApplyRefact where
import Control.Arrow
import Control.Exception ( IOException
, ErrorCall
, Handler(..)
, catches
, try
)
import Control.Lens hiding ( List )
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson hiding (Error)
import Data.Maybe
#if __GLASGOW_HASKELL__ < 808
import Data.Monoid ((<>))
#endif
import qualified Data.Text as T
import GHC.Generics
import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginUtils
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Extension
import Language.Haskell.HLint4 as Hlint
import qualified Language.Haskell.LSP.Types as LSP
import qualified Language.Haskell.LSP.Types.Lens as LSP
import Refact.Apply
-- ---------------------------------------------------------------------
{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}
{-# ANN module ("HLint: ignore Redundant do" :: String) #-}
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
-- ---------------------------------------------------------------------
type HintTitle = T.Text
applyRefactDescriptor :: PluginId -> PluginDescriptor
applyRefactDescriptor plId = PluginDescriptor
{ pluginId = plId
, pluginName = "ApplyRefact"
, pluginDesc = "apply-refact applies refactorings specified by the refact package. It is currently integrated into hlint to enable the automatic application of suggestions."
, pluginCommands =
[ PluginCommand "applyOne" "Apply a single hint" applyOneCmd
, PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd
]
, pluginCodeActionProvider = Just codeActionProvider
, pluginDiagnosticProvider = Nothing
, pluginHoverProvider = Nothing
, pluginSymbolProvider = Nothing
, pluginFormattingProvider = Nothing
}
-- ---------------------------------------------------------------------
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)
data OneHint = OneHint
{ oneHintPos :: Position
, oneHintTitle :: HintTitle
} deriving (Eq, Show)
applyOneCmd :: ApplyOneParams -> IdeGhcM (IdeResult WorkspaceEdit)
applyOneCmd (AOP uri pos title) = pluginGetFile "applyOne: " uri $ \fp -> do
let oneHint = OneHint pos title
revMapp <- reverseFileMap
let defaultResult = do
debugm "applyOne: no access to the persisted file."
return $ IdeResultOk mempty
withMappedFile fp defaultResult $ \file' -> do
res <- liftToGhc $ applyHint file' (Just oneHint) revMapp
logm $ "applyOneCmd:file=" ++ show fp
logm $ "applyOneCmd:res=" ++ show res
case res of
Left err -> return $ IdeResultFail
(IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null)
Right fs -> return (IdeResultOk fs)
-- ---------------------------------------------------------------------
applyAllCmd :: Uri -> IdeGhcM (IdeResult WorkspaceEdit)
applyAllCmd uri = pluginGetFile "applyAll: " uri $ \fp -> do
let defaultResult = do
debugm "applyAll: no access to the persisted file."
return $ IdeResultOk mempty
revMapp <- reverseFileMap
withMappedFile fp defaultResult $ \file' -> do
res <- liftToGhc $ applyHint file' Nothing revMapp
logm $ "applyAllCmd:res=" ++ show res
case res of
Left err -> return $ IdeResultFail (IdeError PluginError
(T.pack $ "applyAll: " ++ show err) Null)
Right fs -> return (IdeResultOk fs)
-- ---------------------------------------------------------------------
-- AZ:TODO: Why is this in IdeGhcM?
lint :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams)
lint uri = pluginGetFile "lint: " uri $ \fp -> do
let
defaultResult = do
debugm "lint: no access to the persisted file."
return
$ IdeResultOk (PublishDiagnosticsParams (filePathToUri fp) $ List [])
withMappedFile fp defaultResult $ \file' -> do
eitherErrorResult <- liftIO
(try $ runExceptT $ runLint file' [] :: IO
(Either IOException (Either [Diagnostic] [Idea]))
)
case eitherErrorResult of
Left err -> return $ IdeResultFail
(IdeError PluginError (T.pack $ "lint: " ++ show err) Null)
Right res -> case res of
Left diags ->
return
(IdeResultOk
(PublishDiagnosticsParams (filePathToUri fp) $ List diags)
)
Right fs ->
return
$ IdeResultOk
$ PublishDiagnosticsParams (filePathToUri fp)
$ List (map hintToDiagnostic $ stripIgnores fs)
runLint :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea]
runLint fp args = do
(flags,classify,hint) <- liftIO $ argsSettings args
let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}
res <- bimapExceptT parseErrorToDiagnostic id $ ExceptT $ parseModuleEx myflags fp Nothing
pure $ applyHints classify hint [res]
parseErrorToDiagnostic :: Hlint.ParseError -> [Diagnostic]
parseErrorToDiagnostic (Hlint.ParseError l msg contents) =
[Diagnostic
{ _range = srcLoc2Range l
, _severity = Just DsInfo -- Not displayed
, _code = Just (LSP.StringValue "parser")
, _source = Just "hlint"
, _message = T.unlines [T.pack msg,T.pack contents]
, _relatedInformation = Nothing
}]
{-
-- | An idea suggest by a 'Hint'.
data Idea = Idea
{ideaModule :: String -- ^ The module the idea applies to, may be @\"\"@ if the module cannot be determined or is a result of cross-module hints.
,ideaDecl :: String -- ^ The declaration the idea applies to, typically the function name, but may be a type name.
,ideaSeverity :: Severity -- ^ The severity of the idea, e.g. 'Warning'.
,ideaHint :: String -- ^ The name of the hint that generated the idea, e.g. @\"Use reverse\"@.
,ideaSpan :: SrcSpan -- ^ The source code the idea relates to.
,ideaFrom :: String -- ^ The contents of the source code the idea relates to.
,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors).
,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement.
,ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea
}
deriving (Eq,Ord)
-}
-- | 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 #-}
-- ---------------------------------------------------------------------
stripIgnores :: [Idea] -> [Idea]
stripIgnores ideas = filter notIgnored ideas
where
notIgnored idea = ideaSeverity idea /= Ignore
-- ---------------------------------------------------------------------
hintToDiagnostic :: Idea -> Diagnostic
hintToDiagnostic idea
= Diagnostic
{ _range = ss2Range (ideaSpan idea)
, _severity = Just (hintSeverityMap $ ideaSeverity idea)
, _code = Just (LSP.StringValue $ T.pack $ ideaHint idea)
, _source = Just "hlint"
, _message = idea2Message idea
, _relatedInformation = Nothing
}
-- ---------------------------------------------------------------------
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]
-- ---------------------------------------------------------------------
-- | Maps hlint severities to LSP severities
-- | We want to lower the severities so HLint errors and warnings
-- | don't mix with GHC errors and warnings:
-- | as per https://github.com/haskell/haskell-ide-engine/issues/375
hintSeverityMap :: Severity -> DiagnosticSeverity
hintSeverityMap Ignore = DsInfo -- cannot really happen after stripIgnores
hintSeverityMap Suggestion = DsHint
hintSeverityMap Warning = DsInfo
hintSeverityMap Error = DsInfo
-- ---------------------------------------------------------------------
srcLoc2Range :: SrcLoc -> Range
srcLoc2Range (SrcLoc _ l c) = Range ps pe
where
ps = Position (l-1) (c-1)
pe = Position (l-1) 100000
-- ---------------------------------------------------------------------
ss2Range :: SrcSpan -> Range
ss2Range ss = Range ps pe
where
ps = Position (srcSpanStartLine ss - 1) (srcSpanStartColumn ss - 1)
pe = Position (srcSpanEndLine ss - 1) (srcSpanEndColumn ss - 1)
-- ---------------------------------------------------------------------
applyHint :: FilePath -> Maybe OneHint -> (FilePath -> FilePath) -> IdeM (Either String WorkspaceEdit)
applyHint fp mhint fileMap = do
runExceptT $ do
ideas <- getIdeas fp 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 pont 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).
res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches`
[ Handler $ \e -> return (Left (show (e :: IOException)))
, Handler $ \e -> return (Left (show (e :: ErrorCall)))
]
case res of
Right appliedFile -> do
diff <- ExceptT $ Right <$> makeDiffResult fp (T.pack appliedFile) fileMap
liftIO $ logm $ "applyHint:diff=" ++ show diff
return diff
Left err ->
throwE (show err)
-- | Gets HLint ideas for
getIdeas :: MonadIO m => FilePath -> Maybe OneHint -> ExceptT String m [Idea]
getIdeas lintFile mhint = do
let hOpts = hlintOpts lintFile (oneHintPos <$> mhint)
ideas <- runHlint lintFile hOpts
pure $ maybe ideas (`filterIdeas` ideas) mhint
-- | 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 &&& srcSpanStartColumn) . ideaSpan
in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas
hlintOpts :: FilePath -> Maybe Position -> [String]
hlintOpts lintFile mpos =
let
posOpt (Position l c) = " --pos " ++ show (l+1) ++ "," ++ show (c+1)
opts = maybe "" posOpt mpos
in [lintFile, "--quiet", "--refactor", "--refactor-options=" ++ opts ]
runHlint :: MonadIO m => FilePath -> [String] -> ExceptT String m [Idea]
runHlint fp args =
do (flags,classify,hint) <- liftIO $ argsSettings args
let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}
res <- bimapExceptT showParseError id $ ExceptT $ liftIO $ parseModuleEx myflags fp Nothing
pure $ applyHints classify hint [res]
showParseError :: Hlint.ParseError -> String
showParseError (Hlint.ParseError location message content) =
unlines [show location, message, content]
-- ---------------------------------------------------------------------
codeActionProvider :: CodeActionProvider
codeActionProvider plId docId _ context = IdeResultOk <$> hlintActions
where
hlintActions :: IdeM [LSP.CodeAction]
hlintActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags)
-- |Some hints do not have an associated refactoring
validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _) =
case code of
"Eta reduce" -> False
_ -> True
validCommand _ = False
LSP.List diags = context ^. LSP.diagnostics
mkHlintAction :: LSP.Diagnostic -> IdeM (Maybe LSP.CodeAction)
mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") m _) =
Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args)
where
codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd)
title = "Apply hint:" <> head (T.lines m)
-- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
args = [toJSON (AOP (docId ^. LSP.uri) start code)]
mkHlintAction (LSP.Diagnostic _r _s _c _source _m _) = return Nothing
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
modulemoduleIde.Plugin.HlintIde.Plugin.Hlint
((
descriptor
--, provider
--, provider
))wherewhere
importimport Refact.ApplyRefact.Apply
importimport Control.ArrowControl.Arrow ((((&&&&&&))))
importimport Control.DeepSeqControl.DeepSeq
importimport Control.ExceptionControl.Exception
importimport Control.LensControl.Lens ((((^.^.))))
importimport Control.MonadControl.Monad
importimport Control.Monad.IO.ClassControl.Monad.IO.Class
importimport Control.Monad.Trans.ExceptControl.Monad.Trans.Except
importimport Data.Aeson.TypesData.Aeson.Types ((ToJSONToJSON((....)),, FromJSONFromJSON((....)),, ValueValue((....))))
importimport Data.BinaryData.Binary
importimportqualifiedqualified Data.HashSetData.HashSetasas HashSetHashSet
importimport Data.HashableData.Hashable
importimport Data.MaybeData.Maybe
importimportqualifiedqualified Data.TextData.Textasas TT
importimportqualifiedqualified Data.Text.IOData.Text.IOasas TT
importimport Data.TypeableData.Typeable
importimport Development.IDE.Core.OfInterestDevelopment.IDE.Core.OfInterest
importimport Development.IDE.Core.RulesDevelopment.IDE.Core.Rules
importimport Development.IDE.Core.ShakeDevelopment.IDE.Core.Shake
importimport Development.IDE.Types.DiagnosticsDevelopment.IDE.Types.Diagnosticsasas DD
importimport Development.IDE.Types.LocationDevelopment.IDE.Types.Location
importimport Development.Shake
-- import Development.Shake hiding ( Diagnostic )
-- import Development.Shake hiding ( Diagnostic )
importimport GHCGHC hidinghiding((DynFlagsDynFlags((....))))
#ifndef GHC_LIB
importimport GHCGHC ((DynFlagsDynFlags((....))))
importimport HscTypesHscTypes ((hsc_dflagshsc_dflags))
#else
import RealGHC (DynFlags(..))
import RealGHC.HscTypes (hsc_dflags)
import qualified RealGHC.EnumSet as EnumSet
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
#endif
importimport Ide.LoggerIde.Logger
importimport Ide.TypesIde.Types
importimport Ide.PluginIde.Plugin
importimport Ide.PluginUtilsIde.PluginUtils
importimport Language.Haskell.HLintLanguage.Haskell.HLintasas HlintHlint
importimport Language.Haskell.LSP.TypesLanguage.Haskell.LSP.Types
importimportqualifiedqualified Language.Haskell.LSP.TypesLanguage.Haskell.LSP.Typesasas LSPLSP
importimportqualifiedqualified Language.Haskell.LSP.Types.LensLanguage.Haskell.LSP.Types.Lensasas LSPLSP
importimport Text.Regex.TDFA.TextText.Regex.TDFA.Text(())
importimport GHC.GenericsGHC.Generics ((GenericGeneric)
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
descriptordescriptor:::: PluginIdPluginId->-> PluginDescriptorPluginDescriptor
descriptordescriptor plIdplId== ((defaultPluginDescriptordefaultPluginDescriptor plIdplId))
{{ pluginRulespluginRules== rulesrules
,, pluginCommandspluginCommands==
[[ PluginCommandPluginCommand "applyOne""applyOne" "Apply a single hint""Apply a single hint" applyOneCmdapplyOneCmd
,, PluginCommandPluginCommand "applyAll""applyAll" "Apply all hints to the file""Apply all hints to the file" applyAllCmdapplyAllCmd
]]
,, pluginCodeActionProviderpluginCodeActionProvider== JustJust codeActionProvidercodeActionProvider
}}
datadata GetHlintDiagnosticsGetHlintDiagnostics== GetHlintDiagnosticsGetHlintDiagnostics
derivingderiving ((EqEq,, ShowShow,, TypeableTypeable,, GenericGeneric))
instanceinstance HashableHashable GetHlintDiagnosticsGetHlintDiagnostics
instanceinstance NFDataNFData GetHlintDiagnosticsGetHlintDiagnostics
instanceinstance BinaryBinary GetHlintDiagnosticsGetHlintDiagnostics
typetypeinstanceinstance RuleResultRuleResult GetHlintDiagnosticsGetHlintDiagnostics== (())
rulesrules:::: RulesRules (())
rulesrules== dodo
definedefine $$ \\GetHlintDiagnosticsGetHlintDiagnostics filefile->-> dodo
ideasideas<-<- getIdeasgetIdeas filefile
returnreturn $$ ((diagnosticsdiagnostics filefile ideasideas,, JustJust (())))
getHlintSettingsRulegetHlintSettingsRule ((HlintEnabledHlintEnabled [[]]))
actionaction $$ dodo
filesfiles<-<- getFilesOfInterestgetFilesOfInterest
voidvoid $$ usesuses GetHlintDiagnosticsGetHlintDiagnostics $$ HashSet.toListHashSet.toList filesfiles
wherewhere
diagnosticsdiagnostics:::: NormalizedFilePathNormalizedFilePath->-> EitherEither ParseErrorParseError [[IdeaIdea]]->-> [[FileDiagnosticFileDiagnostic]]
diagnosticsdiagnostics filefile ((RightRight ideasideas))==
[[((filefile,, ShowDiagShowDiag,, ideaToDiagnosticideaToDiagnostic ii))|| ii<-<- ideasideas,, ideaSeverityideaSeverity ii /=/= IgnoreIgnore]]
diagnosticsdiagnostics filefile ((LeftLeft parseErrparseErr))==
[[((filefile,, ShowDiagShowDiag,, parseErrorToDiagnosticparseErrorToDiagnostic parseErrparseErr))]]
ideaToDiagnosticideaToDiagnostic:::: IdeaIdea->-> DiagnosticDiagnostic
ideaToDiagnosticideaToDiagnostic ideaidea==
LSP.DiagnosticLSP.Diagnostic{{
_range_range== srcSpanToRangesrcSpanToRange $$ ideaSpanideaSpan ideaidea
,, _severity_severity== JustJust LSP.DsInfoLSP.DsInfo
,, _code_code== JustJust ((LSP.StringValueLSP.StringValue $$ T.packT.pack $$ ideaHintideaHint ideaidea))
,, _source_source== JustJust "hlint""hlint"
,, _message_message== T.packT.pack $$ showshow ideaidea
,, _relatedInformation_relatedInformation== NothingNothing
,, _tags_tags== NothingNothing
}}
parseErrorToDiagnosticparseErrorToDiagnostic:::: ParseErrorParseError->-> DiagnosticDiagnostic
parseErrorToDiagnosticparseErrorToDiagnostic ((Hlint.ParseErrorHlint.ParseError ll msgmsg contentscontents))==
LSP.DiagnosticLSP.Diagnostic{{
_range_range== srcSpanToRangesrcSpanToRange ll
,, _severity_severity== JustJust LSP.DsInfoLSP.DsInfo
,, _code_code== JustJust ((LSP.StringValueLSP.StringValue "parser""parser"))
,, _source_source== JustJust "hlint""hlint"
,, _message_message== T.unlinesT.unlines [[T.packT.pack msgmsg,,T.packT.pack contentscontents]]
,, _relatedInformation_relatedInformation== NothingNothing
,, _tags_tags== NothingNothing
}
-- This one is defined in Development.IDE.GHC.Error but here
-- the types could come from ghc-lib or ghc
-- This one is defined in Development.IDE.GHC.Error but here
-- the types could come from ghc-lib or ghc
srcSpanToRangesrcSpanToRange:::: SrcSpanSrcSpan->-> LSP.RangeLSP.Range
srcSpanToRangesrcSpanToRange ((RealSrcSpanRealSrcSpan spanspan))== RangeRange{{
_start_start== LSP.PositionLSP.Position{{
_line_line== srcSpanStartLinesrcSpanStartLine spanspan -- 11
,, _character_character== srcSpanStartColsrcSpanStartCol spanspan -- 11}}
,, _end_end== LSP.PositionLSP.Position{{
_line_line== srcSpanEndLinesrcSpanEndLine spanspan -- 11
,, _character_character== srcSpanEndColsrcSpanEndCol spanspan -- 11}}
}}
srcSpanToRangesrcSpanToRange ((UnhelpfulSpanUnhelpfulSpan __))== noRangenoRange
getIdeasgetIdeas:::: NormalizedFilePathNormalizedFilePath->-> ActionAction ((EitherEither ParseErrorParseError [[IdeaIdea]]))
getIdeasgetIdeas nfpnfp== dodo
logmlogm $$ "getIdeas:file:""getIdeas:file:" ++++ showshow nfpnfp
((flagsflags,, classifyclassify,, hinthint))<-<- useNoFile_useNoFile_ GetHlintSettingsGetHlintSettings
letlet applyHints'applyHints' ((JustJust ((RightRight modExmodEx))))== RightRight $$ applyHintsapplyHints classifyclassify hinthint [[modExmodEx]]
applyHints'applyHints' ((JustJust ((LeftLeft errerr))))== LeftLeft errerr
applyHints'applyHints' NothingNothing== RightRight [[]]
fmapfmap applyHints'applyHints' ((moduleExmoduleEx flagsflags))
wherewhere moduleExmoduleEx:::: ParseFlagsParseFlags->-> ActionAction ((MaybeMaybe ((EitherEither ParseErrorParseError ModuleExModuleEx))))
#ifndef GHC_LIB
moduleExmoduleEx _flags_flags== dodo
mbpmmbpm<-<- getParsedModulegetParsedModule nfpnfp
casecase mbpmmbpmofof
NothingNothing ->-> returnreturn NothingNothing
JustJust pmpm ->-> dodo
letlet annsanns== pm_annotationspm_annotations pmpm
letlet modumodu== pm_parsed_sourcepm_parsed_source pmpm
returnreturn $$ JustJust $$ RightRight ((createModuleExcreateModuleEx annsanns modumodu)
-- ---------------------------------------------------------------------
#else
moduleEx flags = do
flags' <- setExtensions flags
Just <$> (liftIO $ parseModuleEx flags' (fromNormalizedFilePath nfp) Nothing)
setExtensions flags = do
hsc <- hscEnv <$> use_ GhcSession nfp
let dflags = hsc_dflags hsc
let hscExts = EnumSet.toList (extensionFlags dflags)
logm $ "getIdeas:setExtensions:hscExtensions:" ++ show hscExts
let hlintExts = mapMaybe (GhclibParserEx.readExtension . show) hscExts
logm $ "getIdeas:setExtensions:hlintExtensions:" ++ show hlintExts
return $ flags { enabledExtensions = hlintExts }
#endif
-- ---------------------------------------------------------------------
datadata HlintUsageHlintUsage
== HlintEnabledHlintEnabled {{ cmdArgscmdArgs:::: [[StringString]]}}
|| HlintDisabledHlintDisabled
derivingderiving ShowShow
datadata GetHlintSettingsGetHlintSettings== GetHlintSettingsGetHlintSettings
derivingderiving ((EqEq,, ShowShow,, TypeableTypeable,, GenericGeneric))
instanceinstance HashableHashable GetHlintSettingsGetHlintSettings
instanceinstance NFDataNFData GetHlintSettingsGetHlintSettings
instanceinstance NFDataNFData HintHintwherewhere rnfrnf== rwhnfrwhnf
instanceinstance NFDataNFData ClassifyClassifywherewhere rnfrnf== rwhnfrwhnf
instanceinstance NFDataNFData ParseFlagsParseFlagswherewhere rnfrnf== rwhnfrwhnf
instanceinstance ShowShow HintHintwherewhere showshow== constconst "<hint>""<hint>"
instanceinstance ShowShow ParseFlagsParseFlagswherewhere showshow== constconst "<parseFlags>""<parseFlags>"
instanceinstance BinaryBinary GetHlintSettingsGetHlintSettings
typetypeinstanceinstance RuleResultRuleResult GetHlintSettingsGetHlintSettings== ((ParseFlagsParseFlags,, [[ClassifyClassify]],, HintHint))
getHlintSettingsRulegetHlintSettingsRule:::: HlintUsageHlintUsage->-> RulesRules (())
getHlintSettingsRulegetHlintSettingsRule usageusage==
defineNoFiledefineNoFile $$ \\GetHlintSettingsGetHlintSettings->->
liftIOliftIO $$ casecase usageusageofof
HlintEnabledHlintEnabled cmdArgscmdArgs ->-> argsSettingsargsSettings cmdArgscmdArgs
HlintDisabledHlintDisabled ->-> failfail "hlint configuration unspecified"
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
codeActionProvidercodeActionProvider:::: CodeActionProviderCodeActionProvider
codeActionProvidercodeActionProvider __ __ plIdplId docIddocId __ contextcontext== ((RightRight .. LSP.ListLSP.List .. mapmap CACodeActionCACodeAction)) <$><$> hlintActionshlintActions
wherewhere
hlintActionshlintActions:::: IOIO [[LSP.CodeActionLSP.CodeAction]]
hlintActionshlintActions== catMaybescatMaybes <$><$> mapMmapM mkHlintActionmkHlintAction ((filterfilter validCommandvalidCommand diagsdiags)
-- |Some hints do not have an associated refactoring
-- |Some hints do not have an associated refactoring
validCommandvalidCommand ((LSP.DiagnosticLSP.Diagnostic __ __ ((JustJust ((LSP.StringValueLSP.StringValue codecode)))) ((JustJust "hlint""hlint")) __ __ __))==
codecode /=/= "Eta reduce""Eta reduce"
validCommandvalidCommand __== FalseFalse
LSP.ListLSP.List diagsdiags== contextcontext ^.^. LSP.diagnosticsLSP.diagnostics
mkHlintActionmkHlintAction:::: LSP.DiagnosticLSP.Diagnostic->-> IOIO ((MaybeMaybe LSP.CodeActionLSP.CodeAction))
mkHlintActionmkHlintAction diagdiag@@((LSP.DiagnosticLSP.Diagnostic ((LSP.RangeLSP.Range startstart __)) _s_s ((JustJust ((LSP.StringValueLSP.StringValue codecode)))) ((JustJust "hlint""hlint")) mm __ __))==
JustJust .. codeActioncodeAction <$><$> mkLspCommandmkLspCommand plIdplId "applyOne""applyOne" titletitle ((JustJust argsargs))
wherewhere
codeActioncodeAction cmdcmd== LSP.CodeActionLSP.CodeAction titletitle ((JustJust LSP.CodeActionQuickFixLSP.CodeActionQuickFix)) ((JustJust ((LSP.ListLSP.List [[diagdiag]])))) NothingNothing ((JustJust cmdcmd))
titletitle== "Apply hint:""Apply hint:" <><> headhead ((T.linesT.lines mm)
-- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
-- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
argsargs== [[toJSONtoJSON ((AOPAOP ((docIddocId ^.^. LSP.uriLSP.uri)) startstart codecode))]]
mkHlintActionmkHlintAction ((LSP.DiagnosticLSP.Diagnostic _r_r _s_s _c_c _source_source _m_m __ __))== returnreturn Nothing
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
applyAllCmdapplyAllCmd:::: CommandFunctionCommandFunction UriUri
applyAllCmdapplyAllCmd _lf_lf ideide uriuri== dodo
letlet filefile== maybemaybe ((errorerror $$ showshow uriuri ++++ " is not a file."" is not a file."))
toNormalizedFilePath'toNormalizedFilePath'
((uriToFilePath'uriToFilePath' uriuri))
logmlogm $$ "applyAllCmd:file=""applyAllCmd:file=" ++++ showshow filefile
resres<-<- applyHintapplyHint ideide filefile NothingNothing
logmlogm $$ "applyAllCmd:res=""applyAllCmd:res=" ++++ showshow resres
returnreturn $$
casecase resresofof
LeftLeft errerr ->-> ((LeftLeft ((responseErrorresponseError ((T.packT.pack $$ "applyAll: ""applyAll: " ++++ showshow errerr)))),, NothingNothing))
RightRight fsfs ->-> ((RightRight NullNull,, JustJust ((WorkspaceApplyEditWorkspaceApplyEdit,, ApplyWorkspaceEditParamsApplyWorkspaceEditParams fsfs)))
-- ---------------------------------------------------------------------
-- ---------------------------------------------------------------------
datadata ApplyOneParamsApplyOneParams== AOPAOP
{{ filefile :::: UriUri
,, start_posstart_pos:::: Position
-- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
-- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
,, hintTitlehintTitle:::: HintTitleHintTitle
}} derivingderiving ((EqEq,,ShowShow,,GenericGeneric,,FromJSONFromJSON,,ToJSONToJSON))
typetype HintTitleHintTitle== T.TextT.Text
datadata OneHintOneHint== OneHintOneHint
{{ oneHintPosoneHintPos:::: PositionPosition
,, oneHintTitleoneHintTitle:::: HintTitleHintTitle
}} derivingderiving ((EqEq,, ShowShow))
applyOneCmdapplyOneCmd:::: CommandFunctionCommandFunction ApplyOneParamsApplyOneParams
applyOneCmdapplyOneCmd _lf_lf ideide ((AOPAOP uriuri pospos titletitle))== dodo
letlet oneHintoneHint== OneHintOneHint pospos titletitle
letlet filefile== maybemaybe ((errorerror $$ showshow uriuri ++++ " is not a file."" is not a file.")) toNormalizedFilePath'toNormalizedFilePath'
((uriToFilePath'uriToFilePath' uriuri))
resres<-<- applyHintapplyHint ideide filefile ((JustJust oneHintoneHint))
logmlogm $$ "applyOneCmd:file=""applyOneCmd:file=" ++++ showshow filefile
logmlogm $$ "applyOneCmd:res=""applyOneCmd:res=" ++++ showshow resres
returnreturn $$
casecase resresofof
LeftLeft errerr ->-> ((LeftLeft ((responseErrorresponseError ((T.packT.pack $$ "applyOne: ""applyOne: " ++++ showshow errerr)))),, NothingNothing))
RightRight fsfs ->-> ((RightRight NullNull,, JustJust ((WorkspaceApplyEditWorkspaceApplyEdit,, ApplyWorkspaceEditParamsApplyWorkspaceEditParams fsfs))))
applyHintapplyHint:::: IdeStateIdeState->-> NormalizedFilePathNormalizedFilePath->-> MaybeMaybe OneHintOneHint->-> IOIO ((EitherEither StringString WorkspaceEditWorkspaceEdit))
applyHintapplyHint ideide nfpnfp mhintmhint==
runExceptTrunExceptT $$ dodo
ideasideas<-<- bimapExceptTbimapExceptT showParseErrorshowParseError idid $$ ExceptTExceptT $$ liftIOliftIO $$ runActionrunAction "applyHint""applyHint" ideide $$ getIdeasgetIdeas nfpnfp
letlet ideas'ideas'== maybemaybe ideasideas ((``filterIdeasfilterIdeas`` ideasideas)) mhintmhint
letlet commandscommands== mapmap ((showshow &&&&&& ideaRefactoringideaRefactoring)) ideas'ideas'
liftIOliftIO $$ logmlogm $$ "applyHint:apply=""applyHint:apply=" ++++ showshow 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).
-- 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).
letlet fpfp== fromNormalizedFilePathfromNormalizedFilePath nfpnfp
resres<-<- liftIOliftIO $$ ((RightRight <$><$> applyRefactoringsapplyRefactorings NothingNothing commandscommands fpfp)) ``catchescatches``
[[ HandlerHandler $$ \\ee->-> returnreturn ((LeftLeft ((showshow ((ee:::: IOExceptionIOException))))))
,, HandlerHandler $$ \\ee->-> returnreturn ((LeftLeft ((showshow ((ee:::: ErrorCallErrorCall))))))
]]
casecase resresofof
RightRight appliedFileappliedFile ->-> dodo
letlet uriuri== fromNormalizedUrifromNormalizedUri ((filePathToUri'filePathToUri' nfpnfp))
oldContentoldContent<-<- liftIOliftIO $$ T.readFileT.readFile fpfp
liftIOliftIO $$ logmlogm $$ "applyHint:oldContent=""applyHint:oldContent=" ++++ showshow oldContentoldContent
liftIOliftIO $$ logmlogm $$ "applyHint:appliedFile=""applyHint:appliedFile=" ++++ showshow ((T.packT.pack appliedFileappliedFile))
letlet wsEditwsEdit== diffText'diffText' TrueTrue ((uriuri,, oldContentoldContent)) ((T.packT.pack appliedFileappliedFile)) IncludeDeletionsIncludeDeletions
liftIOliftIO $$ logmlogm $$ "applyHint:diff=""applyHint:diff=" ++++ showshow wsEditwsEdit
ExceptTExceptT $$ RightRight <$><$> ((returnreturn wsEditwsEdit))
LeftLeft errerr ->->
throwEthrowE ((showshow errerr))
where
-- | If we are only interested in applying a particular hint then
-- let's filter out all the irrelevant ideas
-- | If we are only interested in applying a particular hint then
-- let's filter out all the irrelevant ideas
filterIdeasfilterIdeas:::: OneHintOneHint->-> [[IdeaIdea]]->-> [[IdeaIdea]]
filterIdeasfilterIdeas ((OneHintOneHint ((PositionPosition ll cc)) titletitle)) ideasideas==
letlet title'title'== T.unpackT.unpack titletitle
ideaPosideaPos== ((srcSpanStartLinesrcSpanStartLine &&&&&& srcSpanStartColsrcSpanStartCol)) .. toRealSrcSpantoRealSrcSpan .. ideaSpanideaSpan
inin filterfilter ((\\ii->-> ideaHintideaHint ii ==== title'title' &&&& ideaPosideaPos ii ==== ((ll++11,, cc++11)))) ideasideas
toRealSrcSpantoRealSrcSpan ((RealSrcSpanRealSrcSpan realreal))== realreal
toRealSrcSpantoRealSrcSpan ((UnhelpfulSpanUnhelpfulSpan xx))== errorerror $$ "No real source span: ""No real source span: " ++++ showshow xx
showParseErrorshowParseError:::: Hlint.ParseErrorHlint.ParseError->-> StringString
showParseErrorshowParseError ((Hlint.ParseErrorHlint.ParseError locationlocation messagemessage contentcontent))==
unlinesunlines [[showshow locationlocation,, messagemessage,, contentcontent]
-- | Map over both failure and success.
-- | Map over both failure and success.
bimapExceptTbimapExceptT:::: FunctorFunctor mm=>=> ((ee->-> ff))->-> ((aa->-> bb))->-> ExceptTExceptT ee mm aa->-> ExceptTExceptT ff mm bb
bimapExceptTbimapExceptT ff gg ((ExceptTExceptT mm))== ExceptTExceptT ((fmapfmap hh mm))wherewhere
hh ((LeftLeft ee)) == LeftLeft ((ff ee))
hh ((RightRight aa))== RightRight ((gg aa))
{-# INLINE{-# INLINE bimapExceptTbimapExceptT#-}
-- ---------------------------------------------------------------------
{-
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
-- | apply-refact applies refactorings specified by the refact package. It is
-- currently integrated into hlint to enable the automatic application of
-- suggestions.
module Haskell.Ide.Engine.Plugin.ApplyRefact where
import Control.Arrow
import Control.Exception ( IOException
, ErrorCall
, Handler(..)
, catches
, try
)
import Control.Lens hiding ( List )
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson hiding (Error)
import Data.Maybe
import qualified Data.Text as T
import GHC.Generics
import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginUtils
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Extension
import Language.Haskell.HLint4 as Hlint
import qualified Language.Haskell.LSP.Types as LSP
import qualified Language.Haskell.LSP.Types.Lens as LSP
import Refact.Apply
-- ---------------------------------------------------------------------
{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}
{-# ANN module ("HLint: ignore Redundant do" :: String) #-}
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
-- ---------------------------------------------------------------------
type HintTitle = T.Text
applyRefactDescriptor :: PluginId -> PluginDescriptor
applyRefactDescriptor plId = PluginDescriptor
{ pluginId = plId
, pluginName = "ApplyRefact"
, pluginDesc = "apply-refact applies refactorings specified by the refact package. It is currently integrated into hlint to enable the automatic application of suggestions."
, pluginCommands =
[ PluginCommand "applyOne" "Apply a single hint" applyOneCmd
, PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd
]
, pluginCodeActionProvider = Just codeActionProvider
, pluginDiagnosticProvider = Nothing
, pluginHoverProvider = Nothing
, pluginSymbolProvider = Nothing
, pluginFormattingProvider = Nothing
}
-- ---------------------------------------------------------------------
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)
data OneHint = OneHint
{ oneHintPos :: Position
, oneHintTitle :: HintTitle
} deriving (Eq, Show)
applyOneCmd :: ApplyOneParams -> IdeGhcM (IdeResult WorkspaceEdit)
applyOneCmd (AOP uri pos title) = pluginGetFile "applyOne: " uri $ \fp -> do
let oneHint = OneHint pos title
revMapp <- reverseFileMap
let defaultResult = do
debugm "applyOne: no access to the persisted file."
return $ IdeResultOk mempty
withMappedFile fp defaultResult $ \file' -> do
res <- liftToGhc $ applyHint file' (Just oneHint) revMapp
logm $ "applyOneCmd:file=" ++ show fp
logm $ "applyOneCmd:res=" ++ show res
case res of
Left err -> return $ IdeResultFail
(IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null)
Right fs -> return (IdeResultOk fs)
-- ---------------------------------------------------------------------
applyAllCmd :: Uri -> IdeGhcM (IdeResult WorkspaceEdit)
applyAllCmd uri = pluginGetFile "applyAll: " uri $ \fp -> do
let defaultResult = do
debugm "applyAll: no access to the persisted file."
return $ IdeResultOk mempty
revMapp <- reverseFileMap
withMappedFile fp defaultResult $ \file' -> do
res <- liftToGhc $ applyHint file' Nothing revMapp
logm $ "applyAllCmd:res=" ++ show res
case res of
Left err -> return $ IdeResultFail (IdeError PluginError
(T.pack $ "applyAll: " ++ show err) Null)
Right fs -> return (IdeResultOk fs)
-- ---------------------------------------------------------------------
-- AZ:TODO: Why is this in IdeGhcM?
lint :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams)
lint uri = pluginGetFile "lint: " uri $ \fp -> do
let
defaultResult = do
debugm "lint: no access to the persisted file."
return
$ IdeResultOk (PublishDiagnosticsParams (filePathToUri fp) $ List [])
withMappedFile fp defaultResult $ \file' -> do
eitherErrorResult <- liftIO
(try $ runExceptT $ runLint file' [] :: IO
(Either IOException (Either [Diagnostic] [Idea]))
)
case eitherErrorResult of
Left err -> return $ IdeResultFail
(IdeError PluginError (T.pack $ "lint: " ++ show err) Null)
Right res -> case res of
Left diags ->
return
(IdeResultOk
(PublishDiagnosticsParams (filePathToUri fp) $ List diags)
)
Right fs ->
return
$ IdeResultOk
$ PublishDiagnosticsParams (filePathToUri fp)
$ List (map hintToDiagnostic $ stripIgnores fs)
runLint :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea]
runLint fp args = do
(flags,classify,hint) <- liftIO $ argsSettings args
let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}
res <- bimapExceptT parseErrorToDiagnostic id $ ExceptT $ parseModuleEx myflags fp Nothing
pure $ applyHints classify hint [res]
parseErrorToDiagnostic :: Hlint.ParseError -> [Diagnostic]
parseErrorToDiagnostic (Hlint.ParseError l msg contents) =
[Diagnostic
{ _range = srcLoc2Range l
, _severity = Just DsInfo -- Not displayed
, _code = Just (LSP.StringValue "parser")
, _source = Just "hlint"
, _message = T.unlines [T.pack msg,T.pack contents]
, _relatedInformation = Nothing
}]
{-
-- | An idea suggest by a 'Hint'.
data Idea = Idea
{ideaModule :: String -- ^ The module the idea applies to, may be @\"\"@ if the module cannot be determined or is a result of cross-module hints.
,ideaDecl :: String -- ^ The declaration the idea applies to, typically the function name, but may be a type name.
,ideaSeverity :: Severity -- ^ The severity of the idea, e.g. 'Warning'.
,ideaHint :: String -- ^ The name of the hint that generated the idea, e.g. @\"Use reverse\"@.
,ideaSpan :: SrcSpan -- ^ The source code the idea relates to.
,ideaFrom :: String -- ^ The contents of the source code the idea relates to.
,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors).
,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement.
,ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea
}
deriving (Eq,Ord)
-}
-- | 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 #-}
-- ---------------------------------------------------------------------
stripIgnores :: [Idea] -> [Idea]
stripIgnores ideas = filter notIgnored ideas
where
notIgnored idea = ideaSeverity idea /= Ignore
-- ---------------------------------------------------------------------
hintToDiagnostic :: Idea -> Diagnostic
hintToDiagnostic idea
= Diagnostic
{ _range = ss2Range (ideaSpan idea)
, _severity = Just (hintSeverityMap $ ideaSeverity idea)
, _code = Just (LSP.StringValue $ T.pack $ ideaHint idea)
, _source = Just "hlint"
, _message = idea2Message idea
, _relatedInformation = Nothing
}
-- ---------------------------------------------------------------------
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]
-- ---------------------------------------------------------------------
-- | Maps hlint severities to LSP severities
-- | We want to lower the severities so HLint errors and warnings
-- | don't mix with GHC errors and warnings:
-- | as per https://github.com/haskell/haskell-ide-engine/issues/375
hintSeverityMap :: Severity -> DiagnosticSeverity
hintSeverityMap Ignore = DsInfo -- cannot really happen after stripIgnores
hintSeverityMap Suggestion = DsHint
hintSeverityMap Warning = DsInfo
hintSeverityMap Error = DsInfo
-- ---------------------------------------------------------------------
srcLoc2Range :: SrcLoc -> Range
srcLoc2Range (SrcLoc _ l c) = Range ps pe
where
ps = Position (l-1) (c-1)
pe = Position (l-1) 100000
-- ---------------------------------------------------------------------
ss2Range :: SrcSpan -> Range
ss2Range ss = Range ps pe
where
ps = Position (srcSpanStartLine ss - 1) (srcSpanStartColumn ss - 1)
pe = Position (srcSpanEndLine ss - 1) (srcSpanEndColumn ss - 1)
-- ---------------------------------------------------------------------
applyHint :: FilePath -> Maybe OneHint -> (FilePath -> FilePath) -> IdeM (Either String WorkspaceEdit)
applyHint fp mhint fileMap = do
runExceptT $ do
ideas <- getIdeas fp 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 pont 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).
res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches`
[ Handler $ \e -> return (Left (show (e :: IOException)))
, Handler $ \e -> return (Left (show (e :: ErrorCall)))
]
case res of
Right appliedFile -> do
diff <- ExceptT $ Right <$> makeDiffResult fp (T.pack appliedFile) fileMap
liftIO $ logm $ "applyHint:diff=" ++ show diff
return diff
Left err ->
throwE (show err)
-- | Gets HLint ideas for
getIdeas :: MonadIO m => FilePath -> Maybe OneHint -> ExceptT String m [Idea]
getIdeas lintFile mhint = do
let hOpts = hlintOpts lintFile (oneHintPos <$> mhint)
ideas <- runHlint lintFile hOpts
pure $ maybe ideas (`filterIdeas` ideas) mhint
-- | 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 &&& srcSpanStartColumn) . ideaSpan
in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas
hlintOpts :: FilePath -> Maybe Position -> [String]
hlintOpts lintFile mpos =
let
posOpt (Position l c) = " --pos " ++ show (l+1) ++ "," ++ show (c+1)
opts = maybe "" posOpt mpos
in [lintFile, "--quiet", "--refactor", "--refactor-options=" ++ opts ]
runHlint :: MonadIO m => FilePath -> [String] -> ExceptT String m [Idea]
runHlint fp args =
do (flags,classify,hint) <- liftIO $ argsSettings args
let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}
res <- bimapExceptT showParseError id $ ExceptT $ liftIO $ parseModuleEx myflags fp Nothing
pure $ applyHints classify hint [res]
showParseError :: Hlint.ParseError -> String
showParseError (Hlint.ParseError location message content) =
unlines [show location, message, content]
-- ---------------------------------------------------------------------
codeActionProvider :: CodeActionProvider
codeActionProvider plId docId _ context = IdeResultOk <$> hlintActions
where
hlintActions :: IdeM [LSP.CodeAction]
hlintActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags)
-- |Some hints do not have an associated refactoring
validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _) =
case code of
"Eta reduce" -> False
_ -> True
validCommand _ = False
LSP.List diags = context ^. LSP.diagnostics
mkHlintAction :: LSP.Diagnostic -> IdeM (Maybe LSP.CodeAction)
mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") m _) =
Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args)
where
codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd)
title = "Apply hint:" <> head (T.lines m)
-- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
args = [toJSON (AOP (docId ^. LSP.uri) start code)]
mkHlintAction (LSP.Diagnostic _r _s _c _source _m _) = return Nothing
-}
-- ---------------------------------------------------------------------
{-
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
-- | apply-refact applies refactorings specified by the refact package. It is
-- currently integrated into hlint to enable the automatic application of
-- suggestions.
module Haskell.Ide.Engine.Plugin.ApplyRefact where
import Control.Arrow
import Control.Exception ( IOException
, ErrorCall
, Handler(..)
, catches
, try
)
import Control.Lens hiding ( List )
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson hiding (Error)
import Data.Maybe
import Data.Monoid ((<>))
import qualified Data.Text as T
import GHC.Generics
import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginUtils
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Extension
import Language.Haskell.HLint4 as Hlint
import qualified Language.Haskell.LSP.Types as LSP
import qualified Language.Haskell.LSP.Types.Lens as LSP
import Refact.Apply
-- ---------------------------------------------------------------------
{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}
{-# ANN module ("HLint: ignore Redundant do" :: String) #-}
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
-- ---------------------------------------------------------------------
type HintTitle = T.Text
applyRefactDescriptor :: PluginId -> PluginDescriptor
applyRefactDescriptor plId = PluginDescriptor
{ pluginId = plId
, pluginName = "ApplyRefact"
, pluginDesc = "apply-refact applies refactorings specified by the refact package. It is currently integrated into hlint to enable the automatic application of suggestions."
, pluginCommands =
[ PluginCommand "applyOne" "Apply a single hint" applyOneCmd
, PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd
]
, pluginCodeActionProvider = Just codeActionProvider
, pluginDiagnosticProvider = Nothing
, pluginHoverProvider = Nothing
, pluginSymbolProvider = Nothing
, pluginFormattingProvider = Nothing
}
-- ---------------------------------------------------------------------
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)
data OneHint = OneHint
{ oneHintPos :: Position
, oneHintTitle :: HintTitle
} deriving (Eq, Show)
applyOneCmd :: ApplyOneParams -> IdeGhcM (IdeResult WorkspaceEdit)
applyOneCmd (AOP uri pos title) = pluginGetFile "applyOne: " uri $ \fp -> do
let oneHint = OneHint pos title
revMapp <- reverseFileMap
let defaultResult = do
debugm "applyOne: no access to the persisted file."
return $ IdeResultOk mempty
withMappedFile fp defaultResult $ \file' -> do
res <- liftToGhc $ applyHint file' (Just oneHint) revMapp
logm $ "applyOneCmd:file=" ++ show fp
logm $ "applyOneCmd:res=" ++ show res
case res of
Left err -> return $ IdeResultFail
(IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null)
Right fs -> return (IdeResultOk fs)
-- ---------------------------------------------------------------------
applyAllCmd :: Uri -> IdeGhcM (IdeResult WorkspaceEdit)
applyAllCmd uri = pluginGetFile "applyAll: " uri $ \fp -> do
let defaultResult = do
debugm "applyAll: no access to the persisted file."
return $ IdeResultOk mempty
revMapp <- reverseFileMap
withMappedFile fp defaultResult $ \file' -> do
res <- liftToGhc $ applyHint file' Nothing revMapp
logm $ "applyAllCmd:res=" ++ show res
case res of
Left err -> return $ IdeResultFail (IdeError PluginError
(T.pack $ "applyAll: " ++ show err) Null)
Right fs -> return (IdeResultOk fs)
-- ---------------------------------------------------------------------
-- AZ:TODO: Why is this in IdeGhcM?
lint :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams)
lint uri = pluginGetFile "lint: " uri $ \fp -> do
let
defaultResult = do
debugm "lint: no access to the persisted file."
return
$ IdeResultOk (PublishDiagnosticsParams (filePathToUri fp) $ List [])
withMappedFile fp defaultResult $ \file' -> do
eitherErrorResult <- liftIO
(try $ runExceptT $ runLint file' [] :: IO
(Either IOException (Either [Diagnostic] [Idea]))
)
case eitherErrorResult of
Left err -> return $ IdeResultFail
(IdeError PluginError (T.pack $ "lint: " ++ show err) Null)
Right res -> case res of
Left diags ->
return
(IdeResultOk
(PublishDiagnosticsParams (filePathToUri fp) $ List diags)
)
Right fs ->
return
$ IdeResultOk
$ PublishDiagnosticsParams (filePathToUri fp)
$ List (map hintToDiagnostic $ stripIgnores fs)
runLint :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea]
runLint fp args = do
(flags,classify,hint) <- liftIO $ argsSettings args
let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}
res <- bimapExceptT parseErrorToDiagnostic id $ ExceptT $ parseModuleEx myflags fp Nothing
pure $ applyHints classify hint [res]
parseErrorToDiagnostic :: Hlint.ParseError -> [Diagnostic]
parseErrorToDiagnostic (Hlint.ParseError l msg contents) =
[Diagnostic
{ _range = srcLoc2Range l
, _severity = Just DsInfo -- Not displayed
, _code = Just (LSP.StringValue "parser")
, _source = Just "hlint"
, _message = T.unlines [T.pack msg,T.pack contents]
, _relatedInformation = Nothing
}]
{-
-- | An idea suggest by a 'Hint'.
data Idea = Idea
{ideaModule :: String -- ^ The module the idea applies to, may be @\"\"@ if the module cannot be determined or is a result of cross-module hints.
,ideaDecl :: String -- ^ The declaration the idea applies to, typically the function name, but may be a type name.
,ideaSeverity :: Severity -- ^ The severity of the idea, e.g. 'Warning'.
,ideaHint :: String -- ^ The name of the hint that generated the idea, e.g. @\"Use reverse\"@.
,ideaSpan :: SrcSpan -- ^ The source code the idea relates to.
,ideaFrom :: String -- ^ The contents of the source code the idea relates to.
,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors).
,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement.
,ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea
}
deriving (Eq,Ord)
-}
-- | 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 #-}
-- ---------------------------------------------------------------------
stripIgnores :: [Idea] -> [Idea]
stripIgnores ideas = filter notIgnored ideas
where
notIgnored idea = ideaSeverity idea /= Ignore
-- ---------------------------------------------------------------------
hintToDiagnostic :: Idea -> Diagnostic
hintToDiagnostic idea
= Diagnostic
{ _range = ss2Range (ideaSpan idea)
, _severity = Just (hintSeverityMap $ ideaSeverity idea)
, _code = Just (LSP.StringValue $ T.pack $ ideaHint idea)
, _source = Just "hlint"
, _message = idea2Message idea
, _relatedInformation = Nothing
}
-- ---------------------------------------------------------------------
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]
-- ---------------------------------------------------------------------
-- | Maps hlint severities to LSP severities
-- | We want to lower the severities so HLint errors and warnings
-- | don't mix with GHC errors and warnings:
-- | as per https://github.com/haskell/haskell-ide-engine/issues/375
hintSeverityMap :: Severity -> DiagnosticSeverity
hintSeverityMap Ignore = DsInfo -- cannot really happen after stripIgnores
hintSeverityMap Suggestion = DsHint
hintSeverityMap Warning = DsInfo
hintSeverityMap Error = DsInfo
-- ---------------------------------------------------------------------
srcLoc2Range :: SrcLoc -> Range
srcLoc2Range (SrcLoc _ l c) = Range ps pe
where
ps = Position (l-1) (c-1)
pe = Position (l-1) 100000
-- ---------------------------------------------------------------------
ss2Range :: SrcSpan -> Range
ss2Range ss = Range ps pe
where
ps = Position (srcSpanStartLine ss - 1) (srcSpanStartColumn ss - 1)
pe = Position (srcSpanEndLine ss - 1) (srcSpanEndColumn ss - 1)
-- ---------------------------------------------------------------------
applyHint :: FilePath -> Maybe OneHint -> (FilePath -> FilePath) -> IdeM (Either String WorkspaceEdit)
applyHint fp mhint fileMap = do
runExceptT $ do
ideas <- getIdeas fp 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 pont 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).
res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches`
[ Handler $ \e -> return (Left (show (e :: IOException)))
, Handler $ \e -> return (Left (show (e :: ErrorCall)))
]
case res of
Right appliedFile -> do
diff <- ExceptT $ Right <$> makeDiffResult fp (T.pack appliedFile) fileMap
liftIO $ logm $ "applyHint:diff=" ++ show diff
return diff
Left err ->
throwE (show err)
-- | Gets HLint ideas for
getIdeas :: MonadIO m => FilePath -> Maybe OneHint -> ExceptT String m [Idea]
getIdeas lintFile mhint = do
let hOpts = hlintOpts lintFile (oneHintPos <$> mhint)
ideas <- runHlint lintFile hOpts
pure $ maybe ideas (`filterIdeas` ideas) mhint
-- | 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 &&& srcSpanStartColumn) . ideaSpan
in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas
hlintOpts :: FilePath -> Maybe Position -> [String]
hlintOpts lintFile mpos =
let
posOpt (Position l c) = " --pos " ++ show (l+1) ++ "," ++ show (c+1)
opts = maybe "" posOpt mpos
in [lintFile, "--quiet", "--refactor", "--refactor-options=" ++ opts ]
runHlint :: MonadIO m => FilePath -> [String] -> ExceptT String m [Idea]
runHlint fp args =
do (flags,classify,hint) <- liftIO $ argsSettings args
let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}
res <- bimapExceptT showParseError id $ ExceptT $ liftIO $ parseModuleEx myflags fp Nothing
pure $ applyHints classify hint [res]
showParseError :: Hlint.ParseError -> String
showParseError (Hlint.ParseError location message content) =
unlines [show location, message, content]
-- ---------------------------------------------------------------------
codeActionProvider :: CodeActionProvider
codeActionProvider plId docId _ context = IdeResultOk <$> hlintActions
where
hlintActions :: IdeM [LSP.CodeAction]
hlintActions = catMaybes <$> mapM mkHlintAction (filter validCommand diags)
-- |Some hints do not have an associated refactoring
validCommand (LSP.Diagnostic _ _ (Just (LSP.StringValue code)) (Just "hlint") _ _) =
case code of
"Eta reduce" -> False
_ -> True
validCommand _ = False
LSP.List diags = context ^. LSP.diagnostics
mkHlintAction :: LSP.Diagnostic -> IdeM (Maybe LSP.CodeAction)
mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (LSP.StringValue code)) (Just "hlint") m _) =
Just . codeAction <$> mkLspCommand plId "applyOne" title (Just args)
where
codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing (Just cmd)
title = "Apply hint:" <> head (T.lines m)
-- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
args = [toJSON (AOP (docId ^. LSP.uri) start code)]
mkHlintAction (LSP.Diagnostic _r _s _c _source _m _) = return Nothing
-}
#endif
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment