[#1958] Fix placement of language pragmas

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

@@ -14,6 +14,7 @@ import           Control.Applicative        ((<|>))
 import           Control.Lens               hiding (List)
 import           Control.Monad              (join)
 import           Control.Monad.IO.Class     (MonadIO (liftIO))
+import           Data.Char                  (isSpace)
 import qualified Data.HashMap.Strict        as H
 import           Data.List
 import           Data.List.Extra            (nubOrdOn)
@@ -51,7 +52,7 @@ codeActionProvider state _plId (J.CodeActionParams _ _ docId _ (J.CodeActionCont
   pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModule" state $ getParsedModule `traverse` mFile
   mbContents <- liftIO $ fmap (snd =<<) $ runAction "Pragmas.GetFileContents" state $ getFileContents `traverse` mFile
   let dflags = ms_hspp_opts . pm_mod_summary <$> pm
-      insertRange = maybe (Range (Position 0 0) (Position 0 0)) endOfModuleHeader mbContents
+      insertRange = maybe (Range (Position 0 0) (Position 0 0)) findNextPragmaPosition mbContents
       pedits = nubOrdOn snd . concat $ suggest dflags <$> diags
   return $ Right $ List $ pragmaEditToAction uri insertRange <$> pedits
 
@@ -181,13 +182,29 @@ completion _ide _ complParams = do
                       }
         _ -> return $ J.List []
 
--- ---------------------------------------------------------------------
+-----------------------------------------------------------------------
 
--- | Find first line after (last pragma / last shebang / beginning of file).
--- Useful for inserting pragmas.
-endOfModuleHeader :: T.Text -> Range
-endOfModuleHeader contents = Range loc loc
-    where
-        loc = Position line 0
-        line = maybe 0 succ (lastLineWithPrefix "{-#" <|> lastLineWithPrefix "#!")
-        lastLineWithPrefix pre = listToMaybe $ reverse $ findIndices (T.isPrefixOf pre) $ T.lines contents
+-- | 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
+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
+
+afterPragma :: T.Text -> T.Text -> Int -> Int
+afterPragma name contents lineNum = maybe lineNum succ $ lastLineWithPrefix (checkPragma name) contents
+  where
+    lastLineWithPrefix p contents = listToMaybe . reverse $ findIndices p $ T.lines contents
+
+checkPragma :: T.Text -> T.Text -> Bool
+checkPragma name = check
+  where
+    check l = (isPragma l || isShebang 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,54 @@ codeActionTests =
       liftIO $ "Add \"FlexibleInstances\"" `elem` map (^. L.title) cas @? "Contains FlexibleInstances 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
+      liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action"
+      executeCodeAction $ head cas
+
+  , goldenWithPragmas "adds above module keyword on first line" "ModuleOnFirstLine" $ \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 pragma after GHC_OPTIONS" "AfterGhcOptions" $ \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 pragma after shebang and GHC_OPTIONS" "AfterShebangAndOpts" $ \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 pragma after shebang, GHC_OPTIONS and language pragma" "AfterShebangAndOptionsAndPragma" $ \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 pragma after all others ignoring later INLINE pragma" "AfterShebangAndOptionsAndPragmasIgnoreInline" $ \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 pragma after all others ignoring multiple later INLINE pragma" "AfterAllWithMultipleInlines" $ \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 pragma correctly ignoring later INLINE pragma" "AddLanguagePragma" $ \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 TypeApplications pragma" "TypeApplications" $ \doc -> do
       _ <- waitForDiagnosticsFrom doc
       cas <- map fromAction <$> getAllCodeActions doc

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

@@ -0,0 +1,10 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module NeedsLanguagePragma where
+
+tupleSection = (1,) <$> Just 2
+
+{-# INLINE addOne #-}
+addOne :: Int -> Int
+addOne x = x + 1

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

@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module NeedsLanguagePragma where
+
+tupleSection = (1,) <$> Just 2
+
+{-# INLINE addOne #-}
+addOne :: Int -> Int
+addOne x = x + 1

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

@@ -0,0 +1,22 @@
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# 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/AfterAllWithMultipleInlines.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 #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+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/AfterGhcOptions.expected.hs

@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# 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/AfterGhcOptions.hs

@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+
+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/AfterShebangAndOptionsAndPragma.expected.hs

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

plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.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 #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+tupleSection = (1, ) <$> Just 2

plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.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 #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# 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/AfterShebangAndOptionsAndPragmasIgnoreInline.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 #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+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/AfterShebangAndOpts.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 #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# LANGUAGE TupleSections #-}
+
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+tupleSection = (1, ) <$> Just 2

plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.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 #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+
+data Something = Something {
+    foo :: !String,
+    bar :: !Int
+}
+
+tupleSection = (1, ) <$> Just 2

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

@@ -0,0 +1,16 @@
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+{-# LANGUAGE  OverloadedStrings #-}
+{-# 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/AfterShebangAndPragma.hs

@@ -0,0 +1,15 @@
+#! /usr/bin/env nix-shell
+#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
+{-# LANGUAGE  OverloadedStrings #-}
+-- | 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/ModuleOnFirstLine.expected.hs

@@ -0,0 +1,4 @@
+{-# LANGUAGE TupleSections #-}
+module Main where
+
+tupleSection = (1,) <$> Just 2

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

@@ -0,0 +1,3 @@
+module Main where
+
+tupleSection = (1,) <$> Just 2