use GHC language extension names (#362)

Author: sheaf

src/Development/IDE/GHC/Compat.hs

@@ -16,7 +16,6 @@ module Development.IDE.GHC.Compat(
     includePathsGlobal,
     includePathsQuote,
     addIncludePathsQuote,
-    ghcEnumerateExtensions,
     pattern DerivD,
     pattern ForD,
     pattern InstD,
@@ -31,11 +30,6 @@ module Development.IDE.GHC.Compat(
 import StringBuffer
 import DynFlags
 import FieldLabel
-import GHC.LanguageExtensions.Type
-
-#if MIN_GHC_API_VERSION(8,8,0)
-import Data.List.Extra (enumerate)
-#endif
 
 import qualified GHC
 import GHC hiding (ClassOpSig, DerivD, ForD, IEThingWith, InstD, TyClD, ValD)
@@ -88,15 +82,6 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x}
 addIncludePathsQuote path x = x{includePaths = path : includePaths x}
 #endif
 
-ghcEnumerateExtensions :: [Extension]
-#if MIN_GHC_API_VERSION(8,8,0)
-ghcEnumerateExtensions = enumerate
-#elif MIN_GHC_API_VERSION(8,6,0)
-ghcEnumerateExtensions = [Cpp .. StarIsType]
-#else
-ghcEnumerateExtensions = [Cpp .. EmptyDataDeriving]
-#endif
-
 pattern DerivD :: DerivDecl p -> HsDecl p
 pattern DerivD x <-
 #if MIN_GHC_API_VERSION(8,6,0)

src/Development/IDE/Plugin/CodeAction.hs

@@ -21,7 +21,6 @@ import Development.IDE.LSP.Server
 import Development.IDE.Types.Location
 import Development.IDE.Types.Options
 import qualified Data.HashMap.Strict as Map
-import qualified Data.HashSet as Set
 import qualified Language.Haskell.LSP.Core as LSP
 import Language.Haskell.LSP.VFS
 import Language.Haskell.LSP.Messages
@@ -32,9 +31,12 @@ import Data.Char
 import Data.Maybe
 import Data.List.Extra
 import qualified Data.Text as T
+import Data.Tuple.Extra ((&&&))
 import Text.Regex.TDFA ((=~), (=~~))
 import Text.Regex.TDFA.Text()
 import Outputable (ppr, showSDocUnsafe)
+import DynFlags (xFlags, FlagSpec(..))
+import GHC.LanguageExtensions.Type (Extension)
 
 plugin :: Plugin
 plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens
@@ -210,10 +212,14 @@ suggestAddExtension Diagnostic{_range=_range@Range{..},..}
 --     * In the context: a ~ ()
 --       While checking an instance declaration
 --       In the instance declaration for `Unit (m a)'
-    | exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message
+    | exts@(_:_) <- filter (`Map.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message
         = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]
     | otherwise = []
 
+-- | All the GHC extensions
+ghcExtensions :: Map.HashMap T.Text Extension
+ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags
+
 suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]
 suggestModuleTypo Diagnostic{_range=_range@Range{..},..}
 -- src/Development/IDE/Core/Compile.hs:58:1: error:
@@ -367,10 +373,6 @@ extendToWholeLineIfPossible contents range@Range{..} =
         extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line
     in if extend then Range _start (Position (_line _end + 1) 0) else range
 
--- | All the GHC extensions
-ghcExtensions :: Set.HashSet T.Text
-ghcExtensions = Set.fromList $ map (T.pack . show) ghcEnumerateExtensions
-
 splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)
 splitTextAtPosition (Position row col) x
     | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x

test/exe/Main.hs

@@ -392,6 +392,7 @@ codeActionTests = testGroup "code actions"
   , typeWildCardActionTests
   , removeImportTests
   , extendImportTests
+  , addExtensionTests
   , fixConstructorImportTests
   , importRenameActionTests
   , fillTypedHoleTests
@@ -806,6 +807,62 @@ extendImportTests = testGroup "extend import actions"
       contentAfterAction <- documentContents docB
       liftIO $ expectedContentB @=? contentAfterAction
 
+addExtensionTests :: TestTree
+addExtensionTests = testGroup "add language extension actions"
+  [ testSession "add NamedFieldPuns language extension" $ template
+      (T.unlines
+            [ "module Module where"
+            , ""
+            , "data A = A { getA :: Bool }"
+            , ""
+            , "f :: A -> Bool"
+            , "f A { getA } = getA"
+            ])
+      (Range (Position 0 0) (Position 0 0))
+      "Add NamedFieldPuns extension"
+      (T.unlines
+            [ "{-# LANGUAGE NamedFieldPuns #-}"
+            , "module Module where"
+            , ""
+            , "data A = A { getA :: Bool }"
+            , ""
+            , "f :: A -> Bool"
+            , "f A { getA } = getA"
+            ])
+  , testSession "add RecordWildCards language extension" $ template
+      (T.unlines
+            [ "module Module where"
+            , ""
+            , "data A = A { getA :: Bool }"
+            , ""
+            , "f :: A -> Bool"
+            , "f A { .. } = getA"
+            ])
+      (Range (Position 0 0) (Position 0 0))
+      "Add RecordWildCards extension"
+      (T.unlines
+            [ "{-# LANGUAGE RecordWildCards #-}"
+            , "module Module where"
+            , ""
+            , "data A = A { getA :: Bool }"
+            , ""
+            , "f :: A -> Bool"
+            , "f A { .. } = getA"
+            ])
+  ]
+    where
+      template initialContent range expectedAction expectedContents = do
+        doc <- openDoc' "Module.hs" "haskell" initialContent
+        _ <- waitForDiagnostics
+        CACodeAction action@CodeAction { _title = actionTitle } : _
+                    <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
+                       getCodeActions doc range
+        liftIO $ expectedAction @=? actionTitle
+        executeCodeAction action
+        contentAfterAction <- documentContents doc
+        liftIO $ expectedContents @=? contentAfterAction
+        
+
 insertNewDefinitionTests :: TestTree
 insertNewDefinitionTests = testGroup "insert new definition actions"
   [ testSession "insert new function definition" $ do