Insert pragmas after shebang or to existing pragma list

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,21 @@ 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
-      modNameLoc = getLoc <$> hsmodName mod
-      firstImportLoc = getLoc <$> listToMaybe (hsmodImports mod)
-      firstDeclLoc = getLoc <$> listToMaybe (hsmodDecls mod)
-      line = maybe 0 (_line . _start) (modNameLoc <|> firstImportLoc <|> firstDeclLoc >>= srcSpanToRange)
-      loc = Position line 0
-   in Range loc loc
+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 "<no location info>"))
+        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

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"

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