Add fix for placement after multiline pragma

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

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")]

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

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

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

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

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 !_ !_ !_ !_)) = ()

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 !_ !_ !_ !_)) = ()