Expand input to pragma if available

hls-test-utils/src/Test/Hls.hs

@@ -47,8 +47,8 @@ import           Data.Aeson                      (Result (Success),
 import qualified Data.Aeson                      as A
 import           Data.ByteString.Lazy            (ByteString)
 import           Data.Default                    (def)
-import           Data.Maybe                      (fromMaybe)
 import qualified Data.Map                        as M
+import           Data.Maybe                      (fromMaybe)
 import qualified Data.Text                       as T
 import qualified Data.Text.Lazy                  as TL
 import qualified Data.Text.Lazy.Encoding         as TL
@@ -69,7 +69,8 @@ import           Development.IDE.Types.Logger    (Logger (Logger),
 import           Development.IDE.Types.Options
 import           GHC.IO.Handle
 import           GHC.Stack                       (emptyCallStack)
-import           Ide.Plugin.Config               (Config, formattingProvider, PluginConfig, plugins)
+import           Ide.Plugin.Config               (Config, PluginConfig,
+                                                  formattingProvider, plugins)
 import           Ide.PluginUtils                 (idePluginsToPluginDesc,
                                                   pluginDescToIdePlugins)
 import           Ide.Types
@@ -208,9 +209,9 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre
     arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger
 
     hlsPlugins =
-      idePluginsToPluginDesc argsHlsPlugins
+      plugins
       ++ [Test.blockCommandDescriptor "block-command", Test.plugin]
-      ++ plugins
+      ++ idePluginsToPluginDesc argsHlsPlugins
     ideOptions = \config ghcSession ->
       let defIdeOptions = argsIdeOptions config ghcSession
       in defIdeOptions

hls-test-utils/src/Test/Hls/Util.hs

@@ -32,6 +32,7 @@ module Test.Hls.Util
     , knownBrokenOnWindows
     , knownBrokenForGhcVersions
     , knownBrokenInEnv
+    , onlyWorkForGhcVersions
     , setupBuildToolFiles
     , SymbolLocation
     , waitForDiagnosticsFrom
@@ -149,6 +150,14 @@ ignoreInEnv envSpecs reason
 ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
 ignoreForGhcVersions vers = ignoreInEnv (map GhcVer vers)
 
+-- | Mark as broken if GHC does not match only work versions.
+onlyWorkForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
+onlyWorkForGhcVersions vers reason =
+    if ghcVersion `elem` vers
+        then id
+        else expectFailBecause reason
+
+-- | Ignore the test if GHC does not match only work versions.
 onlyRunForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
 onlyRunForGhcVersions vers =
     if ghcVersion `elem` vers

plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal

@@ -33,7 +33,7 @@ library
     , transformers
     , unordered-containers
     , containers
-
+  ghc-options: -Wall -Wno-name-shadowing
   default-language: Haskell2010
 
 test-suite tests

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

@@ -10,55 +10,25 @@
 -- | Provides code actions to add missing pragmas (whenever GHC suggests to)
 module Ide.Plugin.Pragmas
   ( descriptor
+  -- For testing
+  , validPragmas
   ) where
 
-import           Control.Applicative              ((<|>))
-import           Control.Lens                     hiding (List)
-import           Control.Monad                    (join)
-import           Control.Monad.IO.Class           (MonadIO (liftIO))
-import           Control.Monad.Trans.State.Strict (State)
-import           Data.Bits                        (Bits (bit, complement, setBit, (.&.)))
-import           Data.Char                        (isSpace)
-import qualified Data.Char                        as Char
-import           Data.Coerce                      (coerce)
-import           Data.Functor                     (void, ($>))
-import qualified Data.HashMap.Strict              as H
-import qualified Data.List                        as List
-import           Data.List.Extra                  (nubOrdOn)
-import qualified Data.Map.Strict                  as Map
-import           Data.Maybe                       (catMaybes, listToMaybe,
-                                                   mapMaybe)
-import qualified Data.Maybe                       as Maybe
-import           Data.Ord                         (Down (Down))
-import           Data.Semigroup                   (Semigroup ((<>)))
-import qualified Data.Text                        as T
-import           Data.Word                        (Word64)
-import           Development.IDE                  as D (Diagnostic (Diagnostic, _code, _message),
-                                                        GhcSession (GhcSession),
-                                                        HscEnvEq (hscEnv),
-                                                        IdeState, List (List),
-                                                        ParseResult (POk),
-                                                        Position (Position),
-                                                        Range (Range), Uri,
-                                                        getFileContents,
-                                                        getParsedModule,
-                                                        printOutputable, runAction,
-                                                        srcSpanToRange,
-                                                        toNormalizedUri,
-                                                        uriToFilePath',
-                                                        useWithStale)
+import           Control.Lens                  hiding (List)
+import           Control.Monad.IO.Class        (MonadIO (liftIO))
+import qualified Data.HashMap.Strict           as H
+import           Data.List.Extra               (nubOrdOn)
+import           Data.Maybe                    (catMaybes)
+import qualified Data.Text                     as T
+import           Development.IDE
 import           Development.IDE.GHC.Compat
-import           Development.IDE.GHC.Compat.Util  (StringBuffer, atEnd,
-                                                   nextChar,
-                                                   stringToStringBuffer)
-import qualified Development.IDE.Spans.Pragmas    as Pragmas
-import           Development.IDE.Types.HscEnvEq   (HscEnvEq, hscEnv)
+import qualified Development.IDE.Spans.Pragmas as Pragmas
 import           Ide.Types
-import qualified Language.LSP.Server              as LSP
-import qualified Language.LSP.Types               as J
-import qualified Language.LSP.Types.Lens          as J
-import qualified Language.LSP.VFS                 as VFS
-import qualified Text.Fuzzy                       as Fuzzy
+import qualified Language.LSP.Server           as LSP
+import qualified Language.LSP.Types            as J
+import qualified Language.LSP.Types.Lens       as J
+import qualified Language.LSP.VFS              as VFS
+import qualified Text.Fuzzy                    as Fuzzy
 
 -- ---------------------------------------------------------------------
 
@@ -193,7 +163,9 @@ allPragmas =
     -- Language Version Extensions
   , "Haskell98"
   , "Haskell2010"
-    -- Maybe, GHC 2021 after its release?
+#if MIN_VERSION_ghc(9,2,0)
+  , "GHC2021"
+#endif
   ]
 
 -- ---------------------------------------------------------------------
@@ -214,59 +186,67 @@ completion _ide _ complParams = do
                     = J.List $ map buildCompletion
                         (Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas)
                     | "{-# options_ghc" `T.isPrefixOf` line
-                    = J.List $ map mkExtCompl
+                    = J.List $ map buildCompletion
                         (Fuzzy.simpleFilter (VFS.prefixText pfix) flags)
                     | "{-#" `T.isPrefixOf` line
-                    = J.List $ map (\(a, b, c) -> mkPragmaCompl (a <> suffix) b c) validPragmas
+                    = J.List $ [ mkPragmaCompl (a <> suffix) b c
+                                | (a, b, c, w) <- validPragmas, w == NewLine ]
                     | otherwise
-                    = J.List []
+                    = J.List $ [ mkPragmaCompl (prefix <> a <> suffix) b c
+                                | (a, b, c, _) <- validPragmas, Fuzzy.test word b]
                     where
                         line = T.toLower $ VFS.fullLine pfix
+                        word = VFS.prefixText pfix
+                        -- Not completely correct, may fail if more than one "{-#" exist
+                        -- , we can ignore it since it rarely happen.
+                        prefix
+                            | "{-# "  `T.isInfixOf` line = ""
+                            | "{-#"   `T.isInfixOf` line = " "
+                            | otherwise                 = "{-# "
                         suffix
-                            | "#-}" `T.isSuffixOf` line = " "
-                            | "-}"  `T.isSuffixOf` line = " #"
-                            | "}"   `T.isSuffixOf` line = " #-"
+                            | " #-}" `T.isSuffixOf` line = ""
+                            | "#-}"  `T.isSuffixOf` line = " "
+                            | "-}"   `T.isSuffixOf` line = " #"
+                            | "}"    `T.isSuffixOf` line = " #-"
                             | otherwise                 = " #-}"
                 result Nothing = J.List []
-                buildCompletion p =
-                    J.CompletionItem
-                      { _label = p,
-                        _kind = Just J.CiKeyword,
-                        _tags = Nothing,
-                        _detail = Nothing,
-                        _documentation = Nothing,
-                        _deprecated = Nothing,
-                        _preselect = Nothing,
-                        _sortText = Nothing,
-                        _filterText = Nothing,
-                        _insertText = Nothing,
-                        _insertTextFormat = Nothing,
-                        _insertTextMode = Nothing,
-                        _textEdit = Nothing,
-                        _additionalTextEdits = Nothing,
-                        _commitCharacters = Nothing,
-                        _command = Nothing,
-                        _xdata = Nothing
-                      }
         _ -> return $ J.List []
 
 -----------------------------------------------------------------------
-validPragmas :: [(T.Text, T.Text, T.Text)]
+
+-- | Pragma where exist
+data AppearWhere =
+  NewLine
+  -- ^Must be on a new line
+  | CanInline
+  -- ^Can appear in the line
+  deriving (Show, Eq)
+
+validPragmas :: [(T.Text, T.Text, T.Text, AppearWhere)]
 validPragmas =
-  [ ("LANGUAGE ${1:extension}"         , "LANGUAGE",           "{-# LANGUAGE #-}")
-  , ("OPTIONS_GHC -${1:option}"        , "OPTIONS_GHC",        "{-# OPTIONS_GHC #-}")
-  , ("INLINE ${1:function}"            , "INLINE",             "{-# INLINE #-}")
-  , ("NOINLINE ${1:function}"          , "NOINLINE",           "{-# NOINLINE #-}")
-  , ("INLINABLE ${1:function}"         , "INLINABLE",          "{-# INLINABLE #-}")
-  , ("WARNING ${1:message}"            , "WARNING",            "{-# WARNING #-}")
-  , ("DEPRECATED ${1:message}"         , "DEPRECATED",         "{-# DEPRECATED  #-}")
-  , ("ANN ${1:annotation}"             , "ANN",                "{-# ANN #-}")
-  , ("RULES"                           , "RULES",              "{-# RULES #-}")
-  , ("SPECIALIZE ${1:function}"        , "SPECIALIZE",         "{-# SPECIALIZE #-}")
-  , ("SPECIALIZE INLINE ${1:function}" , "SPECIALIZE INLINE",  "{-# SPECIALIZE INLINE #-}")
+  [ ("LANGUAGE ${1:extension}"        , "LANGUAGE"         , "{-# LANGUAGE #-}"         ,   NewLine)
+  , ("OPTIONS_GHC -${1:option}"       , "OPTIONS_GHC"      , "{-# OPTIONS_GHC #-}"      ,   NewLine)
+  , ("INLINE ${1:function}"           , "INLINE"           , "{-# INLINE #-}"           ,   NewLine)
+  , ("NOINLINE ${1:function}"         , "NOINLINE"         , "{-# NOINLINE #-}"         ,   NewLine)
+  , ("INLINABLE ${1:function}"        , "INLINABLE"        , "{-# INLINABLE #-}"        ,   NewLine)
+  , ("WARNING ${1:message}"           , "WARNING"          , "{-# WARNING #-}"          , CanInline)
+  , ("DEPRECATED ${1:message}"        , "DEPRECATED"       , "{-# DEPRECATED  #-}"      , CanInline)
+  , ("ANN ${1:annotation}"            , "ANN"              , "{-# ANN #-}"              ,   NewLine)
+  , ("RULES"                          , "RULES"            , "{-# RULES #-}"            ,   NewLine)
+  , ("SPECIALIZE ${1:function}"       , "SPECIALIZE"       , "{-# SPECIALIZE #-}"       ,   NewLine)
+  , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE", "{-# SPECIALIZE INLINE #-}",   NewLine)
+  , ("SPECIALISE ${1:function}"       , "SPECIALISE"       , "{-# SPECIALISE #-}"       ,   NewLine)
+  , ("SPECIALISE INLINE ${1:function}", "SPECIALISE INLINE", "{-# SPECIALISE INLINE #-}",   NewLine)
+  , ("MINIMAL ${1:functions}"         , "MINIMAL"          , "{-# MINIMAL #-}"          , CanInline)
+  , ("UNPACK"                         , "UNPACK"           , "{-# UNPACK #-}"           , CanInline)
+  , ("NOUNPACK"                       , "NOUNPACK"         , "{-# NOUNPACK #-}"         , CanInline)
+  , ("COMPLETE ${1:function}"         , "COMPLETE"         , "{-# COMPLETE #-}"         ,   NewLine)
+  , ("OVERLAPPING"                    , "OVERLAPPING"      , "{-# OVERLAPPING #-}"      , CanInline)
+  , ("OVERLAPPABLE"                   , "OVERLAPPABLE"     , "{-# OVERLAPPABLE #-}"     , CanInline)
+  , ("OVERLAPS"                       , "OVERLAPS"         , "{-# OVERLAPS #-}"         , CanInline)
+  , ("INCOHERENT"                     , "INCOHERENT"       , "{-# INCOHERENT #-}"       , CanInline)
   ]
 
-
 mkPragmaCompl :: T.Text -> T.Text -> T.Text -> J.CompletionItem
 mkPragmaCompl insertText label detail =
   J.CompletionItem label (Just J.CiKeyword) Nothing (Just detail)
@@ -281,8 +261,8 @@ stripLeading c (s:ss)
   | otherwise = s:ss
 
 
-mkExtCompl :: T.Text -> J.CompletionItem
-mkExtCompl label =
+buildCompletion :: T.Text -> J.CompletionItem
+buildCompletion label =
   J.CompletionItem label (Just J.CiKeyword) Nothing Nothing
     Nothing Nothing Nothing Nothing Nothing Nothing Nothing
     Nothing Nothing Nothing Nothing Nothing Nothing

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

@@ -1,28 +1,30 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 module Main
   ( main
   ) where
 
-import           Control.Lens            ((^.), (^..), traversed)
-import           Data.Foldable           (find)
+import           Control.Lens            ((<&>), (^.))
 import qualified Data.Text               as T
-import qualified Ide.Plugin.Pragmas      as Pragmas
+import           Ide.Plugin.Pragmas
 import qualified Language.LSP.Types.Lens as L
 import           System.FilePath
 import           Test.Hls
+import           Test.Hls.Util           (onlyWorkForGhcVersions)
 
 main :: IO ()
 main = defaultTestRunner tests
 
 pragmasPlugin :: PluginDescriptor IdeState
-pragmasPlugin = Pragmas.descriptor "pragmas"
+pragmasPlugin = descriptor "pragmas"
 
 tests :: TestTree
 tests =
   testGroup "pragmas"
   [ codeActionTests
   , codeActionTests'
   , completionTests
+  , completionSnippetTests
   ]
 
 codeActionTests :: TestTree
@@ -77,7 +79,7 @@ codeActionTest testComment fp actions =
     mapM_ (\(action, contains) -> go action contains cas) actions
     action <- case cas of
       (a:_) -> pure a
-      [] -> liftIO $ assertFailure "Expected non-empty list of code actions"
+      []    -> liftIO $ assertFailure "Expected non-empty list of code actions"
     executeCodeAction action
     where
       go action contains cas = liftIO $ action `elem` map (^. L.title) cas @? contains
@@ -105,7 +107,7 @@ completionTests :: TestTree
 completionTests =
   testGroup "completions"
   [ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 34, 0, 4]
-  , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} ") (Just "{-# LANGUAGE #-}") [0, 4, 0, 31, 0, 4]
+  , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 31, 0, 4]
   , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") [0, 4, 0, 32, 0, 4]
   , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") [0, 4, 0, 33, 0, 4]
   , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") [0, 4, 0, 34, 0, 4]
@@ -114,8 +116,21 @@ completionTests =
   , completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing [0, 4, 0, 34, 0, 24]
   , completionTest "completes the Strict language extension" "Completion.hs" "Str" "Strict" Nothing Nothing Nothing [0, 13, 0, 31, 0, 16]
   , completionTest "completes No- language extensions" "Completion.hs" "NoOverload" "NoOverloadedStrings" Nothing Nothing Nothing [0, 13, 0, 31, 0, 23]
+  , onlyWorkForGhcVersions [GHC92] "GHC2021 flag introduced since ghc9.2" $
+    completionTest "completes GHC2021 extensions" "Completion.hs" "ghc" "GHC2021" Nothing Nothing Nothing [0, 13, 0, 31, 0, 16]
   ]
 
+completionSnippetTests :: TestTree
+completionSnippetTests =
+  testGroup "expand snippet to pragma" $
+    validPragmas <&>
+      (\(insertText, label, detail, _) ->
+        let input = T.toLower $ T.init label
+        in completionTest (T.unpack label)
+            "Completion.hs" input label (Just Snippet)
+            (Just $ "{-# " <> insertText <> " #-}") (Just detail)
+            [0, 0, 0, 34, 0, fromIntegral $ T.length input])
+
 completionTest :: String -> String -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [UInt] -> TestTree
 completionTest testComment fileName te' label textFormat insertText detail [a, b, c, d, x, y] =
   testCase testComment $ runSessionWithServer pragmasPlugin testDataDir $ do

test/functional/Completion.hs

@@ -138,10 +138,10 @@ tests = testGroup "completions" [
     , testCase "import second function completion" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
          doc <- openDoc "FunctionCompletions.hs" "haskell"
 
-         let te = TextEdit (Range (Position 0 41) (Position 0 42)) ", l"
+         let te = TextEdit (Range (Position 0 39) (Position 0 39)) ", l"
          _ <- applyEdit doc te
 
-         compls <- getCompletions doc (Position 0 41)
+         compls <- getCompletions doc (Position 0 42)
          item <- getCompletionByLabel "liftA" compls
          liftIO $ do
              item ^. label @?= "liftA"