Fix extension pragma inserted below ghc options pragma haskell#2364 (haskell#2392)

* new parser for stuff before first declaration

* remove unused pragmas, modify haddock comment on parser

* working but need to clean lots of little things and add more tests

* uncomment completions functions and tests (was trying to see why the test timeout), merge textedits to get around lsp-test applying text edits in reverse order, inserting pragma between lines fixes, some tests

* add line splitting tests, fix line splitting errors and among other things, add docs

* change comments, add cpp for setting use_pos_prags bit in PState

* add safeImportsOn to compat, fix ghc versions

* fix compat

* fix compat

* fix compat 3

* fix compat 4

* fix compat 5

* fix test

* fix compat 6

* add back some tests and investigate haskell#2375 later

Co-authored-by: Javier Neira <[email protected]>

Author: 2 people

ghcide/src/Development/IDE/GHC/Compat/Env.hs

@@ -32,6 +32,7 @@ module Development.IDE.GHC.Compat.Env (
     -- * DynFlags Helper
     setBytecodeLinkerOptions,
     setInterpreterLinkerOptions,
+    Development.IDE.GHC.Compat.Env.safeImportsOn,
     -- * Ways
     Ways,
     Way,
@@ -178,6 +179,13 @@ homeUnitId_ =
   thisPackage
 #endif
 
+safeImportsOn :: DynFlags -> Bool
+safeImportsOn =
+#if MIN_VERSION_ghc(9,2,0)
+  Session.safeImportsOn
+#else
+  DynFlags.safeImportsOn
+#endif
 
 #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)
 type HomeUnit = Unit

ghcide/src/Development/IDE/GHC/Compat/Parser.hs

@@ -13,6 +13,9 @@ module Development.IDE.GHC.Compat.Parser (
     Anno.ApiAnns(..),
 #else
     ApiAnns,
+#endif
+#if MIN_VERSION_ghc(9,0,0)
+    PsSpan(..),
 #endif
     mkHsParsedModule,
     mkParsedModule,
@@ -24,6 +27,7 @@ module Development.IDE.GHC.Compat.Parser (
 
 #if MIN_VERSION_ghc(9,0,0)
 import qualified GHC.Parser.Lexer                as Lexer
+import           GHC.Types.SrcLoc                (PsSpan (..))
 #if MIN_VERSION_ghc(9,2,0)
 import qualified GHC.Driver.Config               as Config
 import           GHC.Parser.Lexer                hiding (initParserState)

ghcide/src/Development/IDE/GHC/Compat/Util.hs

@@ -67,6 +67,8 @@ module Development.IDE.GHC.Compat.Util (
     StringBuffer(..),
     hGetStringBuffer,
     stringToStringBuffer,
+    nextChar,
+    atEnd
     ) where
 
 #if MIN_VERSION_ghc(9,0,0)

plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal

@@ -24,13 +24,15 @@ library
     , base                  >=4.12 && <5
     , extra
     , fuzzy
+    , ghc
     , ghcide                >=1.2  && <1.6
     , hls-plugin-api        >=1.1  && <1.3
     , lens
     , lsp
     , text
     , transformers
     , unordered-containers
+    , containers
 
   default-language: Haskell2010
 

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

@@ -27,9 +27,24 @@ 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 "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 "Block comment then line comment doesn't split line" "BlockCommentThenLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  , codeActionTest "Block comment then single-line block comment doesn't split line" "BlockCommentThenSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  , codeActionTest "Block comment then multi-line block comment doesn't split line" "BlockCommentThenMultiLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  , codeActionTest "Block comment then line haddock splits line" "BlockCommentThenLineHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  ,  codeActionTest "Block comment then single-line block haddock splits line" "BlockCommentThenSingleLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  ,  codeActionTest "Block comment then multi-line block haddock splits line" "BlockCommentThenMultiLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  ,  codeActionTest "Pragma then line comment doesn't split line" "PragmaThenLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  , codeActionTest "Pragma then single-line block comment doesn't split line" "PragmaThenSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  , codeActionTest "Pragma then multi-line block comment splits line" "PragmaThenMultiLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  , codeActionTest "Pragma then line haddock splits line" "PragmaThenLineHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  , codeActionTest "Pragma then single-line block haddock splits line" "PragmaThenSingleLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  , codeActionTest "Pragma then multi-line block haddock splits line" "PragmaThenMultiLineBlockHaddock" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  , codeActionTest "Pragma then single-line block haddock single-line block comment splits line" "PragmaThenSingleLineBlockHaddockSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  , codeActionTest "Block comment then single-line block haddock single-line block comment splits line" "BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  , codeActionTest "Pragma then line haddock then newline line comment splits line" "PragmaThenLineHaddockNewlineLineComment" [("Add \"TupleSections\"", "Contains TupleSections code action")]
+  , codeActionTest "does not add pragma after OPTIONS_GHC pragma located after a declaration" "OptionsGhcAfterDecl" [("Add \"TupleSections\"", "Contains TupleSections 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 before Doc comments after interchanging pragmas" "BeforeDocInterchanging" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")]
   , codeActionTest "Add language after altering OPTIONS_GHC and Language" "AddLanguagePragmaAfterInterchaningOptsGhcAndLangs" [("Add \"TupleSections\"", "Contains TupleSections code action")]
   , codeActionTest "Add language after pragmas with non standard space between prefix and name" "AddPragmaWithNonStandardSpacingInPrecedingPragmas" [("Add \"TupleSections\"", "Contains TupleSections code action")]
@@ -67,7 +82,8 @@ codeActionTest testComment fp actions =
 codeActionTests' :: TestTree
 codeActionTests' =
   testGroup "additional code actions"
-  [ goldenWithPragmas "no duplication" "NamedFieldPuns" $ \doc -> do
+  [
+    goldenWithPragmas "no duplication" "NamedFieldPuns" $ \doc -> do
       _ <- waitForDiagnosticsFrom doc
       cas <- map fromAction <$> getCodeActions doc (Range (Position 8 9) (Position 8 9))
       liftIO $ length cas == 1 @? "Expected one code action, but got: " <> show cas

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

@@ -0,0 +1,6 @@
+{- block comment -} -- line comment
+{-# LANGUAGE TupleSections #-}
+
+module BlockCommentThenLineComment where
+
+a = (1,)

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

@@ -0,0 +1,5 @@
+{- block comment -} -- line comment
+
+module BlockCommentThenLineComment where
+
+a = (1,)

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

@@ -0,0 +1,7 @@
+{- block comment -} 
+{-# LANGUAGE TupleSections #-}
+-- | line haddock
+
+module BlockCommentThenLineHaddock where
+
+a = (1,)

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

@@ -0,0 +1,5 @@
+{- block comment -} -- | line haddock
+
+module BlockCommentThenLineHaddock where
+
+a = (1,)

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

@@ -0,0 +1,10 @@
+{- block comment -} {- multi
+line
+block
+comment
+-}
+{-# LANGUAGE TupleSections #-}
+
+module BlockCommentThenMultiLineBlockComment where
+
+a = (1,)

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

@@ -0,0 +1,9 @@
+{- block comment -} {- multi
+line
+block
+comment
+-}
+
+module BlockCommentThenMultiLineBlockComment where
+
+a = (1,)

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

@@ -0,0 +1,13 @@
+{- block comment -} 
+{-# LANGUAGE TupleSections #-}
+{-| multi
+line
+block
+haddock
+-}
+
+module BlockCommentThenMultiLineBlockHaddock where
+import GHC.SourceGen (multiIf)
+import Diagrams (block)
+
+a = (1,)

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

@@ -0,0 +1,11 @@
+{- block comment -} {-| multi
+line
+block
+haddock
+-}
+
+module BlockCommentThenMultiLineBlockHaddock where
+import GHC.SourceGen (multiIf)
+import Diagrams (block)
+
+a = (1,)

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

@@ -0,0 +1,6 @@
+{- block comment -} {- single line block comment -}
+{-# LANGUAGE TupleSections #-}
+
+module BlockCommentThenSingleLineBlockComment where
+
+a = (1,)

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

@@ -0,0 +1,5 @@
+{- block comment -} {- single line block comment -}
+
+module BlockCommentThenSingleLineBlockComment where
+
+a = (1,)

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

@@ -0,0 +1,7 @@
+{- block comment -} 
+{-# LANGUAGE TupleSections #-}
+{-| single line block haddock -}
+
+module BlockCommentThenSingleLineBlockHaddock where
+
+a = (1,)

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

@@ -0,0 +1,5 @@
+{- block comment -} {-| single line block haddock -}
+
+module BlockCommentThenSingleLineBlockHaddock where
+
+a = (1,)

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

@@ -0,0 +1,7 @@
+{- block comment -} 
+{-# LANGUAGE TupleSections #-}
+{-| single line block haddock -} {- single line block comment -}
+
+module BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment where
+
+a = (1,)

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

@@ -0,0 +1,5 @@
+{- block comment -} {-| single line block haddock -} {- single line block comment -}
+
+module BlockCommentThenSingleLineBlockHaddockSingleLineBlockComment where
+
+a = (1,)

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

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

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

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

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

@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeApplications #-} {-| haddock -}
+
+module PragmaFollowedByBlockHaddock where
+
+a = (1,)

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

@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeApplications #-} -- line comment
+{-# LANGUAGE TupleSections #-}
+
+module PragmaThenLineComment where
+
+a = (1,)

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

@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeApplications #-} -- line comment
+
+module PragmaThenLineComment where
+
+a = (1,)

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

@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeApplications #-} 
+{-# LANGUAGE TupleSections #-}
+-- | line haddock
+
+module PragmaThenLineHaddock where
+
+a = (1,)

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

@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeApplications #-} -- | line haddock
+
+module PragmaThenLineHaddock where
+
+a = (1,)

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

@@ -0,0 +1,8 @@
+{-# LANGUAGE TypeApplications #-} 
+{-# LANGUAGE TupleSections #-}
+-- | line haddock
+-- line comment
+
+module PragmaThenLineHaddockNewlineLineComment where
+
+a = (1,)

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

@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeApplications #-} -- | line haddock
+-- line comment
+
+module PragmaThenLineHaddockNewlineLineComment where
+
+a = (1,)

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

@@ -0,0 +1,11 @@
+{-# LANGUAGE TypeApplications #-} 
+{-# LANGUAGE TupleSections #-}
+{- multi
+line
+block
+comment
+-}
+
+module PragmaThenSingleLineBlockComment where
+
+a = (1,)

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

@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeApplications #-} {- multi
+line
+block
+comment
+-}
+
+module PragmaThenSingleLineBlockComment where
+
+a = (1,)

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

@@ -0,0 +1,11 @@
+{-# LANGUAGE TypeApplications #-} 
+{-# LANGUAGE TupleSections #-}
+{-| multi
+line
+block
+haddock
+-}
+
+module PragmaThenMultiLineBlockHaddock where
+
+a = (1,)

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

@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeApplications #-} {-| multi
+line
+block
+haddock
+-}
+
+module PragmaThenMultiLineBlockHaddock where
+
+a = (1,)

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

@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeApplications #-} {- single line block comment -}
+{-# LANGUAGE TupleSections #-}
+
+module PragmaThenSingleLineBlockComment where
+
+a = (1,)

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

@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeApplications #-} {- single line block comment -}
+
+module PragmaThenSingleLineBlockComment where
+
+a = (1,)

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

@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeApplications #-} 
+{-# LANGUAGE TupleSections #-}
+{-| single line block haddock -}
+
+module PragmaThenSingleLineBlockHaddock where
+
+a = (1,)

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

@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeApplications #-} {-| single line block haddock -}
+
+module PragmaThenSingleLineBlockHaddock where
+
+a = (1,)

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

@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeApplications #-} 
+{-# LANGUAGE TupleSections #-}
+{-| single line block haddock -} {- single line block comment -}
+
+module PragmaThenSingleLineBlockHaddockSingleLineBlockComment where
+
+a = (1,)

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

@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeApplications #-} {-| single line block haddock -} {- single line block comment -}
+
+module PragmaThenSingleLineBlockHaddockSingleLineBlockComment where
+
+a = (1,)