Move pragmas completion to pragmas plugin (#2134)

* Move pragmas completion to pragmas plugin * update pragmas plugin tests * move options pragmas to pragmas plugin return empty list from logic completions when opts or pragma start fix empty list logic Co-authored-by: Alex Naspo <[email protected]> Co-authored-by: Javier Neira <[email protected]>
haskell · Sep 3, 2021 · 98d9e74 · 98d9e74
1 parent c914c35
commit 98d9e74
Show file tree

Hide file tree

Showing 3 changed files with 58 additions and 51 deletions.
diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
@@ -299,11 +299,6 @@ mkExtCompl label =
     Nothing Nothing Nothing Nothing Nothing Nothing Nothing
     Nothing Nothing Nothing Nothing Nothing Nothing
 
-mkPragmaCompl :: T.Text -> T.Text -> CompletionItem
-mkPragmaCompl label insertText =
-  CompletionItem label (Just CiKeyword) Nothing Nothing
-    Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
-    Nothing Nothing Nothing Nothing Nothing Nothing
 
 fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem
 fromIdentInfo doc IdentInfo{..} q = CI
@@ -600,36 +595,19 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu
         , enteredQual `T.isPrefixOf` label
         ]
 
-      filtListWithSnippet f list suffix =
-        [ toggleSnippets caps config (f label (snippet <> suffix))
-        | (snippet, label) <- list
-        , Fuzzy.test fullPrefix label
-        ]
-
       filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
-      filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas
-      filtOptsCompls   = filtListWith mkExtCompl
       filtKeywordCompls
           | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)
           | otherwise = []
 
-      stripLeading :: Char -> String -> String
-      stripLeading _ [] = []
-      stripLeading c (s:ss)
-        | s == c = ss
-        | otherwise = s:ss
 
   if
     | "import " `T.isPrefixOf` fullLine
     -> return filtImportCompls
     -- we leave this condition here to avoid duplications and return empty list
-    -- since HLS implements this completion (#haskell-language-server/pull/662)
-    | "{-# language" `T.isPrefixOf` T.toLower fullLine
-    -> return []
-    | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine
-    -> return $ filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False)
+    -- since HLS implements these completions (#haskell-language-server/pull/662)
     | "{-# " `T.isPrefixOf` fullLine
-    -> return $ filtPragmaCompls (pragmaSuffix fullLine)
+    -> return []
     | otherwise -> do
         -- assumes that nubOrdBy is stable
         let uniqueFiltCompls = nubOrdBy uniqueCompl filtCompls
@@ -651,29 +629,6 @@ uniqueCompl x y =
         then EQ
         else compare (insertText x) (insertText y)
     other -> other
--- ---------------------------------------------------------------------
--- helper functions for pragmas
--- ---------------------------------------------------------------------
-
-validPragmas :: [(T.Text, T.Text)]
-validPragmas =
-  [ ("LANGUAGE ${1:extension}"        , "LANGUAGE")
-  , ("OPTIONS_GHC -${1:option}"       , "OPTIONS_GHC")
-  , ("INLINE ${1:function}"           , "INLINE")
-  , ("NOINLINE ${1:function}"         , "NOINLINE")
-  , ("INLINABLE ${1:function}"        , "INLINABLE")
-  , ("WARNING ${1:message}"           , "WARNING")
-  , ("DEPRECATED ${1:message}"        , "DEPRECATED")
-  , ("ANN ${1:annotation}"            , "ANN")
-  , ("RULES"                          , "RULES")
-  , ("SPECIALIZE ${1:function}"       , "SPECIALIZE")
-  , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE")
-  ]
-
-pragmaSuffix :: T.Text -> T.Text
-pragmaSuffix fullLine
-  |  "}" `T.isSuffixOf` fullLine = mempty
-  | otherwise = " #-}"
 
 -- ---------------------------------------------------------------------
 -- helper functions for infix backticks

diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs
@@ -150,6 +150,9 @@ allPragmas =
 
 -- ---------------------------------------------------------------------
 
+flags :: [T.Text]
+flags = map (T.pack . stripLeading '-') $ flagsForCompletion False
+
 completion :: PluginMethodHandler IdeState 'J.TextDocumentCompletion
 completion _ide _ complParams = do
     let (J.TextDocumentIdentifier uri) = complParams ^. J.textDocument
@@ -163,9 +166,19 @@ completion _ide _ complParams = do
                     | "{-# LANGUAGE" `T.isPrefixOf` VFS.fullLine pfix
                     = J.List $ map buildCompletion
                         (Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas)
+                    | "{-# options_ghc" `T.isPrefixOf` T.toLower (VFS.fullLine pfix)
+                    = J.List $ map mkExtCompl
+                        (Fuzzy.simpleFilter (VFS.prefixText pfix) flags)
+                    -- if there already is a closing bracket - complete without one
+                    | isPragmaPrefix (VFS.fullLine pfix) && "}" `T.isSuffixOf` VFS.fullLine pfix
+                    = J.List $ map (\(a, b, c) -> mkPragmaCompl a b c) (validPragmas Nothing)
+                    -- if there is no closing bracket - complete with one
+                    | isPragmaPrefix (VFS.fullLine pfix)
+                    = J.List $ map (\(a, b, c) -> mkPragmaCompl a b c) (validPragmas (Just "}"))
                     | otherwise
                     = J.List []
                 result Nothing = J.List []
+                isPragmaPrefix line = "{-#" `T.isPrefixOf` line
                 buildCompletion p =
                     J.CompletionItem
                       { _label = p,
@@ -187,8 +200,31 @@ completion _ide _ complParams = do
                         _xdata = Nothing
                       }
         _ -> return $ J.List []
-
 -----------------------------------------------------------------------
+validPragmas :: Maybe T.Text -> [(T.Text, T.Text, T.Text)]
+validPragmas mSuffix =
+  [ ("LANGUAGE ${1:extension} #-" <> suffix         , "LANGUAGE",           "{-# LANGUAGE #-}")
+  , ("OPTIONS_GHC -${1:option} #-" <> suffix        , "OPTIONS_GHC",        "{-# OPTIONS_GHC #-}")
+  , ("INLINE ${1:function} #-" <> suffix            , "INLINE",             "{-# INLINE #-}")
+  , ("NOINLINE ${1:function} #-" <> suffix          , "NOINLINE",           "{-# NOINLINE #-}")
+  , ("INLINABLE ${1:function} #-"<> suffix          , "INLINABLE",          "{-# INLINABLE #-}")
+  , ("WARNING ${1:message} #-" <> suffix            , "WARNING",            "{-# WARNING #-}")
+  , ("DEPRECATED ${1:message} #-" <> suffix         , "DEPRECATED",         "{-# DEPRECATED  #-}")
+  , ("ANN ${1:annotation} #-" <> suffix             , "ANN",                "{-# ANN #-}")
+  , ("RULES #-" <> suffix                           , "RULES",              "{-# RULES #-}")
+  , ("SPECIALIZE ${1:function} #-" <> suffix        , "SPECIALIZE",         "{-# SPECIALIZE #-}")
+  , ("SPECIALIZE INLINE ${1:function} #-"<> suffix  , "SPECIALIZE INLINE",  "{-# SPECIALIZE INLINE #-}")
+  ]
+  where suffix = case mSuffix of
+                  (Just s) -> s
+                  Nothing -> ""
+
+
+mkPragmaCompl :: T.Text -> T.Text -> T.Text -> J.CompletionItem
+mkPragmaCompl insertText label detail =
+  J.CompletionItem label (Just J.CiKeyword) Nothing (Just detail)
+    Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just J.Snippet)
+    Nothing Nothing Nothing Nothing Nothing Nothing
 
 -- | Find first line after the last file header pragma
 -- Defaults to line 0 if the file contains no shebang(s), OPTIONS_GHC pragma(s), or LANGUAGE pragma(s)
@@ -218,3 +254,17 @@ checkPragma name = check
     check l = isPragma l && getName l == name
     getName l = T.take (T.length name) $ T.dropWhile isSpace $ T.drop 3 l
     isPragma = T.isPrefixOf "{-#"
+
+
+stripLeading :: Char -> String -> String
+stripLeading _ [] = []
+stripLeading c (s:ss)
+  | s == c = ss
+  | otherwise = s:ss
+
+
+mkExtCompl :: T.Text -> J.CompletionItem
+mkExtCompl label =
+  J.CompletionItem label (Just J.CiKeyword) Nothing Nothing
+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+    Nothing Nothing Nothing Nothing Nothing Nothing
diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs
@@ -207,18 +207,20 @@ completionTests =
         item ^. L.kind @?= Just CiKeyword
         item ^. L.insertTextFormat @?= Just Snippet
         item ^. L.insertText @?= Just "LANGUAGE ${1:extension} #-}"
+        item ^. L.detail @?= Just "{-# LANGUAGE #-}"
 
-  , testCase "completes pragmas no close" $ runSessionWithServer pragmasPlugin testDataDir $ do
+  , testCase "completes pragmas with existing closing bracket" $ runSessionWithServer pragmasPlugin testDataDir $ do
       doc <- openDoc "Completion.hs" "haskell"
-      let te = TextEdit (Range (Position 0 4) (Position 0 24)) ""
+      let te = TextEdit (Range (Position 0 4) (Position 0 33)) ""
       _ <- applyEdit doc te
       compls <- getCompletions doc (Position 0 4)
       let item = head $ filter ((== "LANGUAGE") . (^. L.label)) compls
       liftIO $ do
         item ^. L.label @?= "LANGUAGE"
         item ^. L.kind @?= Just CiKeyword
         item ^. L.insertTextFormat @?= Just Snippet
-        item ^. L.insertText @?= Just "LANGUAGE ${1:extension}"
+        item ^. L.insertText @?= Just "LANGUAGE ${1:extension} #-"
+        item ^. L.detail @?= Just "{-# LANGUAGE #-}"
 
   , testCase "completes options pragma" $ runSessionWithServer pragmasPlugin testDataDir $ do
       doc <- openDoc "Completion.hs" "haskell"