diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index b6e73e3964..bc00c9b0a3 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/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 "#!" diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs index 5423dfa330..d9af4bbc0f 100644 --- a/plugins/hls-pragmas-plugin/test/Main.hs +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragma.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragma.expected.hs new file mode 100644 index 0000000000..74f146f15e --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragma.hs b/plugins/hls-pragmas-plugin/test/testdata/AddLanguagePragma.hs new file mode 100644 index 0000000000..2f29ee4e13 --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterAllWithMultipleInlines.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterAllWithMultipleInlines.expected.hs new file mode 100644 index 0000000000..4b9adb0269 --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterAllWithMultipleInlines.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterAllWithMultipleInlines.hs new file mode 100644 index 0000000000..d05bc2088b --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.expected.hs new file mode 100644 index 0000000000..c17952a575 --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterGhcOptions.hs new file mode 100644 index 0000000000..cf1c45eaf3 --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.expected.hs new file mode 100644 index 0000000000..67f8957d83 --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragma.hs new file mode 100644 index 0000000000..284bf8e015 --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.expected.hs new file mode 100644 index 0000000000..c06d6640e8 --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOptionsAndPragmasIgnoreInline.hs new file mode 100644 index 0000000000..1fd3c6d1e4 --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.expected.hs new file mode 100644 index 0000000000..317750eb89 --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndOpts.hs new file mode 100644 index 0000000000..0c14945395 --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndPragma.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndPragma.expected.hs new file mode 100644 index 0000000000..6c7c802d23 --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndPragma.hs b/plugins/hls-pragmas-plugin/test/testdata/AfterShebangAndPragma.hs new file mode 100644 index 0000000000..fcae5211d7 --- /dev/null +++ b/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 diff --git a/plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.expected.hs new file mode 100644 index 0000000000..522c7c78b7 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.expected.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TupleSections #-} +module Main where + +tupleSection = (1,) <$> Just 2 diff --git a/plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.hs b/plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.hs new file mode 100644 index 0000000000..1234c57c27 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/ModuleOnFirstLine.hs @@ -0,0 +1,3 @@ +module Main where + +tupleSection = (1,) <$> Just 2