From eed4f41e7388e6a55d8e998e47b6ffcf3079cb8b Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 6 Feb 2020 23:51:50 +0000 Subject: [PATCH 1/4] Generalize formatter plugin support, add Floskell First pass only, need to (re-)enable tests, and find a way of selecting between multiple formatters. Apart from only installing a single formatter plugin. --- haskell-language-server.cabal | 4 ++ src/Ide/Plugin/Floskell.hs | 97 ++++++++++++++++++++++++++++++ src/Ide/Plugin/Formatter.hs | 107 ++++++++++++++++++++++++++++++++++ stack-8.6.5.yaml | 1 + stack.yaml | 2 + 5 files changed, 211 insertions(+) create mode 100644 src/Ide/Plugin/Floskell.hs create mode 100644 src/Ide/Plugin/Formatter.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 209bc6551a..39b09b802a 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -30,6 +30,8 @@ library Ide.Cradle Ide.Plugin.Example Ide.Plugin.Ormolu + Ide.Plugin.Floskell + Ide.Plugin.Formatter Ide.Version other-modules: Paths_haskell_language_server @@ -39,12 +41,14 @@ library base >=4.7 && <5 , aeson , binary + , bytestring , Cabal , cabal-helper >= 1.0 , containers , deepseq , directory , filepath + , floskell == 0.10.* , ghc , ghcide >= 0.1 , gitrev diff --git a/src/Ide/Plugin/Floskell.hs b/src/Ide/Plugin/Floskell.hs new file mode 100644 index 0000000000..e957b6cae7 --- /dev/null +++ b/src/Ide/Plugin/Floskell.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Floskell + ( + plugin + ) +where + +#if __GLASGOW_HASKELL__ >= 806 +#if __GLASGOW_HASKELL__ >= 808 +import Control.Monad.IO.Class ( MonadIO(..) ) +#else +import Control.Monad.IO.Class ( liftIO + , MonadIO(..) + ) +#endif +import qualified Data.Text as T +#endif + +import qualified Data.ByteString.Lazy as BS +import qualified Data.Text.Encoding as T +import Development.IDE.Plugin +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import Floskell +import Ide.Plugin.Formatter +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- +-- New style plugin + +plugin :: Plugin +plugin = formatterPlugin provider + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + +-- | Format provider of Floskell. +-- Formats the given source in either a given Range or the whole Document. +-- If the provider fails an error is returned that can be displayed to the user. +provider :: FormattingProvider IO +provider _ideState typ contents fp _ = do + let file = fromNormalizedFilePath fp + config <- liftIO $ findConfigOrDefault file + let (range, selectedContents) = case typ of + FormatText -> (fullRange contents, contents) + FormatRange r -> (r, extractRange r contents) + result = reformat config (Just file) (BS.fromStrict (T.encodeUtf8 selectedContents)) + case result of + Left err -> return $ Left $ responseError (T.pack $ "floskellCmd: " ++ err) + Right new -> return $ Right $ List [TextEdit range (T.decodeUtf8 (BS.toStrict new))] + +-- | Find Floskell Config, user and system wide or provides a default style. +-- Every directory of the filepath will be searched to find a user configuration. +-- Also looks into places such as XDG_CONFIG_DIRECTORY. +-- This function may not throw an exception and returns a default config. +findConfigOrDefault :: FilePath -> IO AppConfig +findConfigOrDefault file = do + mbConf <- findAppConfigIn file + case mbConf of + Just confFile -> readAppConfig confFile + Nothing -> + let gibiansky = head (filter (\s -> styleName s == "gibiansky") styles) + in return $ defaultAppConfig { appStyle = gibiansky } + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + + +extractRange :: Range -> T.Text -> T.Text +extractRange (Range (Position sl _) (Position el _)) s = newS + where focusLines = take (el-sl+1) $ drop sl $ T.lines s + newS = T.unlines focusLines + +-- | Gets the range that covers the entire text +fullRange :: T.Text -> Range +fullRange s = Range startPos endPos + where startPos = Position 0 0 + endPos = Position lastLine 0 + {- + In order to replace everything including newline characters, + the end range should extend below the last line. From the specification: + "If you want to specify a range that contains a line including + the line ending character(s) then use an end position denoting + the start of the next line" + -} + lastLine = length $ T.lines s + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Formatter.hs b/src/Ide/Plugin/Formatter.hs new file mode 100644 index 0000000000..2a3dd35daf --- /dev/null +++ b/src/Ide/Plugin/Formatter.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Formatter + ( + formatterPlugin + , FormattingType(..) + , FormattingProvider + , responseError + ) +where + +import qualified Data.Text as T +import Development.IDE.Core.FileStore +import Development.IDE.Core.Rules +import Development.IDE.LSP.Server +import Development.IDE.Plugin +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import Development.Shake hiding ( Diagnostic ) +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +formatterPlugin :: FormattingProvider IO -> Plugin +formatterPlugin provider = Plugin rules (handlers provider) + +-- --------------------------------------------------------------------- +-- New style plugin + +rules :: Rules () +rules = mempty + +handlers :: FormattingProvider IO -> PartialHandlers +handlers provider = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.documentFormattingHandler + = withResponse RspDocumentFormatting (formatting provider) + , LSP.documentRangeFormattingHandler + = withResponse RspDocumentRangeFormatting (rangeFormatting provider) + } + +-- --------------------------------------------------------------------- + +formatting :: FormattingProvider IO + -> LSP.LspFuncs () -> IdeState -> DocumentFormattingParams + -> IO (Either ResponseError (List TextEdit)) +formatting provider _lf ideState + (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress) + = doFormatting provider ideState FormatText uri params + +-- --------------------------------------------------------------------- + +rangeFormatting :: FormattingProvider IO + -> LSP.LspFuncs () -> IdeState -> DocumentRangeFormattingParams + -> IO (Either ResponseError (List TextEdit)) +rangeFormatting provider _lf ideState + (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress) + = doFormatting provider ideState (FormatRange range) uri params + +-- --------------------------------------------------------------------- + +doFormatting :: FormattingProvider IO + -> IdeState -> FormattingType -> Uri -> FormattingOptions + -> IO (Either ResponseError (List TextEdit)) +doFormatting provider ideState ft uri params + = case uriToFilePath uri of + Just (toNormalizedFilePath -> fp) -> do + (_, mb_contents) <- runAction ideState $ getFileContents fp + case mb_contents of + Just contents -> provider ideState ft contents fp params + Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri + Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri + +-- --------------------------------------------------------------------- + +-- | Format the given Text as a whole or only a @Range@ of it. +-- Range must be relative to the text to format. +-- To format the whole document, read the Text from the file and use 'FormatText' +-- as the FormattingType. +data FormattingType = FormatText + | FormatRange Range + + +-- | To format a whole document, the 'FormatText' @FormattingType@ can be used. +-- It is required to pass in the whole Document Text for that to happen, an empty text +-- and file uri, does not suffice. +type FormattingProvider m + = IdeState + -> FormattingType -- ^ How much to format + -> T.Text -- ^ Text to format + -> NormalizedFilePath -- ^ location of the file being formatted + -> FormattingOptions -- ^ Options for the formatter + -> m (Either ResponseError (List TextEdit)) -- ^ Result of the formatting + +-- --------------------------------------------------------------------- + +responseError :: T.Text -> ResponseError +responseError txt = ResponseError InvalidParams txt Nothing + +-- --------------------------------------------------------------------- diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index d30efdb223..70c855233e 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -10,6 +10,7 @@ extra-deps: - cabal-helper-1.0.0.0 - cabal-plan-0.6.2.0 - clock-0.7.2 +- floskell-0.10.2 - ghcide-0.1.0 - fuzzy-0.1.0.0 - ghc-lib-parser-8.8.2 diff --git a/stack.yaml b/stack.yaml index 604898c3f9..846f810ddd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,6 +10,7 @@ extra-deps: - cabal-helper-1.0.0.0 - cabal-plan-0.6.2.0 - clock-0.7.2 +- floskell-0.10.2 - fuzzy-0.1.0.0 - ghcide-0.1.0 - ghc-lib-parser-8.8.2 @@ -19,6 +20,7 @@ extra-deps: - hie-bios-0.4.0 - indexed-profunctors-0.1 - lsp-test-0.10.0.0 +- monad-dijkstra-0.1.1.2 - optics-core-0.2 - optparse-applicative-0.15.1.0 - ormolu-0.0.3.1 From ab1ef255e5b7337d2cfb232d94c4b14b20eb92a9 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 9 Feb 2020 21:11:51 +0000 Subject: [PATCH 2/4] Choose formatter based on config. Requires https://github.com/digital-asset/ghcide/pull/416 --- .gitmodules | 4 ++ cabal.project | 4 +- exe/Main.hs | 17 +++-- ghcide | 1 + haskell-language-server.cabal | 5 +- src/Ide/Plugin/Config.hs | 102 +++++++++++++++++++++++++++ src/Ide/Plugin/Example.hs | 12 ++-- src/Ide/Plugin/Floskell.hs | 49 +------------ src/Ide/Plugin/Formatter.hs | 86 ++++++++++++++++------- src/Ide/Plugin/Ormolu.hs | 127 ++++++---------------------------- stack-8.6.4.yaml | 10 +-- stack-8.6.5.yaml | 10 +-- stack-8.8.2.yaml | 11 ++- stack.yaml | 10 +-- 14 files changed, 236 insertions(+), 212 deletions(-) create mode 160000 ghcide create mode 100644 src/Ide/Plugin/Config.hs diff --git a/.gitmodules b/.gitmodules index 7856aaec36..7faeadd5ea 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,3 +8,7 @@ # Commit git commit -m "Removed submodule " # Delete the now untracked submodule files # rm -rf path_to_submodule +[submodule "ghcide"] + path = ghcide + # url = https://github.com/digital-asset/ghcide.git + url = https://github.com/alanz/ghcide.git diff --git a/cabal.project b/cabal.project index c08ab4fe68..1ec814ab26 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,6 @@ packages: ./ - -- ghcide + ghcide tests: true @@ -11,4 +11,4 @@ package ghcide write-ghc-environment-files: never -index-state: 2020-02-04T19:45:47Z +index-state: 2020-02-09T06:58:05Z diff --git a/exe/Main.hs b/exe/Main.hs index aed19bc663..6081287e18 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} module Main(main) where @@ -19,6 +20,7 @@ import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T +import Development.IDE.Core.Debouncer import Development.IDE.Core.FileStore import Development.IDE.Core.OfInterest import Development.IDE.Core.RuleTypes @@ -36,6 +38,8 @@ import Development.IDE.Types.Options import Development.Shake (Action, action) import GHC hiding (def) import HIE.Bios +import Ide.Plugin.Formatter +import Ide.Plugin.Config import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types (LspId(IdInt)) import Linker @@ -50,6 +54,7 @@ import System.Time.Extra import Development.IDE.Plugin.CodeAction as CodeAction import Development.IDE.Plugin.Completions as Completions import Ide.Plugin.Example as Example +import Ide.Plugin.Floskell as Floskell import Ide.Plugin.Ormolu as Ormolu -- --------------------------------------------------------------------- @@ -58,11 +63,12 @@ import Ide.Plugin.Ormolu as Ormolu -- server. -- These can be freely added or removed to tailor the available -- features of the server. -idePlugins :: Bool -> Plugin +idePlugins :: Bool -> Plugin Config idePlugins includeExample = Completions.plugin <> CodeAction.plugin <> - Ormolu.plugin <> + formatterPlugins [("ormolu", Ormolu.provider) + ,("floskell", Floskell.provider)] <> if includeExample then Example.plugin else mempty -- --------------------------------------------------------------------- @@ -91,7 +97,7 @@ main = do t <- offsetTime hPutStrLn stderr "Starting (haskell-language-server)LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - runLanguageServer def (pluginHandler plugins) $ \getLspId event vfs caps -> do + runLanguageServer def (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \getLspId event vfs caps -> do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t -- very important we only call loadSession once, and it's fast, so just do it before starting @@ -100,7 +106,8 @@ main = do { optReportProgress = clientSupportsProgress caps , optShakeProfiling = argsShakeProfiling } - initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) options vfs + debouncer <- newAsyncDebouncer + initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) debouncer options vfs else do putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "." putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues" @@ -135,7 +142,7 @@ main = do let options = (defaultIdeOptions $ return $ return . grab) { optShakeProfiling = argsShakeProfiling } - ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) options vfs + ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs putStrLn "\nStep 6/6: Type checking the files" setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files diff --git a/ghcide b/ghcide new file mode 160000 index 0000000000..24116bc55c --- /dev/null +++ b/ghcide @@ -0,0 +1 @@ +Subproject commit 24116bc55c3b28d882881fdf743701a31c4dc04a diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 39b09b802a..3969e785de 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -28,6 +28,7 @@ source-repository head library exposed-modules: Ide.Cradle + Ide.Plugin.Config Ide.Plugin.Example Ide.Plugin.Ormolu Ide.Plugin.Floskell @@ -45,15 +46,17 @@ library , Cabal , cabal-helper >= 1.0 , containers + , data-default , deepseq , directory + , extra , filepath , floskell == 0.10.* , ghc , ghcide >= 0.1 , gitrev , hashable - , haskell-lsp == 0.19.* + , haskell-lsp == 0.20.* , hie-bios >= 0.4 , hslogger , optparse-simple diff --git a/src/Ide/Plugin/Config.hs b/src/Ide/Plugin/Config.hs new file mode 100644 index 0000000000..7a44e9c7f3 --- /dev/null +++ b/src/Ide/Plugin/Config.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +module Ide.Plugin.Config + ( + getInitialConfig + , getConfigFromNotification + , Config(..) + ) where + +import qualified Data.Aeson as A +import Data.Aeson hiding ( Error ) +import Data.Default +import qualified Data.Text as T +import Language.Haskell.LSP.Types + +-- --------------------------------------------------------------------- + +-- | Given a DidChangeConfigurationNotification message, this function returns the parsed +-- Config object if possible. +getConfigFromNotification :: DidChangeConfigurationNotification -> Either T.Text Config +getConfigFromNotification (NotificationMessage _ _ (DidChangeConfigurationParams p)) = + case fromJSON p of + A.Success c -> Right c + A.Error err -> Left $ T.pack err + +-- | Given an InitializeRequest message, this function returns the parsed +-- Config object if possible. Otherwise, it returns the default configuration +getInitialConfig :: InitializeRequest -> Either T.Text Config +getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Nothing }) = Right def +getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Just opts}) = + case fromJSON opts of + A.Success c -> Right c + A.Error err -> Left $ T.pack err + +-- --------------------------------------------------------------------- + +-- | We (initially anyway) mirror the hie configuration, so that existing +-- clients can simply switch executable and not have any nasty surprises. There +-- will be surprises relating to config options being ignored, initially though. +data Config = + Config + { hlintOn :: Bool + , diagnosticsOnChange :: Bool + , maxNumberOfProblems :: Int + , diagnosticsDebounceDuration :: Int + , liquidOn :: Bool + , completionSnippetsOn :: Bool + , formatOnImportOn :: Bool + , formattingProvider :: T.Text + } deriving (Show,Eq) + +instance Default Config where + def = Config + { hlintOn = True + , diagnosticsOnChange = True + , maxNumberOfProblems = 100 + , diagnosticsDebounceDuration = 350000 + , liquidOn = False + , completionSnippetsOn = True + , formatOnImportOn = True + -- , formattingProvider = "brittany" + , formattingProvider = "ormolu" + } + +-- TODO: Add API for plugins to expose their own LSP config options +instance A.FromJSON Config where + parseJSON = A.withObject "Config" $ \v -> do + s <- v .: "languageServerHaskell" + flip (A.withObject "Config.settings") s $ \o -> Config + <$> o .:? "hlintOn" .!= hlintOn def + <*> o .:? "diagnosticsOnChange" .!= diagnosticsOnChange def + <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems def + <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration def + <*> o .:? "liquidOn" .!= liquidOn def + <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn def + <*> o .:? "formatOnImportOn" .!= formatOnImportOn def + <*> o .:? "formattingProvider" .!= formattingProvider def + +-- 2017-10-09 23:22:00.710515298 [ThreadId 11] - ---> {"jsonrpc":"2.0","method":"workspace/didChangeConfiguration","params":{"settings":{"languageServerHaskell":{"maxNumberOfProblems":100,"hlintOn":true}}}} +-- 2017-10-09 23:22:00.710667381 [ThreadId 15] - reactor:got didChangeConfiguration notification: +-- NotificationMessage +-- {_jsonrpc = "2.0" +-- , _method = WorkspaceDidChangeConfiguration +-- , _params = DidChangeConfigurationParams +-- {_settings = Object (fromList [("languageServerHaskell",Object (fromList [("hlintOn",Bool True) +-- ,("maxNumberOfProblems",Number 100.0)]))])}} + +instance A.ToJSON Config where + toJSON (Config h diag m d l c f fp) = object [ "languageServerHaskell" .= r ] + where + r = object [ "hlintOn" .= h + , "diagnosticsOnChange" .= diag + , "maxNumberOfProblems" .= m + , "diagnosticsDebounceDuration" .= d + , "liquidOn" .= l + , "completionSnippetsOn" .= c + , "formatOnImportOn" .= f + , "formattingProvider" .= fp + ] diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index 7e86891155..0a90009146 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -42,7 +42,7 @@ import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- -plugin :: Plugin +plugin :: Plugin c plugin = Plugin exampleRules handlersExample <> codeActionPlugin codeAction <> Plugin mempty handlersCodeLens @@ -54,7 +54,7 @@ blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) blah _ (Position line col) = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover"]) -handlersExample :: PartialHandlers +handlersExample :: PartialHandlers c handlersExample = PartialHandlers $ \WithMessage{..} x -> return x{LSP.hoverHandler = withResponse RspHover $ const hover} @@ -100,7 +100,7 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) -- | Generate code actions. codeAction - :: LSP.LspFuncs () + :: LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range @@ -118,14 +118,14 @@ codeAction _lsp _state (TextDocumentIdentifier uri) _range CodeActionContext{_di -- --------------------------------------------------------------------- -- | Generate code lenses. -handlersCodeLens :: PartialHandlers +handlersCodeLens :: PartialHandlers c handlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{ LSP.codeLensHandler = withResponse RspCodeLens codeLens, LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand } codeLens - :: LSP.LspFuncs () + :: LSP.LspFuncs c -> IdeState -> CodeLensParams -> IO (Either ResponseError (List CodeLens)) @@ -149,7 +149,7 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} -- | Execute the "codelens.todo" command. executeAddSignatureCommand - :: LSP.LspFuncs () + :: LSP.LspFuncs c -> IdeState -> ExecuteCommandParams -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) diff --git a/src/Ide/Plugin/Floskell.hs b/src/Ide/Plugin/Floskell.hs index e957b6cae7..e0e535b74d 100644 --- a/src/Ide/Plugin/Floskell.hs +++ b/src/Ide/Plugin/Floskell.hs @@ -7,24 +7,13 @@ module Ide.Plugin.Floskell ( - plugin + provider ) where -#if __GLASGOW_HASKELL__ >= 806 -#if __GLASGOW_HASKELL__ >= 808 -import Control.Monad.IO.Class ( MonadIO(..) ) -#else -import Control.Monad.IO.Class ( liftIO - , MonadIO(..) - ) -#endif -import qualified Data.Text as T -#endif - import qualified Data.ByteString.Lazy as BS +import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Floskell @@ -32,14 +21,6 @@ import Ide.Plugin.Formatter import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() --- --------------------------------------------------------------------- --- New style plugin - -plugin :: Plugin -plugin = formatterPlugin provider - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- -- --------------------------------------------------------------------- -- | Format provider of Floskell. @@ -48,7 +29,7 @@ plugin = formatterPlugin provider provider :: FormattingProvider IO provider _ideState typ contents fp _ = do let file = fromNormalizedFilePath fp - config <- liftIO $ findConfigOrDefault file + config <- findConfigOrDefault file let (range, selectedContents) = case typ of FormatText -> (fullRange contents, contents) FormatRange r -> (r, extractRange r contents) @@ -71,27 +52,3 @@ findConfigOrDefault file = do in return $ defaultAppConfig { appStyle = gibiansky } -- --------------------------------------------------------------------- --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - - -extractRange :: Range -> T.Text -> T.Text -extractRange (Range (Position sl _) (Position el _)) s = newS - where focusLines = take (el-sl+1) $ drop sl $ T.lines s - newS = T.unlines focusLines - --- | Gets the range that covers the entire text -fullRange :: T.Text -> Range -fullRange s = Range startPos endPos - where startPos = Position 0 0 - endPos = Position lastLine 0 - {- - In order to replace everything including newline characters, - the end range should extend below the last line. From the specification: - "If you want to specify a range that contains a line including - the line ending character(s) then use an end position denoting - the start of the next line" - -} - lastLine = length $ T.lines s - --- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Formatter.hs b/src/Ide/Plugin/Formatter.hs index 2a3dd35daf..6754c664cb 100644 --- a/src/Ide/Plugin/Formatter.hs +++ b/src/Ide/Plugin/Formatter.hs @@ -7,13 +7,16 @@ module Ide.Plugin.Formatter ( - formatterPlugin + formatterPlugins , FormattingType(..) , FormattingProvider , responseError + , extractRange + , fullRange ) where +import qualified Data.Map as Map import qualified Data.Text as T import Development.IDE.Core.FileStore import Development.IDE.Core.Rules @@ -22,6 +25,7 @@ import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Development.Shake hiding ( Diagnostic ) +import Ide.Plugin.Config import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types @@ -29,8 +33,8 @@ import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- -formatterPlugin :: FormattingProvider IO -> Plugin -formatterPlugin provider = Plugin rules (handlers provider) +formatterPlugins :: [(T.Text, FormattingProvider IO)] -> Plugin Config +formatterPlugins providers = Plugin rules (handlers (Map.fromList providers)) -- --------------------------------------------------------------------- -- New style plugin @@ -38,45 +42,58 @@ formatterPlugin provider = Plugin rules (handlers provider) rules :: Rules () rules = mempty -handlers :: FormattingProvider IO -> PartialHandlers -handlers provider = PartialHandlers $ \WithMessage{..} x -> return x +handlers :: Map.Map T.Text (FormattingProvider IO) -> PartialHandlers Config +handlers providers = PartialHandlers $ \WithMessage{..} x -> return x { LSP.documentFormattingHandler - = withResponse RspDocumentFormatting (formatting provider) + = withResponse RspDocumentFormatting (formatting providers) , LSP.documentRangeFormattingHandler - = withResponse RspDocumentRangeFormatting (rangeFormatting provider) + = withResponse RspDocumentRangeFormatting (rangeFormatting providers) } +-- handlers :: FormattingProvider IO -> T.Text -> PartialHandlers c +-- handlers provider configName = PartialHandlers $ \WithMessage{..} x -> return x +-- { LSP.documentFormattingHandler +-- = withResponse RspDocumentFormatting (formatting provider configName) +-- , LSP.documentRangeFormattingHandler +-- = withResponse RspDocumentRangeFormatting (rangeFormatting provider configName) +-- } + -- --------------------------------------------------------------------- -formatting :: FormattingProvider IO - -> LSP.LspFuncs () -> IdeState -> DocumentFormattingParams +formatting :: Map.Map T.Text (FormattingProvider IO) + -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams -> IO (Either ResponseError (List TextEdit)) -formatting provider _lf ideState +formatting providers lf ideState (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress) - = doFormatting provider ideState FormatText uri params + = doFormatting lf providers ideState FormatText uri params -- --------------------------------------------------------------------- -rangeFormatting :: FormattingProvider IO - -> LSP.LspFuncs () -> IdeState -> DocumentRangeFormattingParams +rangeFormatting :: Map.Map T.Text (FormattingProvider IO) + -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams -> IO (Either ResponseError (List TextEdit)) -rangeFormatting provider _lf ideState +rangeFormatting providers lf ideState (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress) - = doFormatting provider ideState (FormatRange range) uri params + = doFormatting lf providers ideState (FormatRange range) uri params -- --------------------------------------------------------------------- -doFormatting :: FormattingProvider IO +doFormatting :: LSP.LspFuncs Config -> Map.Map T.Text (FormattingProvider IO) -> IdeState -> FormattingType -> Uri -> FormattingOptions -> IO (Either ResponseError (List TextEdit)) -doFormatting provider ideState ft uri params - = case uriToFilePath uri of - Just (toNormalizedFilePath -> fp) -> do - (_, mb_contents) <- runAction ideState $ getFileContents fp - case mb_contents of - Just contents -> provider ideState ft contents fp params - Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri - Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri +doFormatting lf providers ideState ft uri params = do + mc <- LSP.config lf + let mf = maybe "none" formattingProvider mc + case Map.lookup mf providers of + Just provider -> + case uriToFilePath uri of + Just (toNormalizedFilePath -> fp) -> do + (_, mb_contents) <- runAction ideState $ getFileContents fp + case mb_contents of + Just contents -> provider ideState ft contents fp params + Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri + Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri + Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: no formatter found for:[" ++ T.unpack mf ++ "]" -- --------------------------------------------------------------------- @@ -105,3 +122,24 @@ responseError :: T.Text -> ResponseError responseError txt = ResponseError InvalidParams txt Nothing -- --------------------------------------------------------------------- + +extractRange :: Range -> T.Text -> T.Text +extractRange (Range (Position sl _) (Position el _)) s = newS + where focusLines = take (el-sl+1) $ drop sl $ T.lines s + newS = T.unlines focusLines + +-- | Gets the range that covers the entire text +fullRange :: T.Text -> Range +fullRange s = Range startPos endPos + where startPos = Position 0 0 + endPos = Position lastLine 0 + {- + In order to replace everything including newline characters, + the end range should extend below the last line. From the specification: + "If you want to specify a range that contains a line including + the line ending character(s) then use an end position denoting + the start of the next line" + -} + lastLine = length $ T.lines s + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index 05bda2940c..49719053d7 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -7,19 +7,12 @@ module Ide.Plugin.Ormolu ( - plugin + provider ) where #if __GLASGOW_HASKELL__ >= 806 import Control.Exception -#if __GLASGOW_HASKELL__ >= 808 -import Control.Monad.IO.Class ( MonadIO(..) ) -#else -import Control.Monad.IO.Class ( liftIO - , MonadIO(..) - ) -#endif import Data.Char import qualified Data.Text as T import GHC @@ -32,105 +25,17 @@ import qualified HIE.Bios as BIOS import Control.Monad import Data.List import Data.Maybe -import Development.IDE.Core.FileStore import Development.IDE.Core.Rules -import Development.IDE.LSP.Server -import Development.IDE.Plugin +-- import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location -import Development.Shake hiding ( Diagnostic ) -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages +import Ide.Plugin.Formatter import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() --- --------------------------------------------------------------------- --- New style plugin - -plugin :: Plugin -plugin = Plugin ormoluRules ormoluHandlers - -ormoluRules :: Rules () -ormoluRules = mempty - -ormoluHandlers :: PartialHandlers -ormoluHandlers = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.documentFormattingHandler - = withResponse RspDocumentFormatting formatting - , LSP.documentRangeFormattingHandler - = withResponse RspDocumentRangeFormatting rangeFormatting - } - -formatting :: LSP.LspFuncs () -> IdeState -> DocumentFormattingParams -> IO (Either ResponseError (List TextEdit)) -formatting _lf ideState (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress) - = doFormatting ideState FormatText uri params - -rangeFormatting :: LSP.LspFuncs () -> IdeState -> DocumentRangeFormattingParams -> IO (Either ResponseError (List TextEdit)) -rangeFormatting _lf ideState (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress) - = doFormatting ideState (FormatRange range) uri params - -doFormatting :: IdeState -> FormattingType -> Uri -> FormattingOptions -> IO (Either ResponseError (List TextEdit)) -doFormatting ideState ft uri params - = case uriToFilePath uri of - Just (toNormalizedFilePath -> fp) -> do - (_, mb_contents) <- runAction ideState $ getFileContents fp - case mb_contents of - Just contents -> provider ideState ft contents fp params - Nothing -> return $ Left $ responseError $ T.pack $ "Ormolu plugin: could not get file contents for " ++ show uri - Nothing -> return $ Left $ responseError $ T.pack $ "Ormolu plugin: uriToFilePath failed for: " ++ show uri - --- --------------------------------------------------------------------- - --- | Format the given Text as a whole or only a @Range@ of it. --- Range must be relative to the text to format. --- To format the whole document, read the Text from the file and use 'FormatText' --- as the FormattingType. -data FormattingType = FormatText - | FormatRange Range - - --- | To format a whole document, the 'FormatText' @FormattingType@ can be used. --- It is required to pass in the whole Document Text for that to happen, an empty text --- and file uri, does not suffice. -type FormattingProvider m - = IdeState - -> FormattingType -- ^ How much to format - -> T.Text -- ^ Text to format - -> NormalizedFilePath -- ^ location of the file being formatted - -> FormattingOptions -- ^ Options for the formatter - -> m (Either ResponseError (List TextEdit)) -- ^ Result of the formatting - --- --------------------------------------------------------------------- - -extractRange :: Range -> T.Text -> T.Text -extractRange (Range (Position sl _) (Position el _)) s = newS - where focusLines = take (el-sl+1) $ drop sl $ T.lines s - newS = T.unlines focusLines - --- | Gets the range that covers the entire text -fullRange :: T.Text -> Range -fullRange s = Range startPos endPos - where startPos = Position 0 0 - endPos = Position lastLine 0 - {- - In order to replace everything including newline characters, - the end range should extend below the last line. From the specification: - "If you want to specify a range that contains a line including - the line ending character(s) then use an end position denoting - the start of the next line" - -} - lastLine = length $ T.lines s - --- | Find the cradle wide 'ComponentOptions' that apply to a 'FilePath' -lookupBiosComponentOptions :: (Monad m) => NormalizedFilePath -> m (Maybe BIOS.ComponentOptions) -lookupBiosComponentOptions _fp = do - -- gmc <- getModuleCache - -- return $ lookupInCache fp gmc (const Just) (Just . compOpts) Nothing - return Nothing - -- --------------------------------------------------------------------- -provider :: forall m. (MonadIO m) => FormattingProvider m +provider :: FormattingProvider IO #if __GLASGOW_HASKELL__ >= 806 provider ideState typ contents fp _ = do let @@ -145,7 +50,7 @@ provider ideState typ contents fp _ = do $ BIOS.componentOptions <$> opts let - fromDyn :: ParsedModule -> m [DynOption] + fromDyn :: ParsedModule -> IO [DynOption] fromDyn pmod = let df = ms_hspp_opts $ pm_mod_summary pmod @@ -157,16 +62,16 @@ provider ideState typ contents fp _ = do in return $ map DynOption $ pp <> pm <> ex - m_parsed <- liftIO $ runAction ideState $ getParsedModule fp + m_parsed <- runAction ideState $ getParsedModule fp fileOpts <- case m_parsed of Nothing -> return [] Just pm -> fromDyn pm let conf o = Config o False False True False - fmt :: T.Text -> [DynOption] -> m (Either OrmoluException T.Text) + fmt :: T.Text -> [DynOption] -> IO (Either OrmoluException T.Text) fmt cont o = - liftIO $ try @OrmoluException (ormolu (conf o) (fromNormalizedFilePath fp) $ T.unpack cont) + try @OrmoluException (ormolu (conf o) (fromNormalizedFilePath fp) $ T.unpack cont) case typ of FormatText -> ret (fullRange contents) <$> fmt contents cradleOpts @@ -188,10 +93,10 @@ provider ideState typ contents fp _ = do let ws = fst $ T.span isSpace l in (,) ws . T.unlines <$> traverse (T.stripPrefix ws) txt _ -> Nothing - err :: m (Either ResponseError (List TextEdit)) + err :: IO (Either ResponseError (List TextEdit)) err = return $ Left $ responseError $ T.pack "You must format a whole block of code. Ormolu does not support arbitrary ranges." - fmt' :: (T.Text, T.Text) -> m (Either ResponseError (List TextEdit)) + fmt' :: (T.Text, T.Text) -> IO (Either ResponseError (List TextEdit)) fmt' (ws, striped) = ret (lineRange r) <$> (fmap (unStrip ws) <$> fmt striped fileOpts) in @@ -206,5 +111,13 @@ provider ideState typ contents fp _ = do provider _ _ _ _ = return $ IdeResultOk [] -- NOP formatter #endif -responseError :: T.Text -> ResponseError -responseError txt = ResponseError InvalidParams txt Nothing +-- --------------------------------------------------------------------- + +-- | Find the cradle wide 'ComponentOptions' that apply to a 'FilePath' +lookupBiosComponentOptions :: (Monad m) => NormalizedFilePath -> m (Maybe BIOS.ComponentOptions) +lookupBiosComponentOptions _fp = do + -- gmc <- getModuleCache + -- return $ lookupInCache fp gmc (const Just) (Just . compOpts) Nothing + return Nothing + +-- --------------------------------------------------------------------- diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index d06bc8055b..38c22f02f2 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -2,7 +2,7 @@ resolver: lts-13.19 # GHC 8.6.4 packages: - . -# - ./ghcide/ +- ./ghcide/ extra-deps: - brittany-0.12.1.0 @@ -11,7 +11,7 @@ extra-deps: - cabal-helper-1.0.0.0 - cabal-plan-0.5.0.0 - constrained-dynamic-0.1.0.0 -- ghcide-0.1.0 +# - ghcide-0.1.0 - extra-1.6.18 - floskell-0.10.2 - fuzzy-0.1.0.0 @@ -20,14 +20,14 @@ extra-deps: - ghc-lib-parser-ex-8.8.2 - haddock-api-2.22.0 - haddock-library-1.8.0 -- haskell-lsp-0.19.0.0 -- haskell-lsp-types-0.19.0.0 +- haskell-lsp-0.20.0.0 +- haskell-lsp-types-0.20.0.0 - haskell-src-exts-1.21.1 - hie-bios-0.4.0 - hlint-2.2.8 - hoogle-5.0.17.11 - hsimport-0.11.0 -- lsp-test-0.10.0.0 +- lsp-test-0.10.1.0 - monad-dijkstra-0.1.1.2 - monad-memo-0.4.1 - multistate-0.8.0.1 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 70c855233e..76dc006861 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -2,7 +2,7 @@ resolver: lts-14.22 packages: - . -# - ./ghcide/ +- ./ghcide/ extra-deps: - ansi-terminal-0.10.2 @@ -11,15 +11,15 @@ extra-deps: - cabal-plan-0.6.2.0 - clock-0.7.2 - floskell-0.10.2 -- ghcide-0.1.0 +# - ghcide-0.1.0 - fuzzy-0.1.0.0 - ghc-lib-parser-8.8.2 - haddock-library-1.8.0 -- haskell-lsp-0.19.0.0 -- haskell-lsp-types-0.19.0.0 +- haskell-lsp-0.20.0.0 +- haskell-lsp-types-0.20.0.0 - hie-bios-0.4.0 - indexed-profunctors-0.1 -- lsp-test-0.10.0.0 +- lsp-test-0.10.1.0 - optics-core-0.2 - optparse-applicative-0.15.1.0 - ormolu-0.0.3.1 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index aabfe54cfb..18d1b3f320 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -2,13 +2,9 @@ resolver: nightly-2020-01-25 packages: - . -# - ./ghcide/ +- ./ghcide/ extra-deps: -# - git: https://github.com/haskell/haddock.git -# commit: be8b02c4e3cffe7d45b3dad0a0f071d35a274d65 -# subdirs: -# - haddock-api - apply-refact-0.7.0.0 - bytestring-trie-0.2.5.0 - cabal-helper-1.0.0.0 @@ -16,15 +12,18 @@ extra-deps: - constrained-dynamic-0.1.0.0 - floskell-0.10.2 - fuzzy-0.1.0.0 -- ghcide-0.1.0 +# - ghcide-0.1.0 - ghc-lib-parser-ex-8.8.2 - haddock-library-1.8.0 +- haskell-lsp-0.20.0.0 +- haskell-lsp-types-0.20.0.0 - haskell-src-exts-1.21.1 - hie-bios-0.4.0 - hlint-2.2.8 - hoogle-5.0.17.11 - hsimport-0.11.0 - ilist-0.3.1.0 +- lsp-test-0.10.1.0 - monad-dijkstra-0.1.1.2 - ormolu-0.0.3.1 - semigroups-0.18.5 diff --git a/stack.yaml b/stack.yaml index 846f810ddd..3fbe3fc91a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,7 +2,7 @@ resolver: lts-14.22 packages: - . -# - ./ghcide/ +- ./ghcide/ extra-deps: - ansi-terminal-0.10.2 @@ -12,14 +12,14 @@ extra-deps: - clock-0.7.2 - floskell-0.10.2 - fuzzy-0.1.0.0 -- ghcide-0.1.0 +# - ghcide-0.1.0 - ghc-lib-parser-8.8.2 - haddock-library-1.8.0 -- haskell-lsp-0.19.0.0 -- haskell-lsp-types-0.19.0.0 +- haskell-lsp-0.20.0.0 +- haskell-lsp-types-0.20.0.0 - hie-bios-0.4.0 - indexed-profunctors-0.1 -- lsp-test-0.10.0.0 +- lsp-test-0.10.1.0 - monad-dijkstra-0.1.1.2 - optics-core-0.2 - optparse-applicative-0.15.1.0 From 5e92113f51483025702afa7a23055c1323d02600 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 9 Feb 2020 21:24:54 +0000 Subject: [PATCH 3/4] Update deps for stack-8.6.5.yaml --- stack-8.6.5.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 76dc006861..3eeacdd9b7 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -20,6 +20,7 @@ extra-deps: - hie-bios-0.4.0 - indexed-profunctors-0.1 - lsp-test-0.10.1.0 +- monad-dijkstra-0.1.1.2 - optics-core-0.2 - optparse-applicative-0.15.1.0 - ormolu-0.0.3.1 From e173e4e199ca20790e0d53e3c4994cf1718d42ad Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 10 Feb 2020 20:59:19 +0000 Subject: [PATCH 4/4] WIP on integrating hlint using DAML approach But getting a mismatch on ghc-lib vs GHC types for the call to hlint. Closes #32 --- exe/Main.hs | 2 + haskell-language-server.cabal | 3 + src/Ide/Plugin/Hlint.hs | 562 ++++++++++++++++++++++++++++++++++ 3 files changed, 567 insertions(+) create mode 100644 src/Ide/Plugin/Hlint.hs diff --git a/exe/Main.hs b/exe/Main.hs index 6081287e18..af77e4a9c6 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -55,6 +55,7 @@ import Development.IDE.Plugin.CodeAction as CodeAction import Development.IDE.Plugin.Completions as Completions import Ide.Plugin.Example as Example import Ide.Plugin.Floskell as Floskell +import Ide.Plugin.Hlint as Hlint import Ide.Plugin.Ormolu as Ormolu -- --------------------------------------------------------------------- @@ -69,6 +70,7 @@ idePlugins includeExample CodeAction.plugin <> formatterPlugins [("ormolu", Ormolu.provider) ,("floskell", Floskell.provider)] <> + Hlint.plugin <> if includeExample then Example.plugin else mempty -- --------------------------------------------------------------------- diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 3969e785de..0d91b0a5a8 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -30,6 +30,7 @@ library Ide.Cradle Ide.Plugin.Config Ide.Plugin.Example + Ide.Plugin.Hlint Ide.Plugin.Ormolu Ide.Plugin.Floskell Ide.Plugin.Formatter @@ -57,7 +58,9 @@ library , gitrev , hashable , haskell-lsp == 0.20.* + , haskell-src-exts , hie-bios >= 0.4 + , hlint >= 2.2.10 , hslogger , optparse-simple , process diff --git a/src/Ide/Plugin/Hlint.hs b/src/Ide/Plugin/Hlint.hs new file mode 100644 index 0000000000..7ab299e835 --- /dev/null +++ b/src/Ide/Plugin/Hlint.hs @@ -0,0 +1,562 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Hlint + ( + plugin + ) where + +-- import DA.Daml.DocTest +-- import Development.IDE.Core.Service.Daml +-- import qualified DA.Daml.LF.Ast as LF +-- import qualified DA.Daml.LF.ScenarioServiceClient as SS +-- import Control.Exception.Safe +-- import Development.IDE.Core.RuleTypes.Daml +-- import Development.IDE.Core.Rules +-- import Development.IDE.Core.Service.Daml +-- import Development.IDE.Types.Location +-- import qualified DA.Daml.LF.Ast as LF +-- import qualified DA.Daml.Visual as Visual +-- import qualified Data.NameMap as NM +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Control.Monad.Extra +import Control.Monad.Trans.Maybe +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) +import Data.Binary +import qualified Data.ByteString as BS +import Data.Either.Extra +import Data.Foldable +import Data.Functor +import qualified Data.HashMap.Strict as Map +import Data.Hashable +import Data.List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Text as T +import Data.Typeable +import Data.Typeable (Typeable) +import Development.IDE.Core.OfInterest +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Rules +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.LSP.Server +import Development.IDE.Plugin +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import Development.IDE.Types.Logger +import Development.Shake +-- import Development.Shake hiding ( Diagnostic ) +import GHC +import GHC.Generics +import GHC.Generics (Generic) +import HscTypes (ModIface, ModSummary) +import qualified Language.Haskell.Exts.SrcLoc as HSE +import Language.Haskell.HLint4 +import Language.Haskell.HLint4 as Hlint +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.Haskell.LSP.Types.Lens as LSP +import System.Directory +import System.Directory.Extra as Dir +import System.Environment.Blank +import System.FilePath +import System.IO.Error +import Text.Regex.TDFA.Text() + + +-- import "ghc-lib-parser" Module (UnitId) +-- --------------------------------------------------------------------- + +plugin :: Plugin c +plugin = Plugin rules mempty + +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 + -- pm <- getParsedModule file + pm <- use_ GetParsedModule file + let anns = pm_annotations pm + let modu = pm_parsed_source pm + (classify, hint) <- useNoFile_ GetHlintSettings + let ideas = applyHints classify hint [createModuleEx (_ anns) (_ modu)] + return ([diagnostic file i | i <- ideas, ideaSeverity i /= Ignore], Just ()) + + action $ do + files <- getFilesOfInterest + void $ uses GetHlintDiagnostics $ Set.toList files + + where + srcSpanToRange :: HSE.SrcSpan -> LSP.Range + srcSpanToRange span = Range { + _start = LSP.Position { + _line = HSE.srcSpanStartLine span - 1 + , _character = HSE.srcSpanStartColumn span - 1} + , _end = LSP.Position { + _line = HSE.srcSpanEndLine span - 1 + , _character = HSE.srcSpanEndColumn span - 1} + } + diagnostic :: NormalizedFilePath -> Idea -> FileDiagnostic + diagnostic file i = + (file, ShowDiag, LSP.Diagnostic { + _range = srcSpanToRange $ ideaSpan i + , _severity = Just LSP.DsInfo + , _code = Nothing + , _source = Just "linter" + , _message = T.pack $ show i + , _relatedInformation = Nothing + }) + + + +-- --------------------------------------------------------------------- + +data HlintUsage + = HlintEnabled { hlintUseDataDir :: FilePath, hlintAllowOverrides :: Bool } + | 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 Show Hint where show = const "" +instance Binary GetHlintSettings + +type instance RuleResult GetHlintSettings = ([Classify], Hint) + +getHlintSettingsRule :: HlintUsage -> Rules () +getHlintSettingsRule usage = + defineNoFile $ \GetHlintSettings -> + liftIO $ case usage of + HlintEnabled dir enableOverrides -> hlintSettings dir enableOverrides + HlintDisabled -> fail "linter configuration unspecified" + +hlintSettings :: FilePath -> Bool -> IO ([Classify], Hint) +hlintSettings dlintDataDir enableOverrides = do + curdir <- getCurrentDirectory + home <- ((:[]) <$> getHomeDirectory) `catchIOError` (const $ return []) + dlintYaml <- if enableOverrides + then + findM Dir.doesFileExist $ + map ( ".dlint.yaml") (ancestors curdir ++ home) + else + return Nothing + (_, cs, hs) <- foldMapM parseSettings $ + (dlintDataDir "dlint.yaml") : maybeToList dlintYaml + return (cs, hs) + where + ancestors = init . map joinPath . reverse . inits . splitPath + -- `findSettings` calls `readFilesConfig` which in turn calls + -- `readFileConfigYaml` which finally calls `decodeFileEither` from + -- the `yaml` library. Annoyingly that function catches async + -- exceptions and in particular, it ends up catching + -- `ThreadKilled`. So, we have to mask to stop it from doing that. + parseSettings f = mask $ \unmask -> + findSettings (unmask . const (return (f, Nothing))) (Just f) + foldMapM f = foldlM (\acc a -> do w <- f a; return $! mappend acc w) mempty + +-- --------------------------------------------------------------------- +{- +DAML version +getDlintDiagnosticsRule :: Rules () +getDlintDiagnosticsRule = + define $ \GetDlintDiagnostics file -> do + pm <- use_ GetParsedModule file + let anns = pm_annotations pm + let modu = pm_parsed_source pm + (classify, hint) <- useNoFile_ GetDlintSettings + let ideas = applyHints classify hint [createModuleEx anns modu] + return ([diagnostic file i | i <- ideas, ideaSeverity i /= Ignore], Just ()) + where + srcSpanToRange :: HSE.SrcSpan -> LSP.Range + srcSpanToRange span = Range { + _start = LSP.Position { + _line = HSE.srcSpanStartLine span - 1 + , _character = HSE.srcSpanStartColumn span - 1} + , _end = LSP.Position { + _line = HSE.srcSpanEndLine span - 1 + , _character = HSE.srcSpanEndColumn span - 1} + } + diagnostic :: NormalizedFilePath -> Idea -> FileDiagnostic + diagnostic file i = + (file, ShowDiag, LSP.Diagnostic { + _range = srcSpanToRange $ ideaSpan i + , _severity = Just LSP.DsInfo + , _code = Nothing + , _source = Just "linter" + , _message = T.pack $ show i + , _relatedInformation = 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 + +#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 +-}