From afd98d1eddc0bab2b05dea1d3434b46bfbbc4985 Mon Sep 17 00:00:00 2001 From: Pasqualino Titto Assini Date: Thu, 8 Oct 2020 21:54:49 +0200 Subject: [PATCH 1/8] ModuleName Plugin --- exe/Main.hs | 45 +++--- plugins/default/src/Ide/Plugin/ModuleName.hs | 157 +++++++++++++++++++ 2 files changed, 181 insertions(+), 21 deletions(-) create mode 100644 plugins/default/src/Ide/Plugin/ModuleName.hs diff --git a/exe/Main.hs b/exe/Main.hs index c6911722db..a3df59e7bc 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,31 +1,33 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} module Main(main) where -import Ide.Arguments (Arguments(..), LspArguments(..), getArguments) -import Ide.Main (defaultMain) -import Ide.Types (IdePlugins) +import Ide.Arguments (Arguments (..), LspArguments (..), + getArguments) +import Ide.Main (defaultMain) +import Ide.Types (IdePlugins) -- haskell-language-server plugins -import Ide.Plugin.Eval as Eval -import Ide.Plugin.Example as Example -import Ide.Plugin.Example2 as Example2 -import Ide.Plugin.GhcIde as GhcIde -import Ide.Plugin.Floskell as Floskell -import Ide.Plugin.Fourmolu as Fourmolu -import Ide.Plugin.ImportLens as ImportLens -import Ide.Plugin.Ormolu as Ormolu -import Ide.Plugin.StylishHaskell as StylishHaskell -import Ide.Plugin.Retrie as Retrie -import Ide.Plugin.Tactic as Tactic +import Ide.Plugin.Eval as Eval +import Ide.Plugin.Example as Example +import Ide.Plugin.Example2 as Example2 +import Ide.Plugin.Floskell as Floskell +import Ide.Plugin.Fourmolu as Fourmolu +import Ide.Plugin.GhcIde as GhcIde +import Ide.Plugin.ImportLens as ImportLens +import Ide.Plugin.Ormolu as Ormolu +import Ide.Plugin.Retrie as Retrie +import Ide.Plugin.StylishHaskell as StylishHaskell +import Ide.Plugin.Tactic as Tactic #if AGPL -import Ide.Plugin.Brittany as Brittany +import Ide.Plugin.Brittany as Brittany #endif -import Ide.Plugin.Pragmas as Pragmas -import Ide.Plugin (pluginDescToIdePlugins) +import Ide.Plugin (pluginDescToIdePlugins) +import Ide.Plugin.ModuleName as ModuleName +import Ide.Plugin.Pragmas as Pragmas -- --------------------------------------------------------------------- @@ -57,6 +59,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins #endif , Eval.descriptor "eval" , ImportLens.descriptor "importLens" + , ModuleName.descriptor "moduleName" ] examplePlugins = [Example.descriptor "eg" @@ -69,9 +72,9 @@ main :: IO () main = do args <- getArguments "haskell-language-server" - let withExamples = + let withExamples = case args of LspMode (LspArguments{..}) -> argsExamplePlugin - _ -> False + _ -> False defaultMain args (idePlugins withExamples) diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs new file mode 100644 index 0000000000..9f683089c5 --- /dev/null +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -0,0 +1,157 @@ +{-# OPTIONS_GHC -Wwarn -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-unused-imports #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- |Keep the module name in sync with its file path. +module Ide.Plugin.ModuleName + + ( descriptor + ) +where + +import Control.Monad (join) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Maybe () +import Data.Aeson (ToJSON (toJSON), Value (Null)) +import qualified Data.HashMap.Strict as Map +import Data.List (isPrefixOf) +import Data.List.Extra (replace) +import Data.Maybe (listToMaybe) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE (GetParsedModule (GetParsedModule), + GhcSession (GhcSession), + HscEnvEq (hscEnv), IdeState, + List (..), NormalizedFilePath, + Position (Position), Range (Range), + evalGhcEnv, realSrcSpanToRange, + runAction, toNormalizedUri, + uriToFilePath', use, use_) +import Development.IDE.Plugin (getPid) +import GHC (DynFlags (importPaths), + GenLocated (L), + GhcMonad (getSession), + HsModule (hsmodName), + ParsedModule (pm_parsed_source), + SrcSpan (RealSrcSpan), unLoc) +import GhcPlugins (HscEnv (hsc_IC), + InteractiveContext (ic_dflags)) +import Ide.Types (CommandFunction, CommandId (..), + PluginCommand (..), + PluginDescriptor (..), + PluginId (..), + defaultPluginDescriptor) +import Language.Haskell.LSP.Core (LspFuncs, getVirtualFileFunc) +import Language.Haskell.LSP.Types (ApplyWorkspaceEditParams (..), + CAResult (CACodeAction), + CodeAction (CodeAction), + CodeActionKind (CodeActionQuickFix), + CodeLens (CodeLens), + CodeLensParams (CodeLensParams), + Command (Command), + ServerMethod (..), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit), Uri, + WorkspaceEdit (..), + uriToNormalizedFilePath) +import Language.Haskell.LSP.VFS (virtualFileText) +import System.FilePath (dropExtension) + +-- |Plugin descriptor +descriptor :: PluginId -> PluginDescriptor +descriptor plId = + (defaultPluginDescriptor plId) + { pluginId = plId, + pluginCodeLensProvider = Just codeLens + ,pluginCommands = [PluginCommand editCommandName editCommandName editCmd] + -- pluginCodeActionProvider = Just codeAction + } + +-- | Generate code lenses +codeLens :: LspFuncs c -> IdeState -> PluginId -> CodeLensParams -> IO (Either a2 (List CodeLens)) +codeLens lsp state pluginId (CodeLensParams (TextDocumentIdentifier uri) _) = do + pid <- getPid + actions (asCodeLens (mkLspCmdId pid pluginId editCommandName)) lsp state uri + +-- | Generate code actions. +-- NOTE: Not invoked on an empty module (but codeLens is, why?) +codeAction :: LspFuncs c -> IdeState -> p1 -> TextDocumentIdentifier -> p2 -> p3 -> IO (Either a (List CAResult)) +codeAction lsp state _plId (TextDocumentIdentifier uri) _range _ = actions asCodeAction lsp state uri + +-- Copied from "Ide.Plugin" +mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text +mkLspCmdId pid (PluginId plid) (CommandId cid) + = pid <> ":" <> plid <> ":" <> cid + +editCommandName :: IsString p => p +editCommandName = "edit" + +-- | Generic command to apply a group of edits +editCmd :: CommandFunction WorkspaceEdit +editCmd _lf _ide workspaceEdits = return (Right Null, Just $ (WorkspaceApplyEdit,ApplyWorkspaceEditParams workspaceEdits)) + +-- | Required actions (actually, at most one) that can be converted to either CodeLenses or CodeActions +actions :: Show a1 => (Action -> a1) -> LspFuncs c -> IdeState -> Uri -> IO (Either a2 (List a1)) +actions convert lsp state uri = do + let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri + let Just fp = uriToFilePath' uri + + contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri + let emptyModule = maybe True ((==0) . T.length . T.strip . virtualFileText) contents + + correctNameMaybe <- pathModuleName state nfp fp + statedNameMaybe <- codeModuleName state nfp + + let act = Action uri + let actions = case (correctNameMaybe,statedNameMaybe) of + (Just correctName,Just (nameRange,statedName)) | correctName /= statedName -> [convert $ act nameRange ("Set module name to " <> correctName) correctName] + (Just correctName,_) | emptyModule -> let code = T.unwords ["module",correctName,"where\n"] in [convert $ act (Range (Position 0 0) (Position 0 0)) code code] + _ -> [] + + out ["actions",show actions] + pure . Right . List $ actions + +-- | The module name, as derived by the position of the module in its source directory +pathModuleName :: IdeState -> NormalizedFilePath -> String -> IO (Maybe Text) +pathModuleName state nfp fp = do + session :: HscEnvEq <- runAction "ModuleName.ghcSession" state $ use_ GhcSession nfp + paths <- evalGhcEnv (hscEnv session) $ do + env <- getSession + let df = ic_dflags . hsc_IC $ env + return $ importPaths df + out ["import paths",show paths] + let maybePrefix = listToMaybe . filter (`isPrefixOf` fp) $ paths + out ["prefix",show maybePrefix] + let maybeMdlName = (\prefix -> replace "/" "." . drop (length prefix+1) $ dropExtension fp) <$> maybePrefix + out ["mdlName",show maybeMdlName] + return $ T.pack <$> maybeMdlName + +-- | The module name, as stated in the module +codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, Text)) +codeModuleName state nfp = ((\(L (RealSrcSpan l) m) -> (realSrcSpanToRange l,T.pack . show $ m)) <$>) . join . (hsmodName . unLoc . pm_parsed_source <$>) <$> runAction "ModuleName.GetParsedModule" state (use GetParsedModule nfp) + +-- | A source code change +data Action = Action {aUri::Uri,aRange::Range,aTitle::Text,aCode::Text} deriving Show + +-- | Convert an Action to a CodeLens +asCodeLens :: Text -> Action -> CodeLens +asCodeLens cid act@Action{..} = CodeLens aRange (Just $ Command aTitle cid (Just (List [toJSON $ asEdit act]))) Nothing + +-- | Convert an Action to a CodeAction +asCodeAction :: Action -> CAResult +asCodeAction act@Action{..} = CACodeAction $ CodeAction aTitle (Just CodeActionQuickFix) (Just $ List []) (Just $ asEdit act) Nothing +-- -- [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits] + +asEdit :: Action -> WorkspaceEdit +asEdit act@Action{..} = WorkspaceEdit (Just $ Map.singleton aUri $ List (asTextEdits act) ) Nothing + +asTextEdits :: Action -> [TextEdit] +asTextEdits Action{..} = [TextEdit aRange aCode] + +out :: [String] -> IO () +out = print . unwords . ("Plugin ModuleName " :) +-- out _ = return () From 8f80f9a4670a770dc67eb0db87513201a0ed60d1 Mon Sep 17 00:00:00 2001 From: Pasqualino Titto Assini Date: Thu, 8 Oct 2020 22:39:06 +0200 Subject: [PATCH 2/8] added Ide.Plugin.ModuleName to cabal --- haskell-language-server.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index d931e72140..773f003fc7 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -88,6 +88,7 @@ executable haskell-language-server Ide.Plugin.Floskell Ide.Plugin.Fourmolu Ide.Plugin.ImportLens + Ide.Plugin.ModuleName Ide.Plugin.Ormolu Ide.Plugin.Pragmas Ide.Plugin.Retrie From 75629245987d35504e242018fd591736dd340cba Mon Sep 17 00:00:00 2001 From: Pasqualino Titto Assini Date: Thu, 8 Oct 2020 22:48:50 +0200 Subject: [PATCH 3/8] Removed tracing, fixed documentation --- plugins/default/src/Ide/Plugin/ModuleName.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs index 9f683089c5..256dc5543e 100644 --- a/plugins/default/src/Ide/Plugin/ModuleName.hs +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -5,7 +5,12 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} --- |Keep the module name in sync with its file path. +{-| Keep the module name in sync with its file path. + +Provide CodeLenses to: +* Add a module header ('module where") to empty Haskell files +* Fix the mdule name if incorrect +-} module Ide.Plugin.ModuleName ( descriptor @@ -153,5 +158,5 @@ asTextEdits :: Action -> [TextEdit] asTextEdits Action{..} = [TextEdit aRange aCode] out :: [String] -> IO () -out = print . unwords . ("Plugin ModuleName " :) --- out _ = return () +-- out = print . unwords . ("Plugin ModuleName " :) +out _ = return () From 6ab0630464c0015f9575b9725aac88855e4441df Mon Sep 17 00:00:00 2001 From: Pasqualino Titto Assini Date: Thu, 8 Oct 2020 22:51:28 +0200 Subject: [PATCH 4/8] fixed misspelling --- plugins/default/src/Ide/Plugin/ModuleName.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs index 256dc5543e..a93fddd5bc 100644 --- a/plugins/default/src/Ide/Plugin/ModuleName.hs +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -9,7 +9,7 @@ Provide CodeLenses to: * Add a module header ('module where") to empty Haskell files -* Fix the mdule name if incorrect +* Fix the module name if incorrect -} module Ide.Plugin.ModuleName From 6399425e7d138e87db3eec3226eb8319efe056dc Mon Sep 17 00:00:00 2001 From: Pasqualino Titto Assini Date: Sat, 10 Oct 2020 19:37:42 +0200 Subject: [PATCH 5/8] Get import paths directly from session --- plugins/default/src/Ide/Plugin/ModuleName.hs | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs index a93fddd5bc..d7ffec732c 100644 --- a/plugins/default/src/Ide/Plugin/ModuleName.hs +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -28,9 +28,9 @@ import Data.Maybe (listToMaybe) import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T -import Development.IDE (GetParsedModule (GetParsedModule), +import Development.IDE (hscEnvWithImportPaths, GetParsedModule (GetParsedModule), GhcSession (GhcSession), - HscEnvEq (hscEnv), IdeState, + HscEnvEq, IdeState, List (..), NormalizedFilePath, Position (Position), Range (Range), evalGhcEnv, realSrcSpanToRange, @@ -39,12 +39,9 @@ import Development.IDE (GetParsedModule (GetParsedModule), import Development.IDE.Plugin (getPid) import GHC (DynFlags (importPaths), GenLocated (L), - GhcMonad (getSession), HsModule (hsmodName), ParsedModule (pm_parsed_source), - SrcSpan (RealSrcSpan), unLoc) -import GhcPlugins (HscEnv (hsc_IC), - InteractiveContext (ic_dflags)) + SrcSpan (RealSrcSpan), unLoc,getSessionDynFlags) import Ide.Types (CommandFunction, CommandId (..), PluginCommand (..), PluginDescriptor (..), @@ -124,11 +121,10 @@ actions convert lsp state uri = do pathModuleName :: IdeState -> NormalizedFilePath -> String -> IO (Maybe Text) pathModuleName state nfp fp = do session :: HscEnvEq <- runAction "ModuleName.ghcSession" state $ use_ GhcSession nfp - paths <- evalGhcEnv (hscEnv session) $ do - env <- getSession - let df = ic_dflags . hsc_IC $ env - return $ importPaths df + + paths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags out ["import paths",show paths] + let maybePrefix = listToMaybe . filter (`isPrefixOf` fp) $ paths out ["prefix",show maybePrefix] let maybeMdlName = (\prefix -> replace "/" "." . drop (length prefix+1) $ dropExtension fp) <$> maybePrefix @@ -158,5 +154,5 @@ asTextEdits :: Action -> [TextEdit] asTextEdits Action{..} = [TextEdit aRange aCode] out :: [String] -> IO () --- out = print . unwords . ("Plugin ModuleName " :) -out _ = return () +out = print . unwords . ("Plugin ModuleName " :) +-- out _ = return () From d035ea1f31637f3790b347d707ea4310dcf1df1b Mon Sep 17 00:00:00 2001 From: Pasqualino Titto Assini Date: Sun, 11 Oct 2020 13:38:16 +0200 Subject: [PATCH 6/8] exported mkLspCmdId --- hls-plugin-api/src/Ide/Plugin.hs | 1 + plugins/default/src/Ide/Plugin/ModuleName.hs | 275 ++++++++++++------- 2 files changed, 175 insertions(+), 101 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin.hs b/hls-plugin-api/src/Ide/Plugin.hs index 1ef7c3e436..74221fd141 100644 --- a/hls-plugin-api/src/Ide/Plugin.hs +++ b/hls-plugin-api/src/Ide/Plugin.hs @@ -12,6 +12,7 @@ module Ide.Plugin asGhcIdePlugin , pluginDescToIdePlugins , mkLspCommand + , mkLspCmdId , allLspCmdIds , allLspCmdIds' , getPid diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs index d7ffec732c..710147ec2e 100644 --- a/plugins/default/src/Ide/Plugin/ModuleName.hs +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -12,147 +12,220 @@ Provide CodeLenses to: * Fix the module name if incorrect -} module Ide.Plugin.ModuleName - ( descriptor ) where -import Control.Monad (join) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Maybe () -import Data.Aeson (ToJSON (toJSON), Value (Null)) -import qualified Data.HashMap.Strict as Map -import Data.List (isPrefixOf) -import Data.List.Extra (replace) -import Data.Maybe (listToMaybe) -import Data.String (IsString) -import Data.Text (Text) -import qualified Data.Text as T -import Development.IDE (hscEnvWithImportPaths, GetParsedModule (GetParsedModule), - GhcSession (GhcSession), - HscEnvEq, IdeState, - List (..), NormalizedFilePath, - Position (Position), Range (Range), - evalGhcEnv, realSrcSpanToRange, - runAction, toNormalizedUri, - uriToFilePath', use, use_) -import Development.IDE.Plugin (getPid) -import GHC (DynFlags (importPaths), - GenLocated (L), - HsModule (hsmodName), - ParsedModule (pm_parsed_source), - SrcSpan (RealSrcSpan), unLoc,getSessionDynFlags) -import Ide.Types (CommandFunction, CommandId (..), - PluginCommand (..), - PluginDescriptor (..), - PluginId (..), - defaultPluginDescriptor) -import Language.Haskell.LSP.Core (LspFuncs, getVirtualFileFunc) -import Language.Haskell.LSP.Types (ApplyWorkspaceEditParams (..), - CAResult (CACodeAction), - CodeAction (CodeAction), - CodeActionKind (CodeActionQuickFix), - CodeLens (CodeLens), - CodeLensParams (CodeLensParams), - Command (Command), - ServerMethod (..), - TextDocumentIdentifier (TextDocumentIdentifier), - TextEdit (TextEdit), Uri, - WorkspaceEdit (..), - uriToNormalizedFilePath) -import Language.Haskell.LSP.VFS (virtualFileText) -import System.FilePath (dropExtension) +import Control.Monad ( join ) +import Control.Monad.IO.Class ( MonadIO(liftIO) ) +import Control.Monad.Trans.Maybe ( ) +import Data.Aeson ( ToJSON(toJSON) + , Value(Null) + ) +import qualified Data.HashMap.Strict as Map +import Data.List ( isPrefixOf ) +import Data.List.Extra ( replace ) +import Data.Maybe ( listToMaybe ) +import Data.String ( IsString ) +import Data.Text ( Text ) +import qualified Data.Text as T +import Development.IDE ( hscEnvWithImportPaths + , GetParsedModule + ( GetParsedModule + ) + , GhcSession(GhcSession) + , HscEnvEq + , IdeState + , List(..) + , NormalizedFilePath + , Position(Position) + , Range(Range) + , evalGhcEnv + , realSrcSpanToRange + , runAction + , toNormalizedUri + , uriToFilePath' + , use + , use_ + ) +import Development.IDE.Plugin ( getPid ) +import GHC ( DynFlags(importPaths) + , GenLocated(L) + , HsModule(hsmodName) + , ParsedModule(pm_parsed_source) + , SrcSpan(RealSrcSpan) + , unLoc + , getSessionDynFlags + ) +import Ide.Types ( CommandFunction + , PluginCommand(..) + , PluginDescriptor(..) + , PluginId(..) + , defaultPluginDescriptor + ) +import Language.Haskell.LSP.Core ( LspFuncs + , getVirtualFileFunc + ) +import Language.Haskell.LSP.Types ( ApplyWorkspaceEditParams(..) + , CAResult(CACodeAction) + , CodeAction(CodeAction) + , CodeActionKind + ( CodeActionQuickFix + ) + , CodeLens(CodeLens) + , CodeLensParams(CodeLensParams) + , Command(Command) + , ServerMethod(..) + , TextDocumentIdentifier + ( TextDocumentIdentifier + ) + , TextEdit(TextEdit) + , Uri + , WorkspaceEdit(..) + , uriToNormalizedFilePath + ) +import Language.Haskell.LSP.VFS ( virtualFileText ) +import System.FilePath ( dropExtension ) +import Ide.Plugin ( mkLspCmdId ) -- |Plugin descriptor descriptor :: PluginId -> PluginDescriptor -descriptor plId = - (defaultPluginDescriptor plId) - { pluginId = plId, - pluginCodeLensProvider = Just codeLens - ,pluginCommands = [PluginCommand editCommandName editCommandName editCmd] +descriptor plId = (defaultPluginDescriptor plId) + { pluginId = plId + , pluginCodeLensProvider = Just codeLens + , pluginCommands = [PluginCommand editCommandName editCommandName editCmd] -- pluginCodeActionProvider = Just codeAction - } + } -- | Generate code lenses -codeLens :: LspFuncs c -> IdeState -> PluginId -> CodeLensParams -> IO (Either a2 (List CodeLens)) -codeLens lsp state pluginId (CodeLensParams (TextDocumentIdentifier uri) _) = do - pid <- getPid - actions (asCodeLens (mkLspCmdId pid pluginId editCommandName)) lsp state uri +codeLens + :: LspFuncs c + -> IdeState + -> PluginId + -> CodeLensParams + -> IO (Either a2 (List CodeLens)) +codeLens lsp state pluginId (CodeLensParams (TextDocumentIdentifier uri) _) = + do + pid <- getPid + actions (asCodeLens (mkLspCmdId pid pluginId editCommandName)) lsp state uri -- | Generate code actions. -- NOTE: Not invoked on an empty module (but codeLens is, why?) -codeAction :: LspFuncs c -> IdeState -> p1 -> TextDocumentIdentifier -> p2 -> p3 -> IO (Either a (List CAResult)) -codeAction lsp state _plId (TextDocumentIdentifier uri) _range _ = actions asCodeAction lsp state uri - --- Copied from "Ide.Plugin" -mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text -mkLspCmdId pid (PluginId plid) (CommandId cid) - = pid <> ":" <> plid <> ":" <> cid +codeAction + :: LspFuncs c + -> IdeState + -> p1 + -> TextDocumentIdentifier + -> p2 + -> p3 + -> IO (Either a (List CAResult)) +codeAction lsp state _plId (TextDocumentIdentifier uri) _range _ = + actions asCodeAction lsp state uri editCommandName :: IsString p => p editCommandName = "edit" -- | Generic command to apply a group of edits editCmd :: CommandFunction WorkspaceEdit -editCmd _lf _ide workspaceEdits = return (Right Null, Just $ (WorkspaceApplyEdit,ApplyWorkspaceEditParams workspaceEdits)) +editCmd _lf _ide workspaceEdits = return + ( Right Null + , Just $ (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits) + ) -- | Required actions (actually, at most one) that can be converted to either CodeLenses or CodeActions -actions :: Show a1 => (Action -> a1) -> LspFuncs c -> IdeState -> Uri -> IO (Either a2 (List a1)) +actions + :: Show a1 + => (Action -> a1) + -> LspFuncs c + -> IdeState + -> Uri + -> IO (Either a2 (List a1)) actions convert lsp state uri = do - let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri - let Just fp = uriToFilePath' uri - - contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri - let emptyModule = maybe True ((==0) . T.length . T.strip . virtualFileText) contents - - correctNameMaybe <- pathModuleName state nfp fp - statedNameMaybe <- codeModuleName state nfp - - let act = Action uri - let actions = case (correctNameMaybe,statedNameMaybe) of - (Just correctName,Just (nameRange,statedName)) | correctName /= statedName -> [convert $ act nameRange ("Set module name to " <> correctName) correctName] - (Just correctName,_) | emptyModule -> let code = T.unwords ["module",correctName,"where\n"] in [convert $ act (Range (Position 0 0) (Position 0 0)) code code] - _ -> [] - - out ["actions",show actions] - pure . Right . List $ actions + let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri + let Just fp = uriToFilePath' uri + out ["actions[", fp] + + contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri + let emptyModule = + maybe True ((== 0) . T.length . T.strip . virtualFileText) contents + + correctNameMaybe <- pathModuleName state nfp fp + statedNameMaybe <- codeModuleName state nfp + out ["correct", show correctNameMaybe, "stated", show statedNameMaybe] + + let act = Action uri + let + actions = case (correctNameMaybe, statedNameMaybe) of + (Just correctName, Just (nameRange, statedName)) + | correctName /= statedName + -> [ convert $ act nameRange + ("Set module name to " <> correctName) + correctName + ] + (Just correctName, _) | emptyModule -> + let code = T.unwords ["module", correctName, "where\n"] + in [convert $ act (Range (Position 0 0) (Position 0 0)) code code] + _ -> [] + + out ["actions", show actions] + pure . Right . List $ actions -- | The module name, as derived by the position of the module in its source directory pathModuleName :: IdeState -> NormalizedFilePath -> String -> IO (Maybe Text) -pathModuleName state nfp fp = do - session :: HscEnvEq <- runAction "ModuleName.ghcSession" state $ use_ GhcSession nfp - - paths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags - out ["import paths",show paths] - - let maybePrefix = listToMaybe . filter (`isPrefixOf` fp) $ paths - out ["prefix",show maybePrefix] - let maybeMdlName = (\prefix -> replace "/" "." . drop (length prefix+1) $ dropExtension fp) <$> maybePrefix - out ["mdlName",show maybeMdlName] - return $ T.pack <$> maybeMdlName +pathModuleName state nfp fp = do + session :: HscEnvEq <- runAction "ModuleName.ghcSession" state + $ use_ GhcSession nfp + + paths <- + evalGhcEnv (hscEnvWithImportPaths session) + $ importPaths + <$> getSessionDynFlags + out ["import paths", show paths] + + let maybePrefix = listToMaybe . filter (`isPrefixOf` fp) $ paths + out ["prefix", show maybePrefix] + let maybeMdlName = + (\prefix -> + replace "/" "." . drop (length prefix + 1) $ dropExtension fp + ) + <$> maybePrefix + out ["mdlName", show maybeMdlName] + return $ T.pack <$> maybeMdlName -- | The module name, as stated in the module codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, Text)) -codeModuleName state nfp = ((\(L (RealSrcSpan l) m) -> (realSrcSpanToRange l,T.pack . show $ m)) <$>) . join . (hsmodName . unLoc . pm_parsed_source <$>) <$> runAction "ModuleName.GetParsedModule" state (use GetParsedModule nfp) +codeModuleName state nfp = + ((\(L (RealSrcSpan l) m) -> (realSrcSpanToRange l, T.pack . show $ m)) <$>) + . join + . (hsmodName . unLoc . pm_parsed_source <$>) + <$> runAction "ModuleName.GetParsedModule" state (use GetParsedModule nfp) -- | A source code change data Action = Action {aUri::Uri,aRange::Range,aTitle::Text,aCode::Text} deriving Show -- | Convert an Action to a CodeLens asCodeLens :: Text -> Action -> CodeLens -asCodeLens cid act@Action{..} = CodeLens aRange (Just $ Command aTitle cid (Just (List [toJSON $ asEdit act]))) Nothing +asCodeLens cid act@Action {..} = CodeLens + aRange + (Just $ Command aTitle cid (Just (List [toJSON $ asEdit act]))) + Nothing -- | Convert an Action to a CodeAction asCodeAction :: Action -> CAResult -asCodeAction act@Action{..} = CACodeAction $ CodeAction aTitle (Just CodeActionQuickFix) (Just $ List []) (Just $ asEdit act) Nothing --- -- [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits] +asCodeAction act@Action {..} = CACodeAction $ CodeAction + aTitle + (Just CodeActionQuickFix) + (Just $ List []) + (Just $ asEdit act) + Nothing asEdit :: Action -> WorkspaceEdit -asEdit act@Action{..} = WorkspaceEdit (Just $ Map.singleton aUri $ List (asTextEdits act) ) Nothing +asEdit act@Action {..} = + WorkspaceEdit (Just $ Map.singleton aUri $ List (asTextEdits act)) Nothing asTextEdits :: Action -> [TextEdit] -asTextEdits Action{..} = [TextEdit aRange aCode] +asTextEdits Action {..} = [TextEdit aRange aCode] out :: [String] -> IO () -out = print . unwords . ("Plugin ModuleName " :) --- out _ = return () +-- out = print . unwords . ("Plugin ModuleName " :) +out _ = return () From c628078996f37a5df0aa4387ae68b4ef29284363 Mon Sep 17 00:00:00 2001 From: Pasqualino Titto Assini Date: Sun, 11 Oct 2020 17:08:10 +0200 Subject: [PATCH 7/8] Added tests, canonicalized paths --- haskell-language-server.cabal | 1 + plugins/default/src/Ide/Plugin/ModuleName.hs | 49 +++++++++------ test/functional/Main.hs | 59 ++++++++++--------- test/functional/ModuleName.hs | 57 ++++++++++++++++++ test/testdata/moduleName/TEmptyModule.hs | 2 + .../moduleName/TEmptyModule.hs.expected | 3 + test/testdata/moduleName/TWrongModuleName.hs | 7 +++ .../moduleName/TWrongModuleName.hs.expected | 7 +++ 8 files changed, 140 insertions(+), 45 deletions(-) create mode 100644 test/functional/ModuleName.hs create mode 100644 test/testdata/moduleName/TEmptyModule.hs create mode 100644 test/testdata/moduleName/TEmptyModule.hs.expected create mode 100644 test/testdata/moduleName/TWrongModuleName.hs create mode 100644 test/testdata/moduleName/TWrongModuleName.hs.expected diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 773f003fc7..ea9d4f52ff 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -263,6 +263,7 @@ test-suite func-test FunctionalLiquid HieBios Highlight + ModuleName Progress Reference Rename diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs index 710147ec2e..97ffbe0abf 100644 --- a/plugins/default/src/Ide/Plugin/ModuleName.hs +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -8,7 +8,7 @@ {-| Keep the module name in sync with its file path. Provide CodeLenses to: -* Add a module header ('module where") to empty Haskell files +* Add a module header ("module /moduleName/ where") to empty Haskell files * Fix the module name if incorrect -} module Ide.Plugin.ModuleName @@ -85,9 +85,16 @@ import Language.Haskell.LSP.Types ( ApplyWorkspaceEditParams(..) , uriToNormalizedFilePath ) import Language.Haskell.LSP.VFS ( virtualFileText ) -import System.FilePath ( dropExtension ) +import System.FilePath ( splitDirectories + , dropExtension + ) import Ide.Plugin ( mkLspCmdId ) - +import Development.IDE.Types.Logger +import Development.IDE.Core.Shake +import Data.Text ( pack ) +import System.Directory ( canonicalizePath ) +import Data.List +import Ide.Plugin.Tactic.Debug ( unsafeRender ) -- |Plugin descriptor descriptor :: PluginId -> PluginDescriptor descriptor plId = (defaultPluginDescriptor plId) @@ -143,7 +150,6 @@ actions actions convert lsp state uri = do let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri let Just fp = uriToFilePath' uri - out ["actions[", fp] contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri let emptyModule = @@ -151,7 +157,7 @@ actions convert lsp state uri = do correctNameMaybe <- pathModuleName state nfp fp statedNameMaybe <- codeModuleName state nfp - out ["correct", show correctNameMaybe, "stated", show statedNameMaybe] + out state ["correct", show correctNameMaybe, "stated", show statedNameMaybe] let act = Action uri let @@ -167,29 +173,35 @@ actions convert lsp state uri = do in [convert $ act (Range (Position 0 0) (Position 0 0)) code code] _ -> [] - out ["actions", show actions] + out state ["actions", show actions] pure . Right . List $ actions -- | The module name, as derived by the position of the module in its source directory pathModuleName :: IdeState -> NormalizedFilePath -> String -> IO (Maybe Text) -pathModuleName state nfp fp = do +pathModuleName state normFilePath filePath = do session :: HscEnvEq <- runAction "ModuleName.ghcSession" state - $ use_ GhcSession nfp + $ use_ GhcSession normFilePath - paths <- + srcPaths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags - out ["import paths", show paths] + out state ["import paths", show srcPaths] + paths <- mapM canonicalizePath srcPaths + mdlPath <- canonicalizePath filePath + out state ["canonic paths", show paths, "mdlPath", mdlPath] + let maybePrefix = listToMaybe . filter (`isPrefixOf` mdlPath) $ paths + out state ["prefix", show maybePrefix] - let maybePrefix = listToMaybe . filter (`isPrefixOf` fp) $ paths - out ["prefix", show maybePrefix] let maybeMdlName = (\prefix -> - replace "/" "." . drop (length prefix + 1) $ dropExtension fp + intercalate "." + . splitDirectories + . drop (length prefix + 1) + $ dropExtension mdlPath ) <$> maybePrefix - out ["mdlName", show maybeMdlName] + out state ["mdlName", show maybeMdlName] return $ T.pack <$> maybeMdlName -- | The module name, as stated in the module @@ -226,6 +238,9 @@ asEdit act@Action {..} = asTextEdits :: Action -> [TextEdit] asTextEdits Action {..} = [TextEdit aRange aCode] -out :: [String] -> IO () --- out = print . unwords . ("Plugin ModuleName " :) -out _ = return () +out :: IdeState -> [String] -> IO () +out state = + logPriority (ideLogger state) Debug + . pack + . unwords + . ("Plugin ModuleName " :) diff --git a/test/functional/Main.hs b/test/functional/Main.hs index d499adc3f5..4e2965d9ad 100644 --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -1,39 +1,41 @@ module Main where -import Test.Tasty -import Test.Tasty.Runners (listingTests, consoleTestReporter) -import Test.Tasty.Ingredients.Rerun -import Test.Tasty.Runners.AntXML +import Test.Tasty +import Test.Tasty.Runners ( listingTests + , consoleTestReporter + ) +import Test.Tasty.Ingredients.Rerun +import Test.Tasty.Runners.AntXML -import Command -import Completion -import Deferred -import Definition -import Diagnostic -import Eval -import Format -import FunctionalBadProject -import FunctionalCodeAction -import FunctionalLiquid -import HieBios -import Highlight -import Progress -import Reference -import Rename -import Symbol -import Tactic -import TypeDefinition +import Command +import Completion +import Deferred +import Definition +import Diagnostic +import Eval +import Format +import FunctionalBadProject +import FunctionalCodeAction +import FunctionalLiquid +import HieBios +import Highlight +import Progress +import Reference +import Rename +import Symbol +import Tactic +import TypeDefinition +import ModuleName main :: IO () main = -- ingredient: xml runner writes json file of test results (https://github.com/ocharles/tasty-ant-xml/blob/master/Test/Tasty/Runners/AntXML.hs) -- rerunningTests allow rerun of failed tests (https://github.com/ocharles/tasty-rerun/blob/master/src/Test/Tasty/Ingredients/Rerun.hs) - defaultMainWithIngredients [ - antXMLRunner - , rerunningTests [ listingTests, consoleTestReporter ] - ] - $ testGroup "haskell-language-server" [ - Command.tests + defaultMainWithIngredients + [antXMLRunner, rerunningTests [listingTests, consoleTestReporter]] + $ testGroup + "haskell-language-server" + [ Command.tests , Completion.tests , Deferred.tests , Definition.tests @@ -45,6 +47,7 @@ main = , FunctionalLiquid.tests , HieBios.tests , Highlight.tests + , ModuleName.tests , Progress.tests , Reference.tests , Rename.tests diff --git a/test/functional/ModuleName.hs b/test/functional/ModuleName.hs new file mode 100644 index 0000000000..83586e64c4 --- /dev/null +++ b/test/functional/ModuleName.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module ModuleName + ( tests + ) +where + +import Control.Applicative.Combinators + ( skipManyTill ) +import Control.Monad.IO.Class ( MonadIO(liftIO) ) +import qualified Data.Text.IO as T +import Language.Haskell.LSP.Test ( fullCaps + , documentContents + , executeCommand + , getCodeLenses + , openDoc + , runSession + , anyMessage + , message + ) +import Language.Haskell.LSP.Types ( ApplyWorkspaceEditRequest + , CodeLens(..) + ) +import System.FilePath ( (<.>) + , () + ) +import Test.Hls.Util ( hieCommand ) +import Test.Tasty ( TestTree + , testGroup + ) +import Test.Tasty.HUnit ( testCase + , (@?=) + ) + +tests :: TestTree +tests = testGroup + "moduleName" + [ testCase "Add module header to empty module" $ goldenTest "TEmptyModule.hs" + , testCase "Fix wrong module name" $ goldenTest "TWrongModuleName.hs" + ] + +goldenTest :: FilePath -> IO () +goldenTest input = runSession hieCommand fullCaps testdataPath $ do + doc <- openDoc input "haskell" + -- getCodeLenses doc >>= liftIO . print . length + [CodeLens { _command = Just c }] <- getCodeLenses doc + executeCommand c + _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + edited <- documentContents doc + -- liftIO $ T.writeFile (testdataPath input <.> "expected") edited + expected <- liftIO $ T.readFile $ testdataPath input <.> "expected" + liftIO $ edited @?= expected + +testdataPath :: FilePath +testdataPath = "test/testdata/moduleName" diff --git a/test/testdata/moduleName/TEmptyModule.hs b/test/testdata/moduleName/TEmptyModule.hs new file mode 100644 index 0000000000..139597f9cb --- /dev/null +++ b/test/testdata/moduleName/TEmptyModule.hs @@ -0,0 +1,2 @@ + + diff --git a/test/testdata/moduleName/TEmptyModule.hs.expected b/test/testdata/moduleName/TEmptyModule.hs.expected new file mode 100644 index 0000000000..214c20b678 --- /dev/null +++ b/test/testdata/moduleName/TEmptyModule.hs.expected @@ -0,0 +1,3 @@ +module TEmptyModule where + + diff --git a/test/testdata/moduleName/TWrongModuleName.hs b/test/testdata/moduleName/TWrongModuleName.hs new file mode 100644 index 0000000000..ede67750f5 --- /dev/null +++ b/test/testdata/moduleName/TWrongModuleName.hs @@ -0,0 +1,7 @@ +module BadName + ( x + ) +where + +x :: Integer +x = 11 diff --git a/test/testdata/moduleName/TWrongModuleName.hs.expected b/test/testdata/moduleName/TWrongModuleName.hs.expected new file mode 100644 index 0000000000..87fb0f5b10 --- /dev/null +++ b/test/testdata/moduleName/TWrongModuleName.hs.expected @@ -0,0 +1,7 @@ +module TWrongModuleName + ( x + ) +where + +x :: Integer +x = 11 From 7f748a9977c106472fa744ad9beacba7805bff23 Mon Sep 17 00:00:00 2001 From: Pasqualino Titto Assini Date: Sun, 11 Oct 2020 17:23:05 +0200 Subject: [PATCH 8/8] added cradle configuration file for moduleName tests --- test/testdata/moduleName/hie.yaml | 1 + 1 file changed, 1 insertion(+) create mode 100644 test/testdata/moduleName/hie.yaml diff --git a/test/testdata/moduleName/hie.yaml b/test/testdata/moduleName/hie.yaml new file mode 100644 index 0000000000..94263b31ce --- /dev/null +++ b/test/testdata/moduleName/hie.yaml @@ -0,0 +1 @@ +cradle: { direct: { arguments: ["TEmptyModule", "TWrongModuleName"] } }