From 0aaf407c25b4be32497fd2defae90af5c07aaae1 Mon Sep 17 00:00:00 2001 From: Pasqualino Titto Assini Date: Fri, 4 Dec 2020 23:28:11 +0100 Subject: [PATCH] idempotent command and code cleanup --- plugins/default/src/Ide/Plugin/ModuleName.hs | 384 +++++++++---------- 1 file changed, 184 insertions(+), 200 deletions(-) diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs index 6035dd228d..0fabfe72cf 100644 --- a/plugins/default/src/Ide/Plugin/ModuleName.hs +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -1,222 +1,206 @@ -{-# OPTIONS_GHC -Wwarn -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-unused-imports #-} -{-# LANGUAGE NamedFieldPuns, NoMonomorphismRestriction, OverloadedStrings #-} -{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-unused-imports #-} -{-| 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 /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 Data.Char (isUpper) -import qualified Data.HashMap.Strict as Map -import Data.List -import Data.List (isPrefixOf) -import Data.List.Extra (replace) -import Data.Maybe (listToMaybe) -import Data.String (IsString) -import Data.Text (Text, pack) -import qualified Data.Text as T -import Development.IDE (GetParsedModule (GetParsedModule), - GhcSession (GhcSession), - HscEnvEq, IdeState, List (..), - NormalizedFilePath, - Position (Position), - Range (Range), evalGhcEnv, - hscEnvWithImportPaths, - realSrcSpanToRange, runAction, - toNormalizedUri, uriToFilePath', - use, use_) -import Development.IDE.Core.Shake -import Development.IDE.Plugin (getPid) -import Development.IDE.Types.Logger -import GHC (DynFlags (importPaths), - GenLocated (L), - HsModule (hsmodName), - ParsedModule (pm_parsed_source), - SrcSpan (RealSrcSpan), - getSessionDynFlags, unLoc) -import Ide.Plugin (mkLspCmdId) -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.Directory (canonicalizePath) -import System.FilePath (dropExtension, splitDirectories, - takeFileName) +module Ide.Plugin.ModuleName ( + descriptor, +) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Aeson ( + ToJSON (toJSON), + Value (Null), + ) +import Data.Char (isLower) +import qualified Data.HashMap.Strict as Map +import Data.List (find, intercalate, isPrefixOf) +import Data.Maybe (maybeToList) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as T +-- import Debug.Trace (trace) +import Development.IDE ( + GetParsedModule ( + GetParsedModule + ), + GhcSession (GhcSession), + HscEnvEq, + IdeState, + List (..), + NormalizedFilePath, + Position (Position), + Range (Range), + evalGhcEnv, + hscEnvWithImportPaths, + 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), + getSessionDynFlags, + unLoc, + ) +import Ide.Plugin (mkLspCmdId) +import Ide.Types ( + CommandFunction, + PluginCommand (..), + PluginDescriptor (..), + PluginId (..), + defaultPluginDescriptor, + ) +import Language.Haskell.LSP.Core ( + LspFuncs, + getVirtualFileFunc, + ) +import Language.Haskell.LSP.Types ( + ApplyWorkspaceEditParams (..), + CodeLens (CodeLens), + CodeLensParams (CodeLensParams), + Command (Command), + ServerMethod (..), + TextDocumentIdentifier ( + TextDocumentIdentifier + ), + TextEdit (TextEdit), + Uri, + WorkspaceEdit (..), + uriToNormalizedFilePath, + ) +import Language.Haskell.LSP.VFS (virtualFileText) +import System.Directory (canonicalizePath) +import System.FilePath ( + dropExtension, + splitDirectories, + takeFileName, + ) + -- |Plugin descriptor descriptor :: PluginId -> PluginDescriptor -descriptor plId = (defaultPluginDescriptor plId) - { pluginId = plId - , pluginCodeLensProvider = Just codeLens - , pluginCommands = [PluginCommand editCommandName editCommandName editCmd] - -- pluginCodeActionProvider = Just codeAction - } +descriptor plId = + (defaultPluginDescriptor plId) + { pluginId = plId + , pluginCodeLensProvider = Just codeLens + , pluginCommands = [PluginCommand editCommandName editCommandName command] + } + +editCommandName :: IsString p => p +editCommandName = "edit" + +asCodeLens :: Text -> Action -> CodeLens +asCodeLens cid Replace{..} = + CodeLens + aRange + (Just $ Command aTitle cid (Just (List [toJSON aUri]))) + Nothing -- | Generate code lenses -codeLens - :: LspFuncs c - -> IdeState - -> PluginId - -> CodeLensParams - -> IO (Either a2 (List CodeLens)) +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 + do + pid <- getPid + Right . List . maybeToList . (asCodeLens (mkLspCmdId pid pluginId editCommandName) <$>) <$> action lsp state uri + +-- | (Quasi) Idempotent command execution: recalculate action to execute on command request +command :: CommandFunction Uri +command lsp state uri = do + actMaybe <- action lsp state uri + return + ( Right Null + , (\act -> (WorkspaceApplyEdit, ApplyWorkspaceEditParams $ asEdit act)) <$> actMaybe + ) -editCommandName :: IsString p => p -editCommandName = "edit" +-- | A source code change +data Action = Replace {aUri :: Uri, aRange :: Range, aTitle :: Text, aCode :: Text} deriving (Show) --- | 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 +-- | Convert an Action to the corresponding edit operation +asEdit :: Action -> WorkspaceEdit +asEdit act@Replace{..} = + WorkspaceEdit (Just $ Map.singleton aUri $ List (asTextEdits act)) Nothing + +asTextEdits :: Action -> [TextEdit] +asTextEdits Replace{..} = [TextEdit aRange aCode] + +-- | Required action (that can be converted to either CodeLenses or CodeActions) +action :: LspFuncs c -> IdeState -> Uri -> IO (Maybe Action) +action lsp state uri = + traceAs "action" <$> do + let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri + let Just fp = uriToFilePath' uri + + contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri + let emptyModule = maybe True (T.null . T.strip . virtualFileText) contents + + correctNameMaybe <- traceAs "correctName" <$> pathModuleName state nfp fp + statedNameMaybe <- traceAs "statedName" <$> codeModuleName state nfp + + let act = Replace uri + let todo = case (correctNameMaybe, statedNameMaybe) of + (Just correctName, Just (nameRange, statedName)) + | correctName /= statedName -> + Just $ + act + nameRange + ("Set module name to " <> correctName) + correctName + (Just correctName, _) + | emptyModule -> + let code = T.unwords ["module", correctName, "where\n"] + in Just $ act (Range (Position 0 0) (Position 0 0)) code code + _ -> Nothing + return todo -- | 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 - if isUpper $ head $ takeFileName mdlPath - then do - 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 - else return $ Just "Main" +pathModuleName state normFilePath filePath + | isLower (head $ takeFileName filePath) = return $ Just "Main" + | otherwise = do + session :: HscEnvEq <- runAction "ModuleName.ghcSession" state $ use_ GhcSession normFilePath + srcPaths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags + paths <- mapM canonicalizePath srcPaths + mdlPath <- canonicalizePath filePath + let maybePrefix = find (`isPrefixOf` mdlPath) paths + + let maybeMdlName = + ( \prefix -> + intercalate "." + . splitDirectories + . drop (length prefix + 1) + $ dropExtension mdlPath + ) + <$> maybePrefix + 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) + ((\(L (RealSrcSpan l) m) -> (realSrcSpanToRange l, T.pack . show $ m)) <$>) + . ((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 +-- traceAs :: Show a => String -> a -> a +-- traceAs lbl a = trace (lbl ++ " = " ++ show a) a --- | 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 " :) +traceAs :: b -> a -> a +traceAs _ a = a