amend fix for correct placement of file header pragmas (#2078)

Co-authored-by: Pepe Iborra <pepeiborra@gmail.com>

plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs

@@ -190,27 +190,31 @@ completion _ide _ complParams = do
 
 -----------------------------------------------------------------------
 
--- | Find first line after the last LANGUAGE pragma
--- Defaults to line 0 if the file contains no shebang(s), OPTIONS_GHC pragma(s), or other LANGUAGE pragma(s)
--- Otherwise it will be one after the count of line numbers, with order: Shebangs -> OPTIONS_GHC -> LANGUAGE
+-- | Find first line after the last file header pragma
+-- Defaults to line 0 if the file contains no shebang(s), OPTIONS_GHC pragma(s), or LANGUAGE pragma(s)
+-- Otherwise it will be one after the count of line numbers, checking in order: Shebangs -> OPTIONS_GHC -> LANGUAGE
+-- Taking the max of these to account for the possibility of interchanging order of these three Pragma types
 findNextPragmaPosition :: T.Text -> Range
 findNextPragmaPosition contents = Range loc loc
   where
     loc = Position line 0
-    line = afterLangPragma . afterOptsGhc $ afterShebang 0
-    afterLangPragma = afterPragma "LANGUAGE" contents
-    afterOptsGhc = afterPragma "OPTIONS_GHC" contents
-    afterShebang = afterPragma "" contents
+    line = afterLangPragma . afterOptsGhc $ afterShebang
+    afterLangPragma = afterPragma "LANGUAGE" contents'
+    afterOptsGhc = afterPragma "OPTIONS_GHC" contents'
+    afterShebang = lastLineWithPrefix (T.isPrefixOf "#!") contents' 0
+    contents' = T.lines contents
 
-afterPragma :: T.Text -> T.Text -> Int -> Int
-afterPragma name contents lineNum = maybe lineNum succ $ lastLineWithPrefix (checkPragma name) contents
+afterPragma :: T.Text -> [T.Text] -> Int -> Int
+afterPragma name contents lineNum = lastLineWithPrefix (checkPragma name) contents lineNum
+
+lastLineWithPrefix :: (T.Text -> Bool) -> [T.Text] -> Int -> Int
+lastLineWithPrefix p contents lineNum = max lineNum next
   where
-    lastLineWithPrefix p contents = listToMaybe . reverse $ findIndices p $ T.lines contents
+    next = maybe lineNum succ $ listToMaybe . reverse $ findIndices p contents
 
 checkPragma :: T.Text -> T.Text -> Bool
 checkPragma name = check
   where
-    check l = (isPragma l || isShebang l) && getName l == name
+    check l = isPragma l && getName l == name
     getName l = T.take (T.length name) $ T.dropWhile isSpace $ T.drop 3 l
     isPragma = T.isPrefixOf "{-#"
-    isShebang = T.isPrefixOf "#!"

plugins/hls-pragmas-plugin/test/Main.hs

@@ -32,6 +32,66 @@ codeActionTests =
       liftIO $ "Add \"FlexibleInstances\"" `elem` map (^. L.title) cas @? "Contains FlexibleInstances code action"
       executeCodeAction $ head cas
 
+  , goldenWithPragmas "adds LANGUAGE with no other pragmas at start ignoring later INLINE pragma" "AddPragmaIgnoreInline" $ \doc -> do
+      _ <- waitForDiagnosticsFrom doc
+      cas <- map fromAction <$> getAllCodeActions doc
+      liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
+      executeCodeAction $ head cas
+
+  , goldenWithPragmas "adds LANGUAGE after shebang preceded by other LANGUAGE and GHC_OPTIONS" "AddPragmaAfterShebangPrecededByLangAndOptsGhc" $ \doc -> do
+      _ <- waitForDiagnosticsFrom doc
+      cas <- map fromAction <$> getAllCodeActions doc
+      liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
+      executeCodeAction $ head cas
+
+  , goldenWithPragmas "adds LANGUAGE after shebang with other Language preceding shebang" "AddPragmaAfterShebangPrecededByLanguage" $ \doc -> do
+      _ <- waitForDiagnosticsFrom doc
+      cas <- map fromAction <$> getAllCodeActions doc
+      liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
+      executeCodeAction $ head cas
+
+  , goldenWithPragmas "adds LANGUAGE before Doc comments after interchanging pragmas" "BeforeDocInterchanging" $ \doc -> do
+      _ <- waitForDiagnosticsFrom doc
+      cas <- map fromAction <$> getAllCodeActions doc
+      liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action"
+      executeCodeAction $ head cas
+
+  , goldenWithPragmas "Add language after altering OPTIONS_GHC and Language" "AddLanguagePragmaAfterInterchaningOptsGhcAndLangs" $ \doc -> do
+      _ <- waitForDiagnosticsFrom doc
+      cas <- map fromAction <$> getAllCodeActions doc
+      liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
+      executeCodeAction $ head cas
+
+  , goldenWithPragmas "Add language after pragmas with non standard space between prefix and name" "AddPragmaWithNonStandardSpacingInPrecedingPragmas" $ \doc -> do
+      _ <- waitForDiagnosticsFrom doc
+      cas <- map fromAction <$> getAllCodeActions doc
+      liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
+      executeCodeAction $ head cas
+
+   , goldenWithPragmas "adds LANGUAGE after OptGHC at start ignoring later INLINE pragma" "AddPragmaAfterOptsGhcIgnoreInline" $ \doc -> do
+      _ <- waitForDiagnosticsFrom doc
+      cas <- map fromAction <$> getAllCodeActions doc
+      liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
+      executeCodeAction $ head cas
+
+  , goldenWithPragmas "adds LANGUAGE ignore later Ann pragma" "AddPragmaIgnoreLaterAnnPragma" $ \doc -> do
+      _ <- waitForDiagnosticsFrom doc
+      cas <- map fromAction <$> getAllCodeActions doc
+      liftIO $ "Add \"BangPatterns\"" `elem` map (^. L.title) cas @? "Contains BangPatterns code action"
+      executeCodeAction $ head cas
+
+  , goldenWithPragmas "adds LANGUAGE after interchanging pragmas ignoring later Ann pragma" "AddLanguageAfterInterchaningIgnoringLaterAnn" $ \doc -> do
+        _ <- waitForDiagnosticsFrom doc
+        cas <- map fromAction <$> getAllCodeActions doc
+        liftIO $ "Add \"BangPatterns\"" `elem` map (^. L.title) cas @? "Contains BangPatterns code action"
+        executeCodeAction $ head cas
+
+  , goldenWithPragmas "adds LANGUAGE after OptGHC preceded by another language pragma" "AddLanguageAfterLanguageThenOptsGhc" $ \doc -> do
+      _ <- waitForDiagnosticsFrom doc
+      cas <- map fromAction <$> getAllCodeActions doc
+      liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action"
+      executeCodeAction $ head cas
+
   , goldenWithPragmas "adds LANGUAGE pragma after shebang and last language pragma" "AfterShebangAndPragma" $ \doc -> do
       _ <- waitForDiagnosticsFrom doc
       cas <- map fromAction <$> getAllCodeActions doc

plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterInterchaningIgnoringLaterAnn.expected.hs

@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
+{-# 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/AddLanguageAfterInterchaningIgnoringLaterAnn.hs

@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
+
+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/AddLanguageAfterLanguageThenOptsGhc.expected.hs

@@ -0,0 +1,21 @@
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE  OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
+{-# LANGUAGE NamedFieldPuns #-}
+-- | Doc Comment
+{- Block -}
+
+module BeforeDocComment where
+
+test :: Int -> Integer
+test x = x * 2
+
+data Record = Record
+  { a :: Int,
+    b :: Double,
+    c :: String
+  }
+
+f Record{a, b} = a

plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterLanguageThenOptsGhc.hs

@@ -0,0 +1,20 @@
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE  OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
+-- | Doc Comment
+{- Block -}
+
+module BeforeDocComment where
+
+test :: Int -> Integer
+test x = x * 2
+
+data Record = Record
+  { a :: Int,
+    b :: Double,
+    c :: String
+  }
+
+f Record{a, b} = a

plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragmaAfterInterchaningOptsGhcAndLangs.expected.hs

@@ -0,0 +1,21 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
+{-# LANGUAGE TupleSections #-}
+
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+{-# INLINE addOne #-}
+addOne :: Int -> Int 
+addOne x = x + 1
+
+{-# INLINE subOne #-}
+subOne :: Int -> Int
+subOne x = x - 1
+
+tupleSection = (1, ) <$> Just 2

plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragmaAfterInterchaningOptsGhcAndLangs.hs

@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
+
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+{-# INLINE addOne #-}
+addOne :: Int -> Int 
+addOne x = x + 1
+
+{-# INLINE subOne #-}
+subOne :: Int -> Int
+subOne x = x - 1
+
+tupleSection = (1, ) <$> Just 2

plugins/hls-pragmas-plugin/test/testdata/AddOptsGhcAfterLanguage.expected.hs

@@ -0,0 +1,12 @@
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE  OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
+-- | Doc Comment
+{- Block -}
+
+module BeforeDocComment where
+
+test :: Int -> Integer
+test x = x * 2

plugins/hls-pragmas-plugin/test/testdata/AddOptsGhcAfterLanguage.hs

@@ -0,0 +1,11 @@
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE  OverloadedStrings #-}
+-- | Doc Comment
+{- Block -}
+
+module BeforeDocComment where
+
+test :: Int -> Integer
+test x = x * 2

plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterOptsGhcIgnoreInline.expected.hs

@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE TupleSections #-}
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+tupleSection = (1, ) <$> Just 2
+
+{-# INLINE addOne #-}
+addOne :: Int -> Int 
+addOne x = x + 1

plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterOptsGhcIgnoreInline.hs

@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -Wall #-}
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+tupleSection = (1, ) <$> Just 2
+
+{-# INLINE addOne #-}
+addOne :: Int -> Int 
+addOne x = x + 1

plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLangAndOptsGhc.expected.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wall #-}
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+{-# LANGUAGE TupleSections #-}
+
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+tupleSection = (1, ) <$> Just 2

plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLangAndOptsGhc.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wall #-}
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+tupleSection = (1, ) <$> Just 2

plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLanguage.expected.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+{-# LANGUAGE TupleSections #-}
+
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+tupleSection = (1, ) <$> Just 2

plugins/hls-pragmas-plugin/test/testdata/AddPragmaAfterShebangPrecededByLanguage.hs

@@ -0,0 +1,10 @@
+{-# LANGUAGE OverloadedStrings #-}
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+tupleSection = (1, ) <$> Just 2

plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreInline.expected.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE TupleSections #-}
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+tupleSection = (1, ) <$> Just 2
+
+{-# INLINE addOne #-}
+addOne :: Int -> Int 
+addOne x = x + 1

plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreInline.hs

@@ -0,0 +1,10 @@
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+tupleSection = (1, ) <$> Just 2
+
+{-# INLINE addOne #-}
+addOne :: Int -> Int 
+addOne x = x + 1

plugins/hls-pragmas-plugin/test/testdata/AddPragmaIgnoreLaterAnnPragma.expected.hs

@@ -0,0 +1,12 @@
+{-# 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/AddPragmaIgnoreLaterAnnPragma.hs

@@ -0,0 +1,11 @@
+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/AddPragmaWithNonStandardSpacingInPrecedingPragmas.expected.hs

@@ -0,0 +1,6 @@
+{-#   OPTIONS_GHC -Wall #-}
+{-#       LANGUAGE  OverloadedStrings #-}
+{-#      OPTIONS_GHC -Wno-deferred-type-errors #-}
+{-# LANGUAGE TupleSections #-}
+
+tupleSection = (1, ) <$> Just 2

plugins/hls-pragmas-plugin/test/testdata/AddPragmaWithNonStandardSpacingInPrecedingPragmas.hs

@@ -0,0 +1,5 @@
+{-#   OPTIONS_GHC -Wall #-}
+{-#       LANGUAGE  OverloadedStrings #-}
+{-#      OPTIONS_GHC -Wno-deferred-type-errors #-}
+
+tupleSection = (1, ) <$> Just 2

plugins/hls-pragmas-plugin/test/testdata/BeforeDocInterchanging.expected.hs

@@ -0,0 +1,18 @@
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
+{-# LANGUAGE NamedFieldPuns #-}
+-- | Doc Comment
+{- Block -}
+
+module BeforeDocComment where
+
+data Record = Record
+  { a :: Int,
+    b :: Double,
+    c :: String
+  }
+
+f Record{a, b} = a

plugins/hls-pragmas-plugin/test/testdata/BeforeDocInterchanging.hs

@@ -0,0 +1,17 @@
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
+-- | Doc Comment
+{- Block -}
+
+module BeforeDocComment where
+
+data Record = Record
+  { a :: Int,
+    b :: Double,
+    c :: String
+  }
+
+f Record{a, b} = a