A plugin for GADT syntax converter

.github/workflows/test.yml

@@ -246,6 +246,10 @@ jobs:
         name: Test hls-change-type-signature test suite
         run: cabal test hls-change-type-signature-plugin --test-options="$TEST_OPTS" || cabal test hls-change-type-signature-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-change-type-signature-plugin --test-options="$TEST_OPTS"
 
+      - if: matrix.test
+        name: Test hls-gadt-plugin test suit
+        run: cabal test hls-gadt-plugin --test-options="$TEST_OPTS" || cabal test hls-gadt-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-gadt-plugin --test-options="$TEST_OPTS"
+
   test_post_job:
     if: always()
     runs-on: ubuntu-latest

CODEOWNERS

@@ -15,6 +15,7 @@
 /plugins/hls-explicit-imports-plugin @pepeiborra
 /plugins/hls-floskell-plugin @Ailrun
 /plugins/hls-fourmolu-plugin @georgefst
+/plugins/hls-gadt-plugin @July541
 /plugins/hls-haddock-comments-plugin @berberman
 /plugins/hls-hlint-plugin @jneira @eddiemundo
 /plugins/hls-module-name-plugin

cabal.project

@@ -28,6 +28,7 @@ packages:
          ./plugins/hls-qualify-imported-names-plugin
          ./plugins/hls-selection-range-plugin
          ./plugins/hls-change-type-signature-plugin
+         ./plugins/hls-gadt-plugin
 
 -- Standard location for temporary packages needed for particular environments
 -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script

docs/features.md

@@ -256,7 +256,19 @@ Known Limitations:
 
 ![Change Type Signature Demo](../plugins/hls-change-type-signature-plugin/change2.gif)
 
-[Link to Docs](../plugins/hls-change-type-signature/README.md)
+![Link to Docs](../plugins/hls-change-type-signature-plugin/README.md)
+
+### Convert to GADT syntax
+
+Provided by: `hls-gadt-plugin`
+
+Code action kind: `refactor.rewrite`
+
+Convert a datatype to GADT syntax.
+
+![GADT Demo](../plugins/hls-gadt-plugin/gadt.gif)
+
+![Link to Docs](../plugins/hls-gadt-plugin/README.md)
 
 ## Code lenses
 

docs/supported-versions.md

@@ -55,6 +55,7 @@ Sometimes a plugin will be supported in the prebuilt binaries but not in a HLS b
 | `hls-stylish-haskell-plugin`        |                          |
 | `hls-tactics-plugin`                | 9.2                      |
 | `hls-selection-range-plugin`        |                          |
+| `hls-gadt-plugin`                   |                          |
 
 ### Using deprecated GHC versions
 

exe/Plugins.hs

@@ -82,6 +82,10 @@ import           Ide.Plugin.SelectionRange         as SelectionRange
 #if changeTypeSignature
 import           Ide.Plugin.ChangeTypeSignature    as ChangeTypeSignature
 #endif
+
+#if gadt
+import           Ide.Plugin.GADT                   as GADT
+#endif
 -- formatters
 
 #if floskell
@@ -190,6 +194,9 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
 #endif
 #if changeTypeSignature
       ChangeTypeSignature.descriptor "changeTypeSignature" :
+#endif
+#if gadt
+      GADT.descriptor "gadt" :
 #endif
     -- The ghcide descriptors should come last so that the notification handlers
     -- (which restart the Shake build) run after everything else

haskell-language-server.cabal

@@ -186,6 +186,11 @@ flag changeTypeSignature
   default:     True
   manual:      True
 
+flag gadt
+  description: Enable gadt plugin
+  default:     True
+  manual:      True
+
 -- formatters
 
 flag floskell
@@ -308,6 +313,11 @@ common changeTypeSignature
     build-depends: hls-change-type-signature-plugin ^>= 1.0
     cpp-options: -DchangeTypeSignature
 
+common gadt
+  if flag(gadt)
+    build-depends: hls-gadt-plugin ^>= 1.0
+    cpp-options: -Dgadt
+
 -- formatters
 
 common floskell
@@ -359,6 +369,7 @@ executable haskell-language-server
                     , alternateNumberFormat
                     , qualifyImportedNames
                     , selectionRange
+                    , gadt
                     , floskell
                     , fourmolu
                     , ormolu

hls-plugin-api/src/Ide/PluginUtils.hs

@@ -56,7 +56,6 @@ import           Language.LSP.Types              hiding
                                                   SemanticTokensEdit (_start))
 import qualified Language.LSP.Types              as J
 import           Language.LSP.Types.Capabilities
-import           Language.LSP.Types.Lens         (uri)
 
 -- ---------------------------------------------------------------------
 

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

@@ -40,6 +40,7 @@ module Test.Hls.Util
     , waitForDiagnosticsFromSourceWithTimeout
     , withCurrentDirectoryInTmp
     , withCurrentDirectoryInTmp'
+    , withCanonicalTempDir
   )
 where
 
@@ -54,16 +55,17 @@ import           Data.Default
 import           Data.List.Extra                 (find)
 import qualified Data.Set                        as Set
 import qualified Data.Text                       as T
-import           Development.IDE                 (GhcVersion(..), ghcVersion)
+import           Development.IDE                 (GhcVersion (..), ghcVersion)
 import qualified Language.LSP.Test               as Test
 import           Language.LSP.Types              hiding (Reason (..))
 import qualified Language.LSP.Types.Capabilities as C
 import qualified Language.LSP.Types.Lens         as L
 import           System.Directory
 import           System.Environment
 import           System.FilePath
-import           System.IO.Temp
 import           System.Info.Extra               (isMac, isWindows)
+import qualified System.IO.Extra
+import           System.IO.Temp
 import           System.Time.Extra               (Seconds, sleep)
 import           Test.Tasty                      (TestTree)
 import           Test.Tasty.ExpectedFailure      (expectFailBecause,
@@ -253,7 +255,7 @@ onMatch :: [a] -> (a -> Bool) -> String -> IO a
 onMatch as predicate err = maybe (fail err) return (find predicate as)
 
 noMatch :: [a] -> (a -> Bool) -> String -> IO ()
-noMatch [] _ _ = pure ()
+noMatch [] _ _           = pure ()
 noMatch as predicate err = bool (pure ()) (fail err) (any predicate as)
 
 inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic
@@ -384,3 +386,10 @@ getCompletionByLabel desiredLabel compls =
         Nothing -> liftIO . assertFailure $
             "Completion with label " <> show desiredLabel
             <> " not found in " <> show (fmap (^. L.label) compls)
+
+-- ---------------------------------------------------------------------
+-- Run with a canonicalized temp dir
+withCanonicalTempDir :: (FilePath -> IO a) -> IO a
+withCanonicalTempDir f = System.IO.Extra.withTempDir $ \dir -> do
+  dir' <- canonicalizePath dir
+  f dir'

plugins/hls-call-hierarchy-plugin/test/Main.hs

@@ -19,6 +19,7 @@ import           System.Directory.Extra
 import           System.FilePath
 import qualified System.IO.Extra
 import           Test.Hls
+import           Test.Hls.Util            (withCanonicalTempDir)
 
 plugin :: PluginDescriptor IdeState
 plugin = descriptor "callHierarchy"
@@ -319,7 +320,7 @@ outgoingCallsTests =
   testGroup "Outgoing Calls"
   [ testGroup "single file"
     [
-      testCase "xdata unavailable" $ withTempDir $ \dir ->
+      testCase "xdata unavailable" $ withCanonicalTempDir $ \dir ->
         runSessionWithServer plugin dir $ do
           doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"]
           waitForKickDone
@@ -423,7 +424,7 @@ deriving instance Ord CallHierarchyIncomingCall
 deriving instance Ord CallHierarchyOutgoingCall
 
 incomingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion
-incomingCallTestCase contents queryX queryY positions ranges = withTempDir $ \dir ->
+incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir ->
   runSessionWithServer plugin dir $ do
     doc <- createDoc "A.hs" "haskell" contents
     waitForKickDone
@@ -465,7 +466,7 @@ incomingCallMultiFileTestCase filepath queryX queryY mp =
     closeDoc doc
 
 outgoingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion
-outgoingCallTestCase contents queryX queryY positions ranges = withTempDir $ \dir ->
+outgoingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir ->
   runSessionWithServer plugin dir $ do
     doc <- createDoc "A.hs" "haskell" contents
     waitForKickDone
@@ -505,7 +506,7 @@ outgoingCallMultiFileTestCase filepath queryX queryY mp =
     closeDoc doc
 
 oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem) -> Assertion
-oneCaseWithCreate contents queryX queryY expected = withTempDir $ \dir ->
+oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir ->
   runSessionWithServer plugin dir $ do
     doc <- createDoc "A.hs" "haskell" contents
     waitForKickDone
@@ -544,8 +545,3 @@ mkIncomingCallsParam = CallHierarchyIncomingCallsParams Nothing Nothing
 
 mkOutgoingCallsParam :: CallHierarchyItem -> CallHierarchyOutgoingCallsParams
 mkOutgoingCallsParam = CallHierarchyOutgoingCallsParams Nothing Nothing
-
-withTempDir :: (FilePath -> IO a) -> IO a
-withTempDir f = System.IO.Extra.withTempDir $ \dir -> do
-  dir' <- canonicalizePath dir
-  f dir'