Skip to content

Commit 6949b15

Browse files
OliverMadinejneiraberberman
authored
Insert pragmas after shebang or to existing pragma list (#1731)
* added option to always insert pragmas at top of file * Revert "added option to always insert pragmas at top of file" This reverts commit 8cebdd5. * Pragmas inserted before comments (#1726) * Code style * Code style * Insert pragamas to existing pragma list * added cpp macro to pragma test for ghc < 810 * Refactor: using file contents to find pragma insertion position * Update getParsedModule action description * Code style Co-authored-by: Javier Neira <atreyu.bbb@gmail.com> Co-authored-by: Potato Hatsue <1793913507@qq.com>
1 parent 369fdfe commit 6949b15

File tree

4 files changed

+99
-20
lines changed

4 files changed

+99
-20
lines changed

‎plugins/default/src/Ide/Plugin/Pragmas.hs

Lines changed: 10 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ import Control.Lens hiding (List)
1111
import Control.Monad (join)
1212
import Control.Monad.IO.Class
1313
import qualified Data.HashMap.Strict as H
14+
import Data.List
1415
import Data.List.Extra (nubOrdOn)
1516
import Data.Maybe (catMaybes, listToMaybe)
1617
import qualified Data.Text as T
@@ -45,8 +46,9 @@ codeActionProvider state _plId (CodeActionParams _ _ docId _ (J.CodeActionContex
4546
let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath'
4647
uri = docId ^. J.uri
4748
pm <- liftIO $ fmap join $ runAction "Pragmas.GetParsedModule" state $ getParsedModule `traverse` mFile
49+
mbContents <- liftIO $ fmap (join . fmap snd) $ runAction "Pragmas.GetFileContents" state $ getFileContents `traverse` mFile
4850
let dflags = ms_hspp_opts . pm_mod_summary <$> pm
49-
insertRange = maybe (Range (Position 0 0) (Position 0 0)) endOfModuleHeader pm
51+
insertRange = maybe (Range (Position 0 0) (Position 0 0)) endOfModuleHeader mbContents
5052
pedits = nubOrdOn snd . concat $ suggest dflags <$> diags
5153
return $ Right $ List $ pragmaEditToAction uri insertRange <$> pedits
5254

@@ -178,14 +180,11 @@ completion _ide _ complParams = do
178180

179181
-- ---------------------------------------------------------------------
180182

181-
-- | Find the first non-blank line before the first of (module name / imports / declarations).
183+
-- | Find first line after (last pragma / last shebang / beginning of file).
182184
-- Useful for inserting pragmas.
183-
endOfModuleHeader :: ParsedModule -> Range
184-
endOfModuleHeader pm =
185-
let mod = unLoc $ pm_parsed_source pm
186-
modNameLoc = getLoc <$> hsmodName mod
187-
firstImportLoc = getLoc <$> listToMaybe (hsmodImports mod)
188-
firstDeclLoc = getLoc <$> listToMaybe (hsmodDecls mod)
189-
line = maybe 0 (_line . _start) (modNameLoc <|> firstImportLoc <|> firstDeclLoc >>= srcSpanToRange)
190-
loc = Position line 0
191-
in Range loc loc
185+
endOfModuleHeader :: T.Text -> Range
186+
endOfModuleHeader contents = Range loc loc
187+
where
188+
loc = Position line 0
189+
line = maybe 0 succ (lastLineWithPrefix "{-#" <|> lastLineWithPrefix "#!")
190+
lastLineWithPrefix pre = listToMaybe $ reverse $ findIndices (T.isPrefixOf pre) $ T.lines contents

‎test/functional/FunctionalCodeAction.hs

Lines changed: 64 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -511,14 +511,8 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [
511511
contents <- documentContents doc
512512

513513
let expected =
514-
-- TODO: Why CPP???
515-
#if __GLASGOW_HASKELL__ < 810
516514
[ "{-# LANGUAGE ScopedTypeVariables #-}"
517515
, "{-# LANGUAGE TypeApplications #-}"
518-
#else
519-
[ "{-# LANGUAGE TypeApplications #-}"
520-
, "{-# LANGUAGE ScopedTypeVariables #-}"
521-
#endif
522516
, "module TypeApplications where"
523517
, ""
524518
, "foo :: forall a. a -> a"
@@ -555,7 +549,7 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [
555549
, "f Record{a, b} = a"
556550
]
557551
liftIO $ T.lines contents @?= expected
558-
, testCase "After Shebang" $ do
552+
, testCase "After shebang" $ do
559553
runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do
560554
doc <- openDoc "AfterShebang.hs" "haskell"
561555

@@ -571,8 +565,8 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [
571565
let expected =
572566
[ "#! /usr/bin/env nix-shell"
573567
, "#! nix-shell --pure -i runghc -p \"haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])\""
574-
, ""
575568
, "{-# LANGUAGE NamedFieldPuns #-}"
569+
, ""
576570
, "module AfterShebang where"
577571
, ""
578572
, "data Record = Record"
@@ -584,6 +578,67 @@ missingPragmaTests = testGroup "missing pragma warning code actions" [
584578
, "f Record{a, b} = a"
585579
]
586580

581+
liftIO $ T.lines contents @?= expected
582+
, testCase "Append to existing pragmas" $ do
583+
runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do
584+
doc <- openDoc "AppendToExisting.hs" "haskell"
585+
586+
_ <- waitForDiagnosticsFrom doc
587+
cas <- map fromAction <$> getAllCodeActions doc
588+
589+
liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action"
590+
591+
executeCodeAction $ head cas
592+
593+
contents <- documentContents doc
594+
595+
let expected =
596+
[ "-- | Doc before pragma"
597+
, "{-# OPTIONS_GHC -Wno-dodgy-imports #-}"
598+
, "{-# LANGUAGE NamedFieldPuns #-}"
599+
, "module AppendToExisting where"
600+
, ""
601+
, "data Record = Record"
602+
, " { a :: Int,"
603+
, " b :: Double,"
604+
, " c :: String"
605+
, " }"
606+
, ""
607+
, "f Record{a, b} = a"
608+
]
609+
610+
liftIO $ T.lines contents @?= expected
611+
, testCase "Before Doc Comments" $ do
612+
runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do
613+
doc <- openDoc "BeforeDocComment.hs" "haskell"
614+
615+
_ <- waitForDiagnosticsFrom doc
616+
cas <- map fromAction <$> getAllCodeActions doc
617+
618+
liftIO $ "Add \"NamedFieldPuns\"" `elem` map (^. L.title) cas @? "Contains NamedFieldPuns code action"
619+
620+
executeCodeAction $ head cas
621+
622+
contents <- documentContents doc
623+
624+
let expected =
625+
[ "#! /usr/bin/env nix-shell"
626+
, "#! nix-shell --pure -i runghc -p \"haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])\""
627+
, "{-# LANGUAGE NamedFieldPuns #-}"
628+
, "-- | Doc Comment"
629+
, "{- Block -}"
630+
, ""
631+
, "module BeforeDocComment where"
632+
, ""
633+
, "data Record = Record"
634+
, " { a :: Int,"
635+
, " b :: Double,"
636+
, " c :: String"
637+
, " }"
638+
, ""
639+
, "f Record{a, b} = a"
640+
]
641+
587642
liftIO $ T.lines contents @?= expected
588643
]
589644

@@ -614,9 +669,9 @@ disableWarningTests =
614669
]
615670
, T.unlines
616671
[ "{-# OPTIONS_GHC -Wall #-}"
672+
, "{-# OPTIONS_GHC -Wno-unused-imports #-}"
617673
, ""
618674
, ""
619-
, "{-# OPTIONS_GHC -Wno-unused-imports #-}"
620675
, "module M where"
621676
, ""
622677
, "import Data.Functor"

‎test/testdata/addPragmas/AppendToExisting.hs

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
-- | Doc before pragma
2+
{-# OPTIONS_GHC -Wno-dodgy-imports #-}
3+
module AppendToExisting where
4+
5+
data Record = Record
6+
{ a :: Int,
7+
b :: Double,
8+
c :: String
9+
}
10+
11+
f Record{a, b} = a

‎test/testdata/addPragmas/BeforeDocComment.hs

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

0 commit comments

Comments
 (0)