From 8cebdd57433689fb18d5c72c3f324210c3750112 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Thu, 15 Apr 2021 09:13:35 +0100 Subject: [PATCH 01/10] added option to always insert pragmas at top of file --- haskell-language-server.cabal | 4 +++- hls-plugin-api/src/Ide/Plugin/Config.hs | 4 ++++ plugins/default/src/Ide/Plugin/Pragmas.hs | 21 ++++++++++++++------- 3 files changed, 21 insertions(+), 8 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 872997da48..96d3299dcc 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -229,7 +229,9 @@ common moduleName common pragmas if flag(pragmas) || flag(all-plugins) hs-source-dirs: plugins/default/src - build-depends: fuzzy + build-depends: + , fuzzy + , data-default other-modules: Ide.Plugin.Pragmas cpp-options: -Dpragmas diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 150ecaf683..21b068979b 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -55,6 +55,7 @@ data Config = , diagnosticsDebounceDuration :: !Int , liquidOn :: !Bool , formatOnImportOn :: !Bool + , pragmaInsertAfterComments :: !Bool , formattingProvider :: !T.Text , maxCompletions :: !Int , plugins :: !(Map.Map T.Text PluginConfig) @@ -69,6 +70,7 @@ instance Default Config where , diagnosticsDebounceDuration = 350000 , liquidOn = False , formatOnImportOn = True + , pragmaInsertAfterComments = True -- , formattingProvider = "brittany" , formattingProvider = "ormolu" -- , formattingProvider = "floskell" @@ -93,6 +95,7 @@ parseConfig defValue = A.withObject "Config" $ \v -> do <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration defValue <*> o .:? "liquidOn" .!= liquidOn defValue <*> o .:? "formatOnImportOn" .!= formatOnImportOn defValue + <*> o .:? "pragmaInsertAfterComments" .!= pragmaInsertAfterComments defValue <*> o .:? "formattingProvider" .!= formattingProvider defValue <*> o .:? "maxCompletions" .!= maxCompletions defValue <*> o .:? "plugin" .!= plugins defValue @@ -108,6 +111,7 @@ instance A.ToJSON Config where , "diagnosticsDebounceDuration" .= diagnosticsDebounceDuration , "liquidOn" .= liquidOn , "formatOnImportOn" .= formatOnImportOn + , "pragmaInsertAfterComments" .= pragmaInsertAfterComments , "formattingProvider" .= formattingProvider , "maxCompletions" .= maxCompletions , "plugin" .= plugins diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index 9eb0a96761..c8434b4c57 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -1,3 +1,4 @@ + {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -10,6 +11,8 @@ import Control.Applicative ((<|>)) import Control.Lens hiding (List) import Control.Monad (join) import Control.Monad.IO.Class +import Ide.Plugin.Config +import Data.Default import qualified Data.HashMap.Strict as H import Data.List.Extra (nubOrdOn) import Data.Maybe (catMaybes, listToMaybe) @@ -42,13 +45,17 @@ data Pragma = LangExt T.Text | OptGHC T.Text codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction codeActionProvider state _plId (CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly)) = do - let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' - uri = docId ^. J.uri - pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModule" state $ getParsedModule `traverse` mFile - let dflags = ms_hspp_opts . pm_mod_summary <$> pm - insertRange = maybe (Range (Position 0 0) (Position 0 0)) endOfModuleHeader pm - pedits = nubOrdOn snd . concat $ suggest dflags <$> diags - return $ Right $ List $ pragmaEditToAction uri insertRange <$> pedits + let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' + uri = docId ^. J.uri + pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModule" state $ getParsedModule `traverse` mFile + config <- liftIO $ runAction "getConfig" state (getClientConfigAction def) + let dflags = ms_hspp_opts . pm_mod_summary <$> pm + pedits = nubOrdOn snd . concat $ suggest dflags <$> diags + insertAfterComments = pragmaInsertAfterComments config + return $ Right $ List $ pragmaEditToAction uri (getInsertRange insertAfterComments pm) <$> pedits + where + getInsertRange True (Just pm) = endOfModuleHeader pm + getInsertRange _ _ = Range (Position 0 0) (Position 0 0) -- | Add a Pragma to the given URI at the top of the file. -- It is assumed that the pragma name is a valid pragma, From c08ee6476d0d6d476abaa125c371749604f552a6 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Thu, 15 Apr 2021 15:28:45 +0100 Subject: [PATCH 02/10] Revert "added option to always insert pragmas at top of file" This reverts commit 8cebdd57433689fb18d5c72c3f324210c3750112. --- haskell-language-server.cabal | 4 +--- hls-plugin-api/src/Ide/Plugin/Config.hs | 4 ---- plugins/default/src/Ide/Plugin/Pragmas.hs | 21 +++++++-------------- 3 files changed, 8 insertions(+), 21 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 96d3299dcc..872997da48 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -229,9 +229,7 @@ common moduleName common pragmas if flag(pragmas) || flag(all-plugins) hs-source-dirs: plugins/default/src - build-depends: - , fuzzy - , data-default + build-depends: fuzzy other-modules: Ide.Plugin.Pragmas cpp-options: -Dpragmas diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 21b068979b..150ecaf683 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -55,7 +55,6 @@ data Config = , diagnosticsDebounceDuration :: !Int , liquidOn :: !Bool , formatOnImportOn :: !Bool - , pragmaInsertAfterComments :: !Bool , formattingProvider :: !T.Text , maxCompletions :: !Int , plugins :: !(Map.Map T.Text PluginConfig) @@ -70,7 +69,6 @@ instance Default Config where , diagnosticsDebounceDuration = 350000 , liquidOn = False , formatOnImportOn = True - , pragmaInsertAfterComments = True -- , formattingProvider = "brittany" , formattingProvider = "ormolu" -- , formattingProvider = "floskell" @@ -95,7 +93,6 @@ parseConfig defValue = A.withObject "Config" $ \v -> do <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration defValue <*> o .:? "liquidOn" .!= liquidOn defValue <*> o .:? "formatOnImportOn" .!= formatOnImportOn defValue - <*> o .:? "pragmaInsertAfterComments" .!= pragmaInsertAfterComments defValue <*> o .:? "formattingProvider" .!= formattingProvider defValue <*> o .:? "maxCompletions" .!= maxCompletions defValue <*> o .:? "plugin" .!= plugins defValue @@ -111,7 +108,6 @@ instance A.ToJSON Config where , "diagnosticsDebounceDuration" .= diagnosticsDebounceDuration , "liquidOn" .= liquidOn , "formatOnImportOn" .= formatOnImportOn - , "pragmaInsertAfterComments" .= pragmaInsertAfterComments , "formattingProvider" .= formattingProvider , "maxCompletions" .= maxCompletions , "plugin" .= plugins diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index c8434b4c57..9eb0a96761 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -11,8 +10,6 @@ import Control.Applicative ((<|>)) import Control.Lens hiding (List) import Control.Monad (join) import Control.Monad.IO.Class -import Ide.Plugin.Config -import Data.Default import qualified Data.HashMap.Strict as H import Data.List.Extra (nubOrdOn) import Data.Maybe (catMaybes, listToMaybe) @@ -45,17 +42,13 @@ data Pragma = LangExt T.Text | OptGHC T.Text codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction codeActionProvider state _plId (CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly)) = do - let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' - uri = docId ^. J.uri - pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModule" state $ getParsedModule `traverse` mFile - config <- liftIO $ runAction "getConfig" state (getClientConfigAction def) - let dflags = ms_hspp_opts . pm_mod_summary <$> pm - pedits = nubOrdOn snd . concat $ suggest dflags <$> diags - insertAfterComments = pragmaInsertAfterComments config - return $ Right $ List $ pragmaEditToAction uri (getInsertRange insertAfterComments pm) <$> pedits - where - getInsertRange True (Just pm) = endOfModuleHeader pm - getInsertRange _ _ = Range (Position 0 0) (Position 0 0) + let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' + uri = docId ^. J.uri + pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModule" state $ getParsedModule `traverse` mFile + let dflags = ms_hspp_opts . pm_mod_summary <$> pm + insertRange = maybe (Range (Position 0 0) (Position 0 0)) endOfModuleHeader pm + pedits = nubOrdOn snd . concat $ suggest dflags <$> diags + return $ Right $ List $ pragmaEditToAction uri insertRange <$> pedits -- | Add a Pragma to the given URI at the top of the file. -- It is assumed that the pragma name is a valid pragma, From 5a8ff8b68517b0254bee2e89938a2bd1f41a3445 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Fri, 16 Apr 2021 19:57:58 +0100 Subject: [PATCH 03/10] Pragmas inserted before comments (#1726) --- plugins/default/src/Ide/Plugin/Pragmas.hs | 19 +++++++-- test/functional/FunctionalCodeAction.hs | 44 +++++++++++++++++--- test/testdata/addPragmas/BeforeDocComment.hs | 14 +++++++ 3 files changed, 68 insertions(+), 9 deletions(-) create mode 100644 test/testdata/addPragmas/BeforeDocComment.hs diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index 9eb0a96761..b8f07884d4 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -16,6 +16,7 @@ import Data.Maybe (catMaybes, listToMaybe) import qualified Data.Text as T import Development.IDE as D import Development.IDE.GHC.Compat +import Development.IDE.Core.Rules (getParsedModuleWithComments) import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types @@ -44,7 +45,7 @@ codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction codeActionProvider state _plId (CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly)) = do let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' uri = docId ^. J.uri - pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModule" state $ getParsedModule `traverse` mFile + pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModuleWithComments" state $ getParsedModuleWithComments `traverse` mFile let dflags = ms_hspp_opts . pm_mod_summary <$> pm insertRange = maybe (Range (Position 0 0) (Position 0 0)) endOfModuleHeader pm pedits = nubOrdOn snd . concat $ suggest dflags <$> diags @@ -178,14 +179,26 @@ completion _ide _ complParams = do -- --------------------------------------------------------------------- --- | Find the first non-blank line before the first of (module name / imports / declarations). +-- | Find the first non-blank line before the first of (comment / module name / imports / declarations). -- Useful for inserting pragmas. endOfModuleHeader :: ParsedModule -> Range endOfModuleHeader pm = let mod = unLoc $ pm_parsed_source pm + firstCommentLoc = getLoc <$> lastListToMaybe (getAnnotationComments (pm_annotations pm) (UnhelpfulSpan "")) modNameLoc = getLoc <$> hsmodName mod firstImportLoc = getLoc <$> listToMaybe (hsmodImports mod) firstDeclLoc = getLoc <$> listToMaybe (hsmodDecls mod) - line = maybe 0 (_line . _start) (modNameLoc <|> firstImportLoc <|> firstDeclLoc >>= srcSpanToRange) + startLine loc = (_line . _start) <$> (loc >>= srcSpanToRange) + line = mbMin (startLine (modNameLoc <|> firstImportLoc <|> firstDeclLoc)) (startLine firstCommentLoc) loc = Position line 0 in Range loc loc + +mbMin :: Maybe Int -> Maybe Int -> Int +mbMin Nothing Nothing = 0 +mbMin (Just n) Nothing = n +mbMin Nothing (Just m) = m +mbMin (Just n) (Just m) = min n m + +lastListToMaybe :: [a] -> Maybe a +lastListToMaybe [] = Nothing +lastListToMaybe xs = Just (last xs) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 6a531113f2..b171ffcb77 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -513,8 +513,8 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ let expected = -- TODO: Why CPP??? #if __GLASGOW_HASKELL__ < 810 - [ "{-# LANGUAGE ScopedTypeVariables #-}" - , "{-# LANGUAGE TypeApplications #-}" + [ "{-# LANGUAGE TypeApplications #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" #else [ "{-# LANGUAGE TypeApplications #-}" , "{-# LANGUAGE ScopedTypeVariables #-}" @@ -584,6 +584,38 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ , "f Record{a, b} = a" ] + liftIO $ T.lines contents @?= expected + , testCase "Before Doc Comments" $ do + runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do + doc <- openDoc "BeforeDocComment.hs" "haskell" + + _ <- waitForDiagnosticsFrom doc + cas <- map fromAction <$> getAllCodeActions doc + + liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action" + + executeCodeAction $ head cas + + contents <- documentContents doc + + let expected = + [ "#! /usr/bin/env nix-shell" + , "#! nix-shell --pure -i runghc -p \"haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])\"" + , "{-# LANGUAGE NamedFieldPuns #-}" + , "-- | Doc Comment" + , "{- Block -}" + , "" + , "module BeforeDocComment where" + , "" + , "data Record = Record" + , " { a :: Int," + , " b :: Double," + , " c :: String" + , " }" + , "" + , "f Record{a, b} = a" + ] + liftIO $ T.lines contents @?= expected ] @@ -597,8 +629,8 @@ disableWarningTests = , "main = putStrLn \"hello\"" ] , T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "{-# OPTIONS_GHC -Wno-missing-signatures #-}" + [ "{-# OPTIONS_GHC -Wno-missing-signatures #-}" + , "{-# OPTIONS_GHC -Wall #-}" , "main = putStrLn \"hello\"" ] ) @@ -613,10 +645,10 @@ disableWarningTests = , "import Data.Functor" ] , T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" + [ "{-# OPTIONS_GHC -Wno-unused-imports #-}" + , "{-# OPTIONS_GHC -Wall #-}" , "" , "" - , "{-# OPTIONS_GHC -Wno-unused-imports #-}" , "module M where" , "" , "import Data.Functor" diff --git a/test/testdata/addPragmas/BeforeDocComment.hs b/test/testdata/addPragmas/BeforeDocComment.hs new file mode 100644 index 0000000000..aacabf2d3c --- /dev/null +++ b/test/testdata/addPragmas/BeforeDocComment.hs @@ -0,0 +1,14 @@ +#! /usr/bin/env nix-shell +#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +-- | Doc Comment +{- Block -} + +module BeforeDocComment where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a From 2b680c2aec541f3c4ea65390c32dbba9ef05c19a Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sat, 17 Apr 2021 06:30:39 +0100 Subject: [PATCH 04/10] Code style --- plugins/default/src/Ide/Plugin/Pragmas.hs | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index b8f07884d4..b6f14c0085 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -184,8 +184,8 @@ completion _ide _ complParams = do endOfModuleHeader :: ParsedModule -> Range endOfModuleHeader pm = let mod = unLoc $ pm_parsed_source pm - firstCommentLoc = getLoc <$> lastListToMaybe (getAnnotationComments (pm_annotations pm) (UnhelpfulSpan "")) modNameLoc = getLoc <$> hsmodName mod + firstCommentLoc = getLoc <$> listToMaybe (reverse $ getAnnotationComments (pm_annotations pm) (UnhelpfulSpan "")) firstImportLoc = getLoc <$> listToMaybe (hsmodImports mod) firstDeclLoc = getLoc <$> listToMaybe (hsmodDecls mod) startLine loc = (_line . _start) <$> (loc >>= srcSpanToRange) @@ -193,12 +193,8 @@ endOfModuleHeader pm = loc = Position line 0 in Range loc loc -mbMin :: Maybe Int -> Maybe Int -> Int -mbMin Nothing Nothing = 0 -mbMin (Just n) Nothing = n -mbMin Nothing (Just m) = m +mbMin :: (Num a, Ord a) => Maybe a -> Maybe a -> a +mbMin Nothing Nothing = 0 +mbMin (Just n) Nothing = n +mbMin Nothing (Just m) = m mbMin (Just n) (Just m) = min n m - -lastListToMaybe :: [a] -> Maybe a -lastListToMaybe [] = Nothing -lastListToMaybe xs = Just (last xs) From 66caa43a0e9254289bb6dffa3c1b0028edf5680d Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sat, 17 Apr 2021 06:34:25 +0100 Subject: [PATCH 05/10] Code style --- plugins/default/src/Ide/Plugin/Pragmas.hs | 31 +++++++++++------------ 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index b6f14c0085..dcc497563e 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -182,19 +182,18 @@ completion _ide _ complParams = do -- | Find the first non-blank line before the first of (comment / module name / imports / declarations). -- Useful for inserting pragmas. endOfModuleHeader :: ParsedModule -> Range -endOfModuleHeader pm = - let mod = unLoc $ pm_parsed_source pm - modNameLoc = getLoc <$> hsmodName mod - firstCommentLoc = getLoc <$> listToMaybe (reverse $ getAnnotationComments (pm_annotations pm) (UnhelpfulSpan "")) - firstImportLoc = getLoc <$> listToMaybe (hsmodImports mod) - firstDeclLoc = getLoc <$> listToMaybe (hsmodDecls mod) - startLine loc = (_line . _start) <$> (loc >>= srcSpanToRange) - line = mbMin (startLine (modNameLoc <|> firstImportLoc <|> firstDeclLoc)) (startLine firstCommentLoc) - loc = Position line 0 - in Range loc loc - -mbMin :: (Num a, Ord a) => Maybe a -> Maybe a -> a -mbMin Nothing Nothing = 0 -mbMin (Just n) Nothing = n -mbMin Nothing (Just m) = m -mbMin (Just n) (Just m) = min n m +endOfModuleHeader pm = Range loc loc + where + loc = Position line 0 + line = mbMin (startLine (modNameLoc <|> firstImportLoc <|> firstDeclLoc)) (startLine firstCommentLoc) + startLine loc = (_line . _start) <$> (loc >>= srcSpanToRange) + modNameLoc = getLoc <$> hsmodName mod + firstCommentLoc = getLoc <$> listToMaybe (reverse $ getAnnotationComments (pm_annotations pm) (UnhelpfulSpan "")) + firstImportLoc = getLoc <$> listToMaybe (hsmodImports mod) + firstDeclLoc = getLoc <$> listToMaybe (hsmodDecls mod) + mod = unLoc $ pm_parsed_source pm + mbMin :: (Num a, Ord a) => Maybe a -> Maybe a -> a + mbMin Nothing Nothing = 0 + mbMin (Just n) Nothing = n + mbMin Nothing (Just m) = m + mbMin (Just n) (Just m) = min n m From 89a094c4ab8581b5c60359e2e03e6ba921958a39 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sat, 17 Apr 2021 16:46:12 +0100 Subject: [PATCH 06/10] Insert pragamas to existing pragma list --- plugins/default/src/Ide/Plugin/Pragmas.hs | 38 +++++++++++---- test/functional/FunctionalCodeAction.hs | 50 +++++++++++++++----- test/testdata/addPragmas/AppendToExisting.hs | 11 +++++ 3 files changed, 77 insertions(+), 22 deletions(-) create mode 100644 test/testdata/addPragmas/AppendToExisting.hs diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index dcc497563e..3045c6540e 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -12,11 +12,11 @@ import Control.Monad (join) import Control.Monad.IO.Class import qualified Data.HashMap.Strict as H import Data.List.Extra (nubOrdOn) -import Data.Maybe (catMaybes, listToMaybe) +import Data.Maybe (catMaybes, listToMaybe, fromMaybe) import qualified Data.Text as T import Development.IDE as D -import Development.IDE.GHC.Compat import Development.IDE.Core.Rules (getParsedModuleWithComments) +import Development.IDE.GHC.Compat import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types @@ -179,21 +179,41 @@ completion _ide _ complParams = do -- --------------------------------------------------------------------- --- | Find the first non-blank line before the first of (comment / module name / imports / declarations). +-- | Find end of last pragma or first (haddock comment / module name / imports / declarations). -- Useful for inserting pragmas. endOfModuleHeader :: ParsedModule -> Range endOfModuleHeader pm = Range loc loc where + mod = unLoc $ pm_parsed_source pm loc = Position line 0 - line = mbMin (startLine (modNameLoc <|> firstImportLoc <|> firstDeclLoc)) (startLine firstCommentLoc) + line = fromMaybe (mbMin firstCodeLine firstDocLine) lastPragmaLine + firstCodeLine = let + modNameLoc = (getLoc <$> hsmodName mod) + firstImportLoc = (getLoc <$> listToMaybe (hsmodImports mod)) + firstDeclLoc = (getLoc <$> listToMaybe (hsmodDecls mod)) + in startLine $ modNameLoc <|> firstImportLoc <|> firstDeclLoc + lastPragmaLine = succ <$> annotationsStart (filter (isPragma . unLoc) comments) + firstDocLine = annotationsStart $ reverse $ filter (isHaddock . unLoc) comments + comments = getAnnotationComments (pm_annotations pm) (UnhelpfulSpan "") + annotationsStart = startLine . (getLoc <$>) . listToMaybe startLine loc = (_line . _start) <$> (loc >>= srcSpanToRange) - modNameLoc = getLoc <$> hsmodName mod - firstCommentLoc = getLoc <$> listToMaybe (reverse $ getAnnotationComments (pm_annotations pm) (UnhelpfulSpan "")) - firstImportLoc = getLoc <$> listToMaybe (hsmodImports mod) - firstDeclLoc = getLoc <$> listToMaybe (hsmodDecls mod) - mod = unLoc $ pm_parsed_source pm mbMin :: (Num a, Ord a) => Maybe a -> Maybe a -> a mbMin Nothing Nothing = 0 mbMin (Just n) Nothing = n mbMin Nothing (Just m) = m mbMin (Just n) (Just m) = min n m + +isHaddock :: AnnotationComment -> Bool +isHaddock c = case c of + AnnLineComment s -> take 4 s `elem` ["-- |", "-- ^", "-- $", "-- *"] + AnnBlockComment s -> take 3 s == "{-|" + AnnDocCommentNext _ -> True + AnnDocCommentPrev _ -> True + AnnDocCommentNamed _ -> True + AnnDocSection _ _ -> True + _ -> False + +isPragma :: AnnotationComment -> Bool +isPragma (AnnBlockComment ('{':'-':'#':_)) = True +isPragma (AnnDocOptions _) = True +isPragma _ = False diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index b171ffcb77..ee564335c2 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -511,14 +511,9 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ contents <- documentContents doc let expected = --- TODO: Why CPP??? -#if __GLASGOW_HASKELL__ < 810 - [ "{-# LANGUAGE TypeApplications #-}" - , "{-# LANGUAGE ScopedTypeVariables #-}" -#else - [ "{-# LANGUAGE TypeApplications #-}" - , "{-# LANGUAGE ScopedTypeVariables #-}" -#endif +-- TODO: Maybe needs cpp? + [ "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE TypeApplications #-}" , "module TypeApplications where" , "" , "foo :: forall a. a -> a" @@ -555,7 +550,7 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ , "f Record{a, b} = a" ] liftIO $ T.lines contents @?= expected - , testCase "After Shebang" $ do + , testCase "After shebang" $ do runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do doc <- openDoc "AfterShebang.hs" "haskell" @@ -584,6 +579,35 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ , "f Record{a, b} = a" ] + liftIO $ T.lines contents @?= expected + , testCase "Append to existing pragmas" $ do + runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do + doc <- openDoc "AppendToExisting.hs" "haskell" + + _ <- waitForDiagnosticsFrom doc + cas <- map fromAction <$> getAllCodeActions doc + + liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action" + + executeCodeAction $ head cas + + contents <- documentContents doc + + let expected = + [ "-- | Doc before pragma" + , "{-# OPTIONS_GHC -Wno-dodgy-imports #-}" + , "{-# LANGUAGE NamedFieldPuns #-}" + , "module AppendToExisting where" + , "" + , "data Record = Record" + , " { a :: Int," + , " b :: Double," + , " c :: String" + , " }" + , "" + , "f Record{a, b} = a" + ] + liftIO $ T.lines contents @?= expected , testCase "Before Doc Comments" $ do runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do @@ -629,8 +653,8 @@ disableWarningTests = , "main = putStrLn \"hello\"" ] , T.unlines - [ "{-# OPTIONS_GHC -Wno-missing-signatures #-}" - , "{-# OPTIONS_GHC -Wall #-}" + [ "{-# OPTIONS_GHC -Wall #-}" + , "{-# OPTIONS_GHC -Wno-missing-signatures #-}" , "main = putStrLn \"hello\"" ] ) @@ -645,8 +669,8 @@ disableWarningTests = , "import Data.Functor" ] , T.unlines - [ "{-# OPTIONS_GHC -Wno-unused-imports #-}" - , "{-# OPTIONS_GHC -Wall #-}" + [ "{-# OPTIONS_GHC -Wall #-}" + , "{-# OPTIONS_GHC -Wno-unused-imports #-}" , "" , "" , "module M where" diff --git a/test/testdata/addPragmas/AppendToExisting.hs b/test/testdata/addPragmas/AppendToExisting.hs new file mode 100644 index 0000000000..2beb29aab4 --- /dev/null +++ b/test/testdata/addPragmas/AppendToExisting.hs @@ -0,0 +1,11 @@ +-- | Doc before pragma +{-# OPTIONS_GHC -Wno-dodgy-imports #-} +module AppendToExisting where + +data Record = Record + { a :: Int, + b :: Double, + c :: String + } + +f Record{a, b} = a From 6157b81f9c2a3c48c9f67d181df1e378d4f9ba63 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Sat, 17 Apr 2021 18:03:30 +0100 Subject: [PATCH 07/10] added cpp macro to pragma test for ghc < 810 --- test/functional/FunctionalCodeAction.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index ee564335c2..98bf30e6ae 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -511,9 +511,14 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ contents <- documentContents doc let expected = --- TODO: Maybe needs cpp? +-- TODO: Why CPP??? +#if __GLASGOW_HASKELL__ < 810 [ "{-# LANGUAGE ScopedTypeVariables #-}" , "{-# LANGUAGE TypeApplications #-}" +#else + [ "{-# LANGUAGE TypeApplications #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" +#endif , "module TypeApplications where" , "" , "foo :: forall a. a -> a" From f68f6b7bc49957f9b3c9de173aa1296cc2f2a677 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Thu, 22 Apr 2021 00:15:14 +0100 Subject: [PATCH 08/10] Refactor: using file contents to find pragma insertion position --- plugins/default/src/Ide/Plugin/Pragmas.hs | 49 +++++------------------ test/functional/FunctionalCodeAction.hs | 8 +--- 2 files changed, 11 insertions(+), 46 deletions(-) diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index 3045c6540e..5d425597eb 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -11,11 +11,11 @@ import Control.Lens hiding (List) import Control.Monad (join) import Control.Monad.IO.Class import qualified Data.HashMap.Strict as H +import Data.List import Data.List.Extra (nubOrdOn) -import Data.Maybe (catMaybes, listToMaybe, fromMaybe) +import Data.Maybe (catMaybes, listToMaybe) import qualified Data.Text as T import Development.IDE as D -import Development.IDE.Core.Rules (getParsedModuleWithComments) import Development.IDE.GHC.Compat import Ide.Types import qualified Language.LSP.Server as LSP @@ -45,9 +45,10 @@ codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction codeActionProvider state _plId (CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly)) = do let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' uri = docId ^. J.uri - pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModuleWithComments" state $ getParsedModuleWithComments `traverse` mFile + pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsed" state $ getParsedModule `traverse` mFile + mbContents <- liftIO $ fmap join $ fmap (fmap snd) $ runAction "Pragmas.GetFileContents" state $ getFileContents `traverse` mFile let dflags = ms_hspp_opts . pm_mod_summary <$> pm - insertRange = maybe (Range (Position 0 0) (Position 0 0)) endOfModuleHeader pm + insertRange = maybe (Range (Position 0 0) (Position 0 0)) endOfModuleHeader mbContents pedits = nubOrdOn snd . concat $ suggest dflags <$> diags return $ Right $ List $ pragmaEditToAction uri insertRange <$> pedits @@ -179,41 +180,11 @@ completion _ide _ complParams = do -- --------------------------------------------------------------------- --- | Find end of last pragma or first (haddock comment / module name / imports / declarations). +-- | Find first line after (last pragma / last shebang / beginning of file). -- Useful for inserting pragmas. -endOfModuleHeader :: ParsedModule -> Range -endOfModuleHeader pm = Range loc loc +endOfModuleHeader :: T.Text -> Range +endOfModuleHeader contents = Range loc loc where - mod = unLoc $ pm_parsed_source pm loc = Position line 0 - line = fromMaybe (mbMin firstCodeLine firstDocLine) lastPragmaLine - firstCodeLine = let - modNameLoc = (getLoc <$> hsmodName mod) - firstImportLoc = (getLoc <$> listToMaybe (hsmodImports mod)) - firstDeclLoc = (getLoc <$> listToMaybe (hsmodDecls mod)) - in startLine $ modNameLoc <|> firstImportLoc <|> firstDeclLoc - lastPragmaLine = succ <$> annotationsStart (filter (isPragma . unLoc) comments) - firstDocLine = annotationsStart $ reverse $ filter (isHaddock . unLoc) comments - comments = getAnnotationComments (pm_annotations pm) (UnhelpfulSpan "") - annotationsStart = startLine . (getLoc <$>) . listToMaybe - startLine loc = (_line . _start) <$> (loc >>= srcSpanToRange) - mbMin :: (Num a, Ord a) => Maybe a -> Maybe a -> a - mbMin Nothing Nothing = 0 - mbMin (Just n) Nothing = n - mbMin Nothing (Just m) = m - mbMin (Just n) (Just m) = min n m - -isHaddock :: AnnotationComment -> Bool -isHaddock c = case c of - AnnLineComment s -> take 4 s `elem` ["-- |", "-- ^", "-- $", "-- *"] - AnnBlockComment s -> take 3 s == "{-|" - AnnDocCommentNext _ -> True - AnnDocCommentPrev _ -> True - AnnDocCommentNamed _ -> True - AnnDocSection _ _ -> True - _ -> False - -isPragma :: AnnotationComment -> Bool -isPragma (AnnBlockComment ('{':'-':'#':_)) = True -isPragma (AnnDocOptions _) = True -isPragma _ = False + line = maybe 0 succ (lastLineWithPrefix "{-#" <|> lastLineWithPrefix "#!") + lastLineWithPrefix pre = listToMaybe $ reverse $ findIndices (T.isPrefixOf pre) $ T.lines contents diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 98bf30e6ae..1b33a5c571 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -511,14 +511,8 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ contents <- documentContents doc let expected = --- TODO: Why CPP??? -#if __GLASGOW_HASKELL__ < 810 [ "{-# LANGUAGE ScopedTypeVariables #-}" , "{-# LANGUAGE TypeApplications #-}" -#else - [ "{-# LANGUAGE TypeApplications #-}" - , "{-# LANGUAGE ScopedTypeVariables #-}" -#endif , "module TypeApplications where" , "" , "foo :: forall a. a -> a" @@ -571,8 +565,8 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [ let expected = [ "#! /usr/bin/env nix-shell" , "#! nix-shell --pure -i runghc -p \"haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])\"" - , "" , "{-# LANGUAGE NamedFieldPuns #-}" + , "" , "module AfterShebang where" , "" , "data Record = Record" From 2903be8aaa35adfd59879ce84fb228d4ded386af Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Thu, 22 Apr 2021 00:44:25 +0100 Subject: [PATCH 09/10] Update getParsedModule action description --- plugins/default/src/Ide/Plugin/Pragmas.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index 5d425597eb..c252a2bfdb 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -45,7 +45,7 @@ codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction codeActionProvider state _plId (CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly)) = do let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' uri = docId ^. J.uri - pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsed" state $ getParsedModule `traverse` mFile + pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModule" state $ getParsedModule `traverse` mFile mbContents <- liftIO $ fmap join $ fmap (fmap snd) $ runAction "Pragmas.GetFileContents" state $ getFileContents `traverse` mFile let dflags = ms_hspp_opts . pm_mod_summary <$> pm insertRange = maybe (Range (Position 0 0) (Position 0 0)) endOfModuleHeader mbContents From ab7f7b6299feb47f4125a5942e7c532be38a88f4 Mon Sep 17 00:00:00 2001 From: Oliver Madine <30090176+OliverMadine@users.noreply.github.com> Date: Thu, 22 Apr 2021 00:55:45 +0100 Subject: [PATCH 10/10] Code style --- plugins/default/src/Ide/Plugin/Pragmas.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index c252a2bfdb..920e907ae7 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -46,7 +46,7 @@ codeActionProvider state _plId (CodeActionParams _ _ docId _ (J.CodeActionContex let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' uri = docId ^. J.uri pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModule" state $ getParsedModule `traverse` mFile - mbContents <- liftIO $ fmap join $ fmap (fmap snd) $ runAction "Pragmas.GetFileContents" state $ getFileContents `traverse` mFile + mbContents <- liftIO $ fmap (join . fmap snd) $ runAction "Pragmas.GetFileContents" state $ getFileContents `traverse` mFile let dflags = ms_hspp_opts . pm_mod_summary <$> pm insertRange = maybe (Range (Position 0 0) (Position 0 0)) endOfModuleHeader mbContents pedits = nubOrdOn snd . concat $ suggest dflags <$> diags