diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs index a7b878f387..6035dd228d 100644 --- a/plugins/default/src/Ide/Plugin/ModuleName.hs +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -1,9 +1,6 @@ {-# 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 #-} +{-# LANGUAGE NamedFieldPuns, NoMonomorphismRestriction, OverloadedStrings #-} +{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} {-| Keep the module name in sync with its file path. @@ -16,84 +13,61 @@ module Ide.Plugin.ModuleName ) 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 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) -- |Plugin descriptor descriptor :: PluginId -> PluginDescriptor descriptor plId = (defaultPluginDescriptor plId) @@ -188,20 +162,23 @@ pathModuleName state normFilePath filePath = do 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 + 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" -- | The module name, as stated in the module codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, Text)) diff --git a/test/functional/ModuleName.hs b/test/functional/ModuleName.hs index 641cd82269..512d4a546f 100644 --- a/test/functional/ModuleName.hs +++ b/test/functional/ModuleName.hs @@ -7,38 +7,26 @@ module ModuleName ) 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 ( hlsCommand ) -import Test.Tasty ( TestTree - , testGroup - ) -import Test.Tasty.HUnit ( testCase - , (@?=) - ) +import Control.Applicative.Combinators (skipManyTill) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Text.IO as T +import Language.Haskell.LSP.Test (anyMessage, documentContents, + executeCommand, fullCaps, + getCodeLenses, message, + openDoc, runSession) +import Language.Haskell.LSP.Types (ApplyWorkspaceEditRequest, + CodeLens (..)) +import System.FilePath ((<.>), ()) +import Test.Hls.Util (hlsCommand) +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" + , testCase "Must infer module name as Main, if the file name starts with a lowercase" $ goldenTest "mainlike.hs" ] goldenTest :: FilePath -> IO () diff --git a/test/testdata/moduleName/hie.yaml b/test/testdata/moduleName/hie.yaml index 94263b31ce..bf9d384c32 100644 --- a/test/testdata/moduleName/hie.yaml +++ b/test/testdata/moduleName/hie.yaml @@ -1 +1 @@ -cradle: { direct: { arguments: ["TEmptyModule", "TWrongModuleName"] } } +cradle: { direct: { arguments: ["TEmptyModule", "TWrongModuleName", "mainlike"] } } diff --git a/test/testdata/moduleName/mainlike.hs b/test/testdata/moduleName/mainlike.hs new file mode 100644 index 0000000000..e69de29bb2 diff --git a/test/testdata/moduleName/mainlike.hs.expected b/test/testdata/moduleName/mainlike.hs.expected new file mode 100644 index 0000000000..6ca9a1fce6 --- /dev/null +++ b/test/testdata/moduleName/mainlike.hs.expected @@ -0,0 +1 @@ +module Main where