Skip to content

Commit b8b9620

Browse files
nini-farouxpepeiborra
nini-faroux
and
pepeiborra
authored
amend fix for correct placement of file header pragmas (haskell#2078)
Co-authored-by: Pepe Iborra <[email protected]>
1 parent 027587b commit b8b9620

24 files changed

+373
-12
lines changed

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

+16-12
Original file line numberDiff line numberDiff line change
@@ -190,27 +190,31 @@ completion _ide _ complParams = do
190190

191191
-----------------------------------------------------------------------
192192

193-
-- | Find first line after the last LANGUAGE pragma
194-
-- Defaults to line 0 if the file contains no shebang(s), OPTIONS_GHC pragma(s), or other LANGUAGE pragma(s)
195-
-- Otherwise it will be one after the count of line numbers, with order: Shebangs -> OPTIONS_GHC -> LANGUAGE
193+
-- | Find first line after the last file header pragma
194+
-- Defaults to line 0 if the file contains no shebang(s), OPTIONS_GHC pragma(s), or LANGUAGE pragma(s)
195+
-- Otherwise it will be one after the count of line numbers, checking in order: Shebangs -> OPTIONS_GHC -> LANGUAGE
196+
-- Taking the max of these to account for the possibility of interchanging order of these three Pragma types
196197
findNextPragmaPosition :: T.Text -> Range
197198
findNextPragmaPosition contents = Range loc loc
198199
where
199200
loc = Position line 0
200-
line = afterLangPragma . afterOptsGhc $ afterShebang 0
201-
afterLangPragma = afterPragma "LANGUAGE" contents
202-
afterOptsGhc = afterPragma "OPTIONS_GHC" contents
203-
afterShebang = afterPragma "" contents
201+
line = afterLangPragma . afterOptsGhc $ afterShebang
202+
afterLangPragma = afterPragma "LANGUAGE" contents'
203+
afterOptsGhc = afterPragma "OPTIONS_GHC" contents'
204+
afterShebang = lastLineWithPrefix (T.isPrefixOf "#!") contents' 0
205+
contents' = T.lines contents
204206

205-
afterPragma :: T.Text -> T.Text -> Int -> Int
206-
afterPragma name contents lineNum = maybe lineNum succ $ lastLineWithPrefix (checkPragma name) contents
207+
afterPragma :: T.Text -> [T.Text] -> Int -> Int
208+
afterPragma name contents lineNum = lastLineWithPrefix (checkPragma name) contents lineNum
209+
210+
lastLineWithPrefix :: (T.Text -> Bool) -> [T.Text] -> Int -> Int
211+
lastLineWithPrefix p contents lineNum = max lineNum next
207212
where
208-
lastLineWithPrefix p contents = listToMaybe . reverse $ findIndices p $ T.lines contents
213+
next = maybe lineNum succ $ listToMaybe . reverse $ findIndices p contents
209214

210215
checkPragma :: T.Text -> T.Text -> Bool
211216
checkPragma name = check
212217
where
213-
check l = (isPragma l || isShebang l) && getName l == name
218+
check l = isPragma l && getName l == name
214219
getName l = T.take (T.length name) $ T.dropWhile isSpace $ T.drop 3 l
215220
isPragma = T.isPrefixOf "{-#"
216-
isShebang = T.isPrefixOf "#!"

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

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

35+
, goldenWithPragmas "adds LANGUAGE with no other pragmas at start ignoring later INLINE pragma" "AddPragmaIgnoreInline" $ \doc -> do
36+
_ <- waitForDiagnosticsFrom doc
37+
cas <- map fromAction <$> getAllCodeActions doc
38+
liftIO $ "Add \"TupleSections\"" `elem` map (^. L.title) cas @? "Contains TupleSections code action"
39+
executeCodeAction $ head cas
40+
41+
, goldenWithPragmas "adds LANGUAGE after shebang preceded by other LANGUAGE and GHC_OPTIONS" "AddPragmaAfterShebangPrecededByLangAndOptsGhc" $ \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 after shebang with other Language preceding shebang" "AddPragmaAfterShebangPrecededByLanguage" $ \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 before Doc comments after interchanging pragmas" "BeforeDocInterchanging" $ \doc -> do
54+
_ <- waitForDiagnosticsFrom doc
55+
cas <- map fromAction <$> getAllCodeActions doc
56+
liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action"
57+
executeCodeAction $ head cas
58+
59+
, goldenWithPragmas "Add language after altering OPTIONS_GHC and Language" "AddLanguagePragmaAfterInterchaningOptsGhcAndLangs" $ \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 "Add language after pragmas with non standard space between prefix and name" "AddPragmaWithNonStandardSpacingInPrecedingPragmas" $ \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 after OptGHC at start ignoring later INLINE pragma" "AddPragmaAfterOptsGhcIgnoreInline" $ \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 ignore later Ann pragma" "AddPragmaIgnoreLaterAnnPragma" $ \doc -> do
78+
_ <- waitForDiagnosticsFrom doc
79+
cas <- map fromAction <$> getAllCodeActions doc
80+
liftIO $ "Add \"BangPatterns\"" `elem` map (^. L.title) cas @? "Contains BangPatterns code action"
81+
executeCodeAction $ head cas
82+
83+
, goldenWithPragmas "adds LANGUAGE after interchanging pragmas ignoring later Ann pragma" "AddLanguageAfterInterchaningIgnoringLaterAnn" $ \doc -> do
84+
_ <- waitForDiagnosticsFrom doc
85+
cas <- map fromAction <$> getAllCodeActions doc
86+
liftIO $ "Add \"BangPatterns\"" `elem` map (^. L.title) cas @? "Contains BangPatterns code action"
87+
executeCodeAction $ head cas
88+
89+
, goldenWithPragmas "adds LANGUAGE after OptGHC preceded by another language pragma" "AddLanguageAfterLanguageThenOptsGhc" $ \doc -> do
90+
_ <- waitForDiagnosticsFrom doc
91+
cas <- map fromAction <$> getAllCodeActions doc
92+
liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action"
93+
executeCodeAction $ head cas
94+
3595
, goldenWithPragmas "adds LANGUAGE pragma after shebang and last language pragma" "AfterShebangAndPragma" $ \doc -> do
3696
_ <- waitForDiagnosticsFrom doc
3797
cas <- map fromAction <$> getAllCodeActions doc

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

+18
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
{-# OPTIONS_GHC -Wall #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# OPTIONS_GHC -Wno-unused-imports #-}
4+
{-# LANGUAGE RecordWildCards #-}
5+
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
6+
{-# LANGUAGE BangPatterns #-}
7+
8+
data Metaprogram = Metaprogram
9+
{ mp_name :: !Text
10+
, mp_known_by_auto :: !Bool
11+
, mp_show_code_action :: !Bool
12+
, mp_program :: !(TacticsM ())
13+
}
14+
deriving stock Generic
15+
{-# ANN Metaprogram "hello" #-}
16+
17+
instance NFData Metaprogram where
18+
rnf (!(Metaprogram !_ !_ !_ !_)) = ()

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

+17
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
{-# OPTIONS_GHC -Wall #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# OPTIONS_GHC -Wno-unused-imports #-}
4+
{-# LANGUAGE RecordWildCards #-}
5+
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
6+
7+
data Metaprogram = Metaprogram
8+
{ mp_name :: !Text
9+
, mp_known_by_auto :: !Bool
10+
, mp_show_code_action :: !Bool
11+
, mp_program :: !(TacticsM ())
12+
}
13+
deriving stock Generic
14+
{-# ANN Metaprogram "hello" #-}
15+
16+
instance NFData Metaprogram where
17+
rnf (!(Metaprogram !_ !_ !_ !_)) = ()

‎plugins/hls-pragmas-plugin/test/testdata/AddLanguageAfterLanguageThenOptsGhc.expected.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+
{-# LANGUAGE OverloadedStrings #-}
5+
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
6+
{-# LANGUAGE NamedFieldPuns #-}
7+
-- | Doc Comment
8+
{- Block -}
9+
10+
module BeforeDocComment where
11+
12+
test :: Int -> Integer
13+
test x = x * 2
14+
15+
data Record = Record
16+
{ a :: Int,
17+
b :: Double,
18+
c :: String
19+
}
20+
21+
f Record{a, b} = a

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

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

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

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

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

+20
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
{-# OPTIONS_GHC -Wall #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# OPTIONS_GHC -Wno-unused-imports #-}
4+
{-# LANGUAGE RecordWildCards #-}
5+
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
6+
7+
data Something = Something {
8+
foo :: !String,
9+
bar :: !Int
10+
}
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
19+
20+
tupleSection = (1, ) <$> Just 2

‎plugins/hls-pragmas-plugin/test/testdata/AddOptsGhcAfterLanguage.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+
{-# LANGUAGE OverloadedStrings #-}
5+
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
6+
-- | Doc Comment
7+
{- Block -}
8+
9+
module BeforeDocComment where
10+
11+
test :: Int -> Integer
12+
test x = x * 2

‎plugins/hls-pragmas-plugin/test/testdata/AddOptsGhcAfterLanguage.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+
{-# LANGUAGE OverloadedStrings #-}
5+
-- | Doc Comment
6+
{- Block -}
7+
8+
module BeforeDocComment where
9+
10+
test :: Int -> Integer
11+
test x = x * 2

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

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

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

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

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

+12
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# OPTIONS_GHC -Wall #-}
3+
#! /usr/bin/env nix-shell
4+
#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"
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/AddPragmaAfterShebangPrecededByLangAndOptsGhc.hs

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

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

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

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

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

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

+11
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
{-# LANGUAGE TupleSections #-}
2+
data Something = Something {
3+
foo :: !String,
4+
bar :: !Int
5+
}
6+
7+
tupleSection = (1, ) <$> Just 2
8+
9+
{-# INLINE addOne #-}
10+
addOne :: Int -> Int
11+
addOne x = x + 1

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

+10
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
data Something = Something {
2+
foo :: !String,
3+
bar :: !Int
4+
}
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/AddPragmaIgnoreLaterAnnPragma.expected.hs

+12
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
data Metaprogram = Metaprogram
3+
{ mp_name :: !Text
4+
, mp_known_by_auto :: !Bool
5+
, mp_show_code_action :: !Bool
6+
, mp_program :: !(TacticsM ())
7+
}
8+
deriving stock Generic
9+
{-# ANN Metaprogram "hello" #-}
10+
11+
instance NFData Metaprogram where
12+
rnf (!(Metaprogram !_ !_ !_ !_)) = ()

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

+11
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
data Metaprogram = Metaprogram
2+
{ mp_name :: !Text
3+
, mp_known_by_auto :: !Bool
4+
, mp_show_code_action :: !Bool
5+
, mp_program :: !(TacticsM ())
6+
}
7+
deriving stock Generic
8+
{-# ANN Metaprogram "hello" #-}
9+
10+
instance NFData Metaprogram where
11+
rnf (!(Metaprogram !_ !_ !_ !_)) = ()

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

+6
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
{-# OPTIONS_GHC -Wall #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
4+
{-# LANGUAGE TupleSections #-}
5+
6+
tupleSection = (1, ) <$> Just 2

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

+5
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
{-# OPTIONS_GHC -Wall #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
4+
5+
tupleSection = (1, ) <$> Just 2

0 commit comments

Comments
 (0)