Skip to content

Commit ced934e

Browse files
nini-farouxpepeiborra
nini-faroux
and
pepeiborra
authored
Add fix for placing suggested new pragma in the correct position, tests (#2043)
included Co-authored-by: Pepe Iborra <pepeiborra@gmail.com>
1 parent e7c5e90 commit ced934e

18 files changed

+293
-10
lines changed

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

+27-10
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ import Control.Applicative ((<|>))
1414
import Control.Lens hiding (List)
1515
import Control.Monad (join)
1616
import Control.Monad.IO.Class (MonadIO (liftIO))
17+
import Data.Char (isSpace)
1718
import qualified Data.HashMap.Strict as H
1819
import Data.List
1920
import Data.List.Extra (nubOrdOn)
@@ -51,7 +52,7 @@ codeActionProvider state _plId (J.CodeActionParams _ _ docId _ (J.CodeActionCont
5152
pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModule" state $ getParsedModule `traverse` mFile
5253
mbContents <- liftIO $ fmap (snd =<<) $ runAction "Pragmas.GetFileContents" state $ getFileContents `traverse` mFile
5354
let dflags = ms_hspp_opts . pm_mod_summary <$> pm
54-
insertRange = maybe (Range (Position 0 0) (Position 0 0)) endOfModuleHeader mbContents
55+
insertRange = maybe (Range (Position 0 0) (Position 0 0)) findNextPragmaPosition mbContents
5556
pedits = nubOrdOn snd . concat $ suggest dflags <$> diags
5657
return $ Right $ List $ pragmaEditToAction uri insertRange <$> pedits
5758

@@ -181,13 +182,29 @@ completion _ide _ complParams = do
181182
}
182183
_ -> return $ J.List []
183184

184-
-- ---------------------------------------------------------------------
185+
-----------------------------------------------------------------------
185186

186-
-- | Find first line after (last pragma / last shebang / beginning of file).
187-
-- Useful for inserting pragmas.
188-
endOfModuleHeader :: T.Text -> Range
189-
endOfModuleHeader contents = Range loc loc
190-
where
191-
loc = Position line 0
192-
line = maybe 0 succ (lastLineWithPrefix "{-#" <|> lastLineWithPrefix "#!")
193-
lastLineWithPrefix pre = listToMaybe $ reverse $ findIndices (T.isPrefixOf pre) $ T.lines contents
187+
-- | Find first line after the last LANGUAGE pragma
188+
-- Defaults to line 0 if the file contains no shebang(s), OPTIONS_GHC pragma(s), or other LANGUAGE pragma(s)
189+
-- Otherwise it will be one after the count of line numbers, with order: Shebangs -> OPTIONS_GHC -> LANGUAGE
190+
findNextPragmaPosition :: T.Text -> Range
191+
findNextPragmaPosition contents = Range loc loc
192+
where
193+
loc = Position line 0
194+
line = afterLangPragma . afterOptsGhc $ afterShebang 0
195+
afterLangPragma = afterPragma "LANGUAGE" contents
196+
afterOptsGhc = afterPragma "OPTIONS_GHC" contents
197+
afterShebang = afterPragma "" contents
198+
199+
afterPragma :: T.Text -> T.Text -> Int -> Int
200+
afterPragma name contents lineNum = maybe lineNum succ $ lastLineWithPrefix (checkPragma name) contents
201+
where
202+
lastLineWithPrefix p contents = listToMaybe . reverse $ findIndices p $ T.lines contents
203+
204+
checkPragma :: T.Text -> T.Text -> Bool
205+
checkPragma name = check
206+
where
207+
check l = (isPragma l || isShebang l) && getName l == name
208+
getName l = T.take (T.length name) $ T.dropWhile isSpace $ T.drop 3 l
209+
isPragma = T.isPrefixOf "{-#"
210+
isShebang = T.isPrefixOf "#!"

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

+48
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,54 @@ codeActionTests =
3232
liftIO $ "Add \"FlexibleInstances\"" `elem` map (^. L.title) cas @? "Contains FlexibleInstances code action"
3333
executeCodeAction $ head cas
3434

35+
, goldenWithPragmas "adds LANGUAGE pragma after shebang and last language pragma" "AfterShebangAndPragma" $ \doc -> do
36+
_ <- waitForDiagnosticsFrom doc
37+
cas <- map fromAction <$> getAllCodeActions doc
38+
liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action"
39+
executeCodeAction $ head cas
40+
41+
, goldenWithPragmas "adds above module keyword on first line" "ModuleOnFirstLine" $ \doc -> do
42+
_ <- waitForDiagnosticsFrom doc
43+
cas <- map fromAction <$> getAllCodeActions doc
44+
liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
45+
executeCodeAction $ head cas
46+
47+
, goldenWithPragmas "adds LANGUAGE pragma after GHC_OPTIONS" "AfterGhcOptions" $ \doc -> do
48+
_ <- waitForDiagnosticsFrom doc
49+
cas <- map fromAction <$> getAllCodeActions doc
50+
liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
51+
executeCodeAction $ head cas
52+
53+
, goldenWithPragmas "adds LANGUAGE pragma after shebang and GHC_OPTIONS" "AfterShebangAndOpts" $ \doc -> do
54+
_ <- waitForDiagnosticsFrom doc
55+
cas <- map fromAction <$> getAllCodeActions doc
56+
liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
57+
executeCodeAction $ head cas
58+
59+
, goldenWithPragmas "adds LANGUAGE pragma after shebang, GHC_OPTIONS and language pragma" "AfterShebangAndOptionsAndPragma" $ \doc -> do
60+
_ <- waitForDiagnosticsFrom doc
61+
cas <- map fromAction <$> getAllCodeActions doc
62+
liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
63+
executeCodeAction $ head cas
64+
65+
, goldenWithPragmas "adds LANGUAGE pragma after all others ignoring later INLINE pragma" "AfterShebangAndOptionsAndPragmasIgnoreInline" $ \doc -> do
66+
_ <- waitForDiagnosticsFrom doc
67+
cas <- map fromAction <$> getAllCodeActions doc
68+
liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
69+
executeCodeAction $ head cas
70+
71+
, goldenWithPragmas "adds LANGUAGE pragma after all others ignoring multiple later INLINE pragma" "AfterAllWithMultipleInlines" $ \doc -> do
72+
_ <- waitForDiagnosticsFrom doc
73+
cas <- map fromAction <$> getAllCodeActions doc
74+
liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
75+
executeCodeAction $ head cas
76+
77+
, goldenWithPragmas "adds LANGUAGE pragma correctly ignoring later INLINE pragma" "AddLanguagePragma" $ \doc -> do
78+
_ <- waitForDiagnosticsFrom doc
79+
cas <- map fromAction <$> getAllCodeActions doc
80+
liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
81+
executeCodeAction $ head cas
82+
3583
, goldenWithPragmas "adds TypeApplications pragma" "TypeApplications" $ \doc -> do
3684
_ <- waitForDiagnosticsFrom doc
3785
cas <- map fromAction <$> getAllCodeActions doc

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

+10
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE TupleSections #-}
3+
4+
module NeedsLanguagePragma where
5+
6+
tupleSection = (1,) <$> Just 2
7+
8+
{-# INLINE addOne #-}
9+
addOne :: Int -> Int
10+
addOne x = x + 1

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

+9
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
3+
module NeedsLanguagePragma where
4+
5+
tupleSection = (1,) <$> Just 2
6+
7+
{-# INLINE addOne #-}
8+
addOne :: Int -> Int
9+
addOne x = x + 1

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

+22
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
#! /usr/bin/env nix-shell
2+
#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
3+
{-# OPTIONS_GHC -Wall #-}
4+
{-# OPTIONS_GHC -Wno-unused-imports #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE RecordWildCards #-}
7+
{-# LANGUAGE TupleSections #-}
8+
9+
data Something = Something {
10+
foo :: !String,
11+
bar :: !Int
12+
}
13+
14+
tupleSection = (1, ) <$> Just 2
15+
16+
{-# INLINE addOne #-}
17+
addOne :: Int -> Int
18+
addOne x = x + 1
19+
20+
{-# INLINE subOne #-}
21+
subOne :: Int -> Int
22+
subOne x = x - 1

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

+21
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,21 @@
1+
#! /usr/bin/env nix-shell
2+
#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
3+
{-# OPTIONS_GHC -Wall #-}
4+
{-# OPTIONS_GHC -Wno-unused-imports #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE RecordWildCards #-}
7+
8+
data Something = Something {
9+
foo :: !String,
10+
bar :: !Int
11+
}
12+
13+
tupleSection = (1, ) <$> Just 2
14+
15+
{-# INLINE addOne #-}
16+
addOne :: Int -> Int
17+
addOne x = x + 1
18+
19+
{-# INLINE subOne #-}
20+
subOne :: Int -> Int
21+
subOne x = x - 1

‎plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.expected.hs

+18
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
{-# OPTIONS_GHC -Wall #-}
2+
{-# OPTIONS_GHC -Wno-unused-imports #-}
3+
{-# LANGUAGE TupleSections #-}
4+
5+
data Something = Something {
6+
foo :: !String,
7+
bar :: !Int
8+
}
9+
10+
tupleSection = (1, ) <$> Just 2
11+
12+
{-# INLINE addOne #-}
13+
addOne :: Int -> Int
14+
addOne x = x + 1
15+
16+
{-# INLINE subOne #-}
17+
subOne :: Int -> Int
18+
subOne x = x - 1

‎plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.hs

+17
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
{-# OPTIONS_GHC -Wall #-}
2+
{-# OPTIONS_GHC -Wno-unused-imports #-}
3+
4+
data Something = Something {
5+
foo :: !String,
6+
bar :: !Int
7+
}
8+
9+
tupleSection = (1, ) <$> Just 2
10+
11+
{-# INLINE addOne #-}
12+
addOne :: Int -> Int
13+
addOne x = x + 1
14+
15+
{-# INLINE subOne #-}
16+
subOne :: Int -> Int
17+
subOne x = x - 1

‎plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.expected.hs

+13
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
#! /usr/bin/env nix-shell
2+
#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
3+
{-# OPTIONS_GHC -Wall #-}
4+
{-# OPTIONS_GHC -Wno-unused-imports #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE TupleSections #-}
7+
8+
data Something = Something {
9+
foo :: !String,
10+
bar :: !Int
11+
}
12+
13+
tupleSection = (1, ) <$> Just 2

‎plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.hs

+12
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
#! /usr/bin/env nix-shell
2+
#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
3+
{-# OPTIONS_GHC -Wall #-}
4+
{-# OPTIONS_GHC -Wno-unused-imports #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
7+
data Something = Something {
8+
foo :: !String,
9+
bar :: !Int
10+
}
11+
12+
tupleSection = (1, ) <$> Just 2

‎plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.expected.hs

+18
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
#! /usr/bin/env nix-shell
2+
#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
3+
{-# OPTIONS_GHC -Wall #-}
4+
{-# OPTIONS_GHC -Wno-unused-imports #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE RecordWildCards #-}
7+
{-# LANGUAGE TupleSections #-}
8+
9+
data Something = Something {
10+
foo :: !String,
11+
bar :: !Int
12+
}
13+
14+
tupleSection = (1, ) <$> Just 2
15+
16+
{-# INLINE addOne #-}
17+
addOne :: Int -> Int
18+
addOne x = x + 1

‎plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.hs

+17
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
#! /usr/bin/env nix-shell
2+
#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
3+
{-# OPTIONS_GHC -Wall #-}
4+
{-# OPTIONS_GHC -Wno-unused-imports #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE RecordWildCards #-}
7+
8+
data Something = Something {
9+
foo :: !String,
10+
bar :: !Int
11+
}
12+
13+
tupleSection = (1, ) <$> Just 2
14+
15+
{-# INLINE addOne #-}
16+
addOne :: Int -> Int
17+
addOne x = x + 1

‎plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.expected.hs

+12
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
#! /usr/bin/env nix-shell
2+
#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
3+
{-# OPTIONS_GHC -Wall #-}
4+
{-# OPTIONS_GHC -Wno-unused-imports #-}
5+
{-# LANGUAGE TupleSections #-}
6+
7+
data Something = Something {
8+
foo :: !String,
9+
bar :: !Int
10+
}
11+
12+
tupleSection = (1, ) <$> Just 2

‎plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.hs

+11
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
#! /usr/bin/env nix-shell
2+
#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
3+
{-# OPTIONS_GHC -Wall #-}
4+
{-# OPTIONS_GHC -Wno-unused-imports #-}
5+
6+
data Something = Something {
7+
foo :: !String,
8+
bar :: !Int
9+
}
10+
11+
tupleSection = (1, ) <$> Just 2

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

+16
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
#! /usr/bin/env nix-shell
2+
#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
3+
{-# LANGUAGE OverloadedStrings #-}
4+
{-# LANGUAGE NamedFieldPuns #-}
5+
-- | Doc Comment
6+
{- Block -}
7+
8+
module BeforeDocComment where
9+
10+
data Record = Record
11+
{ a :: Int,
12+
b :: Double,
13+
c :: String
14+
}
15+
16+
f Record{a, b} = a

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

+15
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
#! /usr/bin/env nix-shell
2+
#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
3+
{-# LANGUAGE OverloadedStrings #-}
4+
-- | Doc Comment
5+
{- Block -}
6+
7+
module BeforeDocComment where
8+
9+
data Record = Record
10+
{ a :: Int,
11+
b :: Double,
12+
c :: String
13+
}
14+
15+
f Record{a, b} = a

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

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

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

+3
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
module Main where
2+
3+
tupleSection = (1,) <$> Just 2

0 commit comments

Comments
 (0)