Merge branch 'master' into type-signature

Author: July541

.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/installation.md

@@ -110,7 +110,7 @@ In addition make sure `haskell-language-server.exe` is not running by closing yo
 ### Download the source code
 
 ```bash
-git clone https://github.com/haskell/haskell-language-server --recurse-submodules
+git clone https://github.com/haskell/haskell-language-server
 cd haskell-language-server
 ```
 

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

ghcide/src/Development/IDE/Plugin/CodeAction.hs

@@ -1561,15 +1561,57 @@ mkRenameEdit contents range name =
 -- require understanding both the precedence of the context of the hole and of
 -- the signature itself. Inserting them (almost) unconditionally is ugly but safe.
 extractWildCardTypeSignature :: T.Text -> T.Text
-extractWildCardTypeSignature msg = (if enclosed || not application then id else bracket) signature
+extractWildCardTypeSignature msg
+  | enclosed || not isApp || isToplevelSig = sig
+  | otherwise                              = "(" <> sig <> ")"
   where
-    msgSigPart = snd $ T.breakOnEnd "standing for " msg
-    signature = T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart
-    -- parenthesize type applications, e.g. (Maybe Char)
-    application = any isSpace . T.unpack $ signature
-    -- do not add extra parentheses to lists, tuples and already parenthesized types
-    enclosed = not (T.null signature) && (T.head signature, T.last signature) `elem` [('(',')'), ('[',']')]
-    bracket = ("(" `T.append`) . (`T.append` ")")
+    msgSigPart      = snd $ T.breakOnEnd "standing for " msg
+    (sig, rest)     = T.span (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart
+    -- If we're completing something like ‘foo :: _’ parens can be safely omitted.
+    isToplevelSig   = errorMessageRefersToToplevelHole rest
+    -- Parenthesize type applications, e.g. (Maybe Char).
+    isApp           = T.any isSpace sig
+    -- Do not add extra parentheses to lists, tuples and already parenthesized types.
+    enclosed        = not (T.null sig) && (T.head sig, T.last sig) `elem` [('(', ')'), ('[', ']')]
+
+-- | Detect whether user wrote something like @foo :: _@ or @foo :: (_, Int)@.
+-- The former is considered toplevel case for which the function returns 'True',
+-- the latter is not toplevel and the returned value is 'False'.
+--
+-- When type hole is at toplevel then there’s a line starting with
+-- "• In the type signature" which ends with " :: _" like in the
+-- following snippet:
+--
+-- source/library/Language/Haskell/Brittany/Internal.hs:131:13: error:
+--     • Found type wildcard ‘_’ standing for ‘HsDecl GhcPs’
+--       To use the inferred type, enable PartialTypeSignatures
+--     • In the type signature: decl :: _
+--       In an equation for ‘splitAnnots’:
+--           splitAnnots m@HsModule {hsmodAnn, hsmodDecls}
+--             = undefined
+--             where
+--                 ann :: SrcSpanAnnA
+--                 decl :: _
+--                 L ann decl = head hsmodDecls
+--     • Relevant bindings include
+--       [REDACTED]
+--
+-- When type hole is not at toplevel there’s a stack of where
+-- the hole was located ending with "In the type signature":
+--
+-- source/library/Language/Haskell/Brittany/Internal.hs:130:20: error:
+--     • Found type wildcard ‘_’ standing for ‘GhcPs’
+--       To use the inferred type, enable PartialTypeSignatures
+--     • In the first argument of ‘HsDecl’, namely ‘_’
+--       In the type ‘HsDecl _’
+--       In the type signature: decl :: HsDecl _
+--     • Relevant bindings include
+--       [REDACTED]
+errorMessageRefersToToplevelHole :: T.Text -> Bool
+errorMessageRefersToToplevelHole msg =
+  not (T.null prefix) && " :: _" `T.isSuffixOf` T.takeWhile (/= '\n') rest
+  where
+    (prefix, rest) = T.breakOn "• In the type signature:" msg
 
 extractRenamableTerms :: T.Text -> [T.Text]
 extractRenamableTerms msg

ghcide/test/exe/Main.hs

@@ -1196,7 +1196,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
         [ "func :: _"
         , "func x = x"
         ]
-        [ "func :: (p -> p)"
+        [ "func :: p -> p"
         , "func x = x"
         ]
   , testUseTypeSignature "local signature"
@@ -1212,11 +1212,11 @@ typeWildCardActionTests = testGroup "type wildcard actions"
         , "      y = x * 2"
         , "  in y"
         ]
-  , testUseTypeSignature "multi-line message"
+  , testUseTypeSignature "multi-line message 1"
         [ "func :: _"
         , "func x y = x + y"
         ]
-        [ "func :: (Integer -> Integer -> Integer)"
+        [ "func :: Integer -> Integer -> Integer"
         , "func x y = x + y"
         ]
   , testUseTypeSignature "type in parentheses"
@@ -1240,6 +1240,43 @@ typeWildCardActionTests = testGroup "type wildcard actions"
         [ "func :: IO ()"
         , "func = putChar 'H'"
         ]
+  , testUseTypeSignature "no spaces around '::'"
+        [ "func::_"
+        , "func x y = x + y"
+        ]
+        [ "func::Integer -> Integer -> Integer"
+        , "func x y = x + y"
+        ]
+  , testGroup "add parens if hole is part of bigger type"
+    [ testUseTypeSignature "subtype 1"
+          [ "func :: _ -> Integer -> Integer"
+          , "func x y = x + y"
+          ]
+          [ "func :: Integer -> Integer -> Integer"
+          , "func x y = x + y"
+          ]
+    , testUseTypeSignature "subtype 2"
+          [ "func :: Integer -> _ -> Integer"
+          , "func x y = x + y"
+          ]
+          [ "func :: Integer -> Integer -> Integer"
+          , "func x y = x + y"
+          ]
+    , testUseTypeSignature "subtype 3"
+          [ "func :: Integer -> Integer -> _"
+          , "func x y = x + y"
+          ]
+          [ "func :: Integer -> Integer -> Integer"
+          , "func x y = x + y"
+          ]
+    , testUseTypeSignature "subtype 4"
+          [ "func :: Integer -> _"
+          , "func x y = x + y"
+          ]
+          [ "func :: Integer -> (Integer -> Integer)"
+          , "func x y = x + y"
+          ]
+    ]
   ]
   where
     -- | Test session of given name, checking action "Use type signature..."

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'