diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index af01fea2d6..da79090061 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -12,7 +12,7 @@ module Ide.Plugin.Pragmas import Control.Applicative ((<|>)) import Control.Lens hiding (List) -import Control.Monad (join) +import Control.Monad (foldM, join) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Char (isSpace) import qualified Data.HashMap.Strict as H @@ -217,7 +217,7 @@ validPragmas mSuffix = ] where suffix = case mSuffix of (Just s) -> s - Nothing -> "" + Nothing -> "" mkPragmaCompl :: T.Text -> T.Text -> T.Text -> J.CompletionItem @@ -241,12 +241,32 @@ findNextPragmaPosition contents = Range loc loc contents' = T.lines contents afterPragma :: T.Text -> [T.Text] -> Int -> Int -afterPragma name contents lineNum = lastLineWithPrefix (checkPragma name) contents lineNum +afterPragma name = lastLineWithPrefixMulti (checkPragma name) lastLineWithPrefix :: (T.Text -> Bool) -> [T.Text] -> Int -> Int lastLineWithPrefix p contents lineNum = max lineNum next where - next = maybe lineNum succ $ listToMaybe . reverse $ findIndices p contents + next = maybe lineNum succ $ listToMaybe $ reverse $ findIndices p contents + +-- | Accounts for the case where the LANGUAGE or OPTIONS_GHC +-- pragma spans multiple lines or just a single line pragma. +lastLineWithPrefixMulti :: (T.Text -> Bool) -> [T.Text] -> Int -> Int +lastLineWithPrefixMulti p contents lineNum = max lineNum next + where + mIndex = listToMaybe . reverse $ findIndices p contents + next = case mIndex of + Nothing -> 0 + Just index -> getEndOfPragmaBlock index $ drop index contents + +getEndOfPragmaBlock :: Int -> [T.Text] -> Int +getEndOfPragmaBlock start contents = lineNumber + where + lineNumber = either id id lineNum + lineNum = foldM go start contents + go pos txt + | endOfBlock txt = Left $ pos + 1 + | otherwise = Right $ pos + 1 + endOfBlock txt = T.dropWhile (/= '}') (T.dropWhile (/= '-') txt) == "}" checkPragma :: T.Text -> T.Text -> Bool checkPragma name = check @@ -255,14 +275,12 @@ checkPragma name = check getName l = T.take (T.length name) $ T.dropWhile isSpace $ T.drop 3 l isPragma = T.isPrefixOf "{-#" - stripLeading :: Char -> String -> String stripLeading _ [] = [] stripLeading c (s:ss) | s == c = ss | otherwise = s:ss - mkExtCompl :: T.Text -> J.CompletionItem mkExtCompl label = J.CompletionItem label (Just J.CiKeyword) Nothing Nothing diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs index ee62d80417..3605922cad 100644 --- a/plugins/hls-pragmas-plugin/test/Main.hs +++ b/plugins/hls-pragmas-plugin/test/Main.hs @@ -27,7 +27,10 @@ tests = codeActionTests :: TestTree codeActionTests = testGroup "code actions" - [ codeActionTest "adds LANGUAGE with no other pragmas at start ignoring later INLINE pragma" "AddPragmaIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")] + [ codeActionTest "add pragma after mix of multi line lang and opts pragmas" "MultiLangOptsMix" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTest "add LANGUAGE pragma after multi line options_ghc" "AfterMultiOptionsPragma" [("Add \"TupleSections\"", "Contains TupleSections code action")] + , codeActionTest "add LANGUAGE pragma after multi line lang pragma" "PragmaAfterMultilinePragma" [("Add \"BangPatterns\"", "Contains BangPatterns code action")] + , codeActionTest "adds LANGUAGE with no other pragmas at start ignoring later INLINE pragma" "AddPragmaIgnoreInline" [("Add \"TupleSections\"", "Contains TupleSections code action")] , codeActionTest "adds LANGUAGE after shebang preceded by other LANGUAGE and GHC_OPTIONS" "AddPragmaAfterShebangPrecededByLangAndOptsGhc" [("Add \"TupleSections\"", "Contains TupleSections code action")] , codeActionTest "adds LANGUAGE after shebang with other Language preceding shebang" "AddPragmaAfterShebangPrecededByLangAndOptsGhc" [("Add \"TupleSections\"", "Contains TupleSections code action")] , codeActionTest "adds LANGUAGE before Doc comments after interchanging pragmas" "BeforeDocInterchanging" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterMultiOptionsPragma.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterMultiOptionsPragma.expected.hs new file mode 100644 index 0000000000..d3bb2e3ca1 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterMultiOptionsPragma.expected.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall +, -Wno-unused-imports, + -freverse-errors #-} +{-# LANGUAGE TupleSections #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 + +{-# INLINE subOne #-} +subOne :: Int -> Int +subOne x = x - 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterMultiOptionsPragma.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterMultiOptionsPragma.hs new file mode 100644 index 0000000000..878b3f397d --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/AfterMultiOptionsPragma.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall +, -Wno-unused-imports, + -freverse-errors #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 + +{-# INLINE subOne #-} +subOne :: Int -> Int +subOne x = x - 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/MultiLangOptsMix.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/MultiLangOptsMix.expected.hs new file mode 100644 index 0000000000..914ff18f56 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/MultiLangOptsMix.expected.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -Wall +, -Wno-unused-imports, + -freverse-errors #-} +{-# LANGUAGE RecordWildCards, + OverloadedStrings, + BangPatterns #-} +{-# OPTIONS_GHC + -freverse-errors + #-} +{-# LANGUAGE TupleSections #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 + +{-# INLINE subOne #-} +subOne :: Int -> Int +subOne x = x - 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/MultiLangOptsMix.hs b/plugins/hls-pragmas-plugin/test/testdata/MultiLangOptsMix.hs new file mode 100644 index 0000000000..0a4885fefb --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/MultiLangOptsMix.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -Wall +, -Wno-unused-imports, + -freverse-errors #-} +{-# LANGUAGE RecordWildCards, + OverloadedStrings, + BangPatterns #-} +{-# OPTIONS_GHC + -freverse-errors + #-} + +data Something = Something { + foo :: !String, + bar :: !Int +} + +tupleSection = (1, ) <$> Just 2 + +{-# INLINE addOne #-} +addOne :: Int -> Int +addOne x = x + 1 + +{-# INLINE subOne #-} +subOne :: Int -> Int +subOne x = x - 1 diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaAfterMultilinePragma.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaAfterMultilinePragma.expected.hs new file mode 100644 index 0000000000..902a761bb3 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaAfterMultilinePragma.expected.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE RecordWildCards, + OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +data Metaprogram = Metaprogram + { mp_name :: !Text + , mp_known_by_auto :: !Bool + , mp_show_code_action :: !Bool + , mp_program :: !(TacticsM ()) + } + deriving stock Generic +{-# ANN Metaprogram "hello" #-} + +instance NFData Metaprogram where + rnf (!(Metaprogram !_ !_ !_ !_)) = () diff --git a/plugins/hls-pragmas-plugin/test/testdata/PragmaAfterMultilinePragma.hs b/plugins/hls-pragmas-plugin/test/testdata/PragmaAfterMultilinePragma.hs new file mode 100644 index 0000000000..3247aedf61 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/PragmaAfterMultilinePragma.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE RecordWildCards, + OverloadedStrings #-} + +data Metaprogram = Metaprogram + { mp_name :: !Text + , mp_known_by_auto :: !Bool + , mp_show_code_action :: !Bool + , mp_program :: !(TacticsM ()) + } + deriving stock Generic +{-# ANN Metaprogram "hello" #-} + +instance NFData Metaprogram where + rnf (!(Metaprogram !_ !_ !_ !_)) = ()