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/haskell-language-server.cabal b/haskell-language-server.cabal index d931e72140..ea9d4f52ff 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 @@ -262,6 +263,7 @@ test-suite func-test FunctionalLiquid HieBios Highlight + ModuleName Progress Reference Rename 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 new file mode 100644 index 0000000000..97ffbe0abf --- /dev/null +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -0,0 +1,246 @@ +{-# 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. + +Provide CodeLenses to: +* Add a module header ("module /moduleName/ where") to empty Haskell files +* 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 + , 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 ( 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) + { 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 + +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 + out state ["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 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 normFilePath filePath = do + session :: HscEnvEq <- runAction "ModuleName.ghcSession" state + $ use_ GhcSession normFilePath + + srcPaths <- + evalGhcEnv (hscEnvWithImportPaths session) + $ importPaths + <$> getSessionDynFlags + 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 maybeMdlName = + (\prefix -> + intercalate "." + . splitDirectories + . drop (length prefix + 1) + $ dropExtension mdlPath + ) + <$> maybePrefix + out state ["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 + +asEdit :: Action -> WorkspaceEdit +asEdit act@Action {..} = + WorkspaceEdit (Just $ Map.singleton aUri $ List (asTextEdits act)) Nothing + +asTextEdits :: Action -> [TextEdit] +asTextEdits Action {..} = [TextEdit aRange aCode] + +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 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"] } }