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