Case split plugin

.github/workflows/test.yml

@@ -267,6 +267,10 @@ jobs:
         name: Test hls-export-plugin test suite
         run: cabal test ${CABAL_ARGS} hls-export-plugin-tests || cabal test ${CABAL_ARGS} hls-export-plugin-tests
 
+      - if: matrix.test && matrix.ghc == '9.14'
+        name: Test hls-case-split-plugin test suite
+        run: cabal test ${CABAL_ARGS} hls-case-split-plugin-tests || cabal test ${CABAL_ARGS} hls-case-split-plugin-tests
+
   test_post_job:
     if: always()
     runs-on: ubuntu-latest

cabal.project

@@ -6,7 +6,7 @@ packages:
          ./hls-plugin-api
          ./hls-test-utils
 
-index-state: 2026-07-30T14:41:11Z
+index-state: 2026-08-07T04:49:30Z
 
 tests: True
 test-show-details: direct

ghcide/src/Development/IDE/GHC/Compat/Error.hs

@@ -26,6 +26,7 @@ module Development.IDE.GHC.Compat.Error (
   _TcRnMessageWithCtx,
   _GhcPsMessage,
   _GhcDsMessage,
+  _DsMessage,
   _GhcDriverMessage,
   _ReportHoleError,
   _TcRnIllegalWildcardInType,
@@ -80,6 +81,11 @@ _GhcDsMessage = prism' GhcDsMessage (\case
   GhcDsMessage dsMsg -> Just dsMsg
   _ -> Nothing)
 
+_DsMessage :: Fold GhcMessage DsMessage
+_DsMessage = prism' GhcDsMessage $ \case
+  GhcDsMessage dsmsg -> Just dsmsg
+  _ -> Nothing
+
 _GhcDriverMessage :: Prism' GhcMessage DriverMessage
 _GhcDriverMessage = prism' GhcDriverMessage (\case
   GhcDriverMessage driverMsg -> Just driverMsg

haskell-language-server.cabal

@@ -575,6 +575,58 @@ test-suite hls-explicit-imports-plugin-tests
     , lsp-types
     , text
 
+-----------------------------
+-- case split plugin
+-----------------------------
+
+flag caseSplit
+  description: Enable caseSplit plugin
+  default:     True
+  manual:      True
+
+common caseSplit
+  if flag(casesplit) && !impl(ghc < 9.14)
+    build-depends: haskell-language-server:hls-case-split-plugin
+    cpp-options: -Dhls_caseSplit
+
+library hls-case-split-plugin
+  import:           defaults, pedantic, warnings
+  if !flag(casesplit) || impl(ghc < 9.14)
+    buildable: False
+  exposed-modules:  Ide.Plugin.CaseSplit
+  hs-source-dirs:   plugins/hls-case-split-plugin/src
+  build-depends:
+    , extra
+    , ghc
+    , haskell-language-server:hls-refactor-plugin
+    , ghcide                == 2.14.0.0
+    , hls-plugin-api        == 2.14.0.0
+    , lens
+    , lsp
+    , mtl
+    , syb
+    , text
+    , transformers
+    , ghc-exactprint        >= 1.14.1.0
+
+  default-extensions:
+    DataKinds
+
+test-suite hls-case-split-plugin-tests
+  import:           defaults, pedantic, test-defaults, warnings
+  if !flag(casesplit) || impl(ghc < 9.14)
+    buildable: False
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   plugins/hls-case-split-plugin/test
+  main-is:          Main.hs
+  build-depends:
+    , filepath
+    , haskell-language-server:hls-case-split-plugin
+    , hls-test-utils   == 2.14.0.0
+    , lens
+    , lsp-types
+    , text
+
 -----------------------------
 -- rename plugin
 -----------------------------
@@ -1853,6 +1905,7 @@ library
                   , class
                   , eval
                   , importLens
+                  , caseSplit
                   , rename
                   , hlint
                   , stan

plugins/hls-case-split-plugin/test/Main.hs

@@ -0,0 +1,177 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main
+  ( main
+  ) where
+
+import           Control.Lens                  (Prism', prism', (^.),
+                                                (^..), (^?))
+import           Data.Foldable                 (find)
+import qualified Data.Text                     as T
+import qualified Ide.Plugin.CaseSplit          as CS
+import qualified Language.LSP.Protocol.Lens    as L
+import           System.FilePath
+import           Test.Hls                      hiding (waitForDiagnosticsFrom)
+import qualified Test.Hls.FileSystem           as FS
+
+main :: IO ()
+main = defaultTestRunner tests
+
+caseSplitPlugin :: PluginTestDescriptor CS.Log
+caseSplitPlugin = mkPluginTestDescriptor CS.descriptor "case split"
+
+tests :: TestTree
+tests = testGroup
+  "case split"
+  [ codeActionTests
+  ]
+
+codeActionTests :: TestTree
+codeActionTests = testGroup
+  "code actions" $ let title = CS.caseSplitPluginCodeActionTitle in
+  [ goldenWithClass "No patterns, no braces" "TNoPatternsNoBraces" $
+      getActionByTitle title
+  , goldenWithClass "Some patterns, no braces" "TSomePatternsNoBraces" $
+      getActionByTitle title
+  , goldenWithClass "Some patterns, with braces" "TSomePatternsWithBraces" $
+      getActionByTitle title
+  , goldenWithClass "No patterns, with braces" "TNoPatternsWithBraces" $
+      getActionByTitle title
+
+  -- Patterns with irregular indentation
+  , goldenWithClass "Jagged patterns, no braces" "TJaggedNoBraces" $
+      getActionByTitle title
+  , goldenWithClass "Jagged patterns, with braces" "TJaggedWithBraces" $
+      getActionByTitle title
+
+  -- Patterns on one line
+  , goldenWithClass "Some patterns on one line, no braces" "TSomePatternsOnOneLineNoBraces" $
+      getActionByTitle title
+  , goldenWithClass "Some patterns on one line, with braces" "TSomePatternsOnOneLineWithBraces" $
+      getActionByTitle title
+
+  -- Records
+  , goldenWithClass "Records' field names are ignored" "TRecordsFieldNamesIgnored" $
+      getActionByTitle title
+  , goldenWithClass "Too many fields are collapsed" "TManyFields" $
+      getActionByTitle title
+
+  -- GADTs
+  , goldenWithClass "GADT - simple" "TGADTsimple" $
+      getActionByTitle title
+  , goldenWithClass "GADT - advanced" "TGADTadvanced" $
+      getActionByTitle title
+
+  -- LambdaCase
+  , goldenWithClass "LambdaCase, no patterns, no braces" "TLambdaCaseNoPatternsNoBraces" $
+      getActionByTitle title
+  , goldenWithClass "LambdaCase, no patterns, with braces" "TLambdaCaseNoPatternsWithBraces" $
+      getActionByTitle title
+  , goldenWithClass "LambdaCase, some patterns, no braces" "TLambdaCaseSomePatternsNoBraces" $
+      getActionByTitle title
+  , goldenWithClass "LambdaCase, some patterns, with braces" "TLambdaCaseSomePatternsWithBraces" $
+      getActionByTitle title
+  , goldenWithClass "LambdaCase in `do`, no patterns, no braces" "TLambdaCaseInDoNoPatternsNoBraces" $
+      getActionByTitle title
+  , goldenWithClass "LambdaCase in `do`, no patterns, with braces" "TLambdaCaseInDoNoPatternsWithBraces" $
+      getActionByTitle title
+  , goldenWithClass "LambdaCase in `do`, some patterns, no braces" "TLambdaCaseInDoSomePatternsNoBraces" $
+      getActionByTitle title
+  , goldenWithClass "LambdaCase in `do`, some patterns, with braces" "TLambdaCaseInDoSomePatternsWithBraces" $
+      getActionByTitle title
+
+  -- Inside where
+  , expectNoCodeActionAvailable "Inside `where`, without signature" "TInsideWhereWithoutSignature"
+  , goldenWithClass "Inside `where`" "TInsideWhere" $
+      getActionByTitle title
+  , goldenWithClass "Inside nested `where`" "TInsideNestedWhere" $
+      getActionByTitle title
+
+  -- Overlapping diagnostics
+  , goldenWithClass "Expression is `_`" "TExpressionIsUnderscore" $
+      getActionByTitle title
+  , goldenWithRange "Overlapping pattern matches" "TOverlappingExistingPatterns" $
+      Range (Position 15 4) (Position 15 5)
+
+  -- Inside let
+  , goldenWithClass "Inside `let`'s declarations" "TInsideLetDeclarations" $
+      getActionByTitle title
+  , goldenWithClass "Inside `let`'s expression" "TInsideLetExpression" $
+      getActionByTitle title
+
+  -- Inside do
+  , goldenWithClass "Inside `let`'s declarations inside `do`" "TInsideLetDeclarationsInsideDo" $
+      getActionByTitle title
+  , goldenWithClass "Inside `let`'s expression inside `do`" "TInsideLetExpressionInsideDo" $
+      getActionByTitle title
+  , goldenWithClass "Inside `do`" "TInsideDo" $
+      getActionByTitle title
+
+  -- Nested case expressions
+  , goldenWithClass "Complete `case` nested in incomplete `case`" "TCompleteCaseInsideIncompleteCase" $
+      getActionByTitle title
+  , goldenWithRange "Incomplete `case` nested in complete `case`" "TIncompleteCaseInsideCompleteCase" $
+      Range (Position 15 16) (Position 15 17)
+  , goldenWithRange "Incomplete `case` nested in incomplete `case`" "TIncompleteCaseInsideIncompleteCase" $
+      Range (Position 15 30) (Position 15 31)
+
+  -- Support UnicodeSyntax
+  , goldenWithClass "Use → instead of -> when UnicodeSyntax is On" "TUnicodeArrow" $
+      getActionByTitle title
+  ]
+
+waitForDiagnosticsFrom :: TextDocumentIdentifier -> Session [Diagnostic]
+waitForDiagnosticsFrom doc = do
+    diagsNot <- skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)
+    let diags = diagsNot ^. L.params . L.diagnostics
+    if doc ^. L.uri /= diagsNot ^. L.params . L.uri
+       || ((not .) . any) ((\case Just (InR "GHC-62161") -> True
+                                  _ -> False) . (^. L.code)) diags
+       then waitForDiagnosticsFrom doc
+       else return diags
+
+_CACodeAction :: Prism' (Command |? CodeAction) CodeAction
+_CACodeAction = prism' InR $ \case
+  InR action -> Just action
+  _          -> Nothing
+
+goldenWithRange :: TestName -> FilePath -> Range -> TestTree
+goldenWithRange title path range =
+  goldenWithHaskellDocInTmpDir def caseSplitPlugin title (mkFs $ FS.directProject (path <.> "hs")) path "expected" "hs" $ \doc -> do
+    _ <- waitForDiagnosticsFrom doc
+    [action] <- concatMap (^.. _CACodeAction) <$> getCodeActions doc range
+    executeCodeAction action
+
+goldenWithClass :: TestName -> FilePath -> ([CodeAction] -> Session CodeAction) -> TestTree
+goldenWithClass title path findAction =
+  goldenWithHaskellDocInTmpDir def caseSplitPlugin title (mkFs $ FS.directProject (path <.> "hs")) path "expected" "hs" $ \doc -> do
+    _ <- waitForDiagnosticsFrom doc
+    actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc
+    action <- findAction actions
+    executeCodeAction action
+
+getActionByTitle :: T.Text -> [CodeAction] -> Session CodeAction
+getActionByTitle title actions =
+  case find (\a -> a ^. L.title == title) actions of
+    Just a -> pure a
+    Nothing -> liftIO $ assertFailure $ "Action " <> show title <> " not found in " <> show [a ^. L.title | a <- actions]
+
+expectNoCodeActionAvailable :: TestName -> FilePath -> TestTree
+expectNoCodeActionAvailable title path =
+  testCase title $ do
+    runSessionWithServerInTmpDir def caseSplitPlugin (mkFs $ FS.directProject (path <.> "hs")) $ do
+      doc <- openDoc (path <.> "hs") "haskell"
+      _ <- waitForDiagnosticsFrom doc
+      caResults <- getAllCodeActions doc
+      liftIO $ map (^? _CACodeAction . L.title) caResults
+        @?= expectedActions
+    where
+      expectedActions = []
+
+testDataDir :: FilePath
+testDataDir = "plugins" </> "hls-case-split-plugin" </> "test" </> "testdata"
+
+mkFs :: [FS.FileTree] -> FS.VirtualFileTree
+mkFs = FS.mkVirtualFileTree testDataDir

plugins/hls-case-split-plugin/test/testdata/TCompleteCaseInsideIncompleteCase.expected.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE EmptyCase #-}
+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}
+{-# LANGUAGE OrPatterns #-}
+module T1 where
+
+data X = A
+       | B
+       | C Int
+       | D Int Int
+       | E
+       | F
+
+foo :: X -> Int
+foo x = case x of
+          A -> 3
+          a@(B; C _) -> case a of
+                 B -> 3
+                 C _ -> 4
+          D _ _ -> _
+          E -> _
+          F -> _

plugins/hls-case-split-plugin/test/testdata/TCompleteCaseInsideIncompleteCase.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE EmptyCase #-}
+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}
+{-# LANGUAGE OrPatterns #-}
+module T1 where
+
+data X = A
+       | B
+       | C Int
+       | D Int Int
+       | E
+       | F
+
+foo :: X -> Int
+foo x = case x of
+          A -> 3
+          a@(B; C _) -> case a of
+                 B -> 3
+                 C _ -> 4

plugins/hls-case-split-plugin/test/testdata/TExpressionIsUnderscore.expected.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE EmptyCase #-}
+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}
+module T1 where
+
+data X = A
+       | B
+       | C Int
+       | D Int Int
+       | E
+       | F
+
+foo :: Int
+foo = case      _     :: X of
+  A -> _
+  B -> _
+  C _ -> _
+  D _ _ -> _
+  E -> _
+  F -> _

plugins/hls-case-split-plugin/test/testdata/TExpressionIsUnderscore.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE EmptyCase #-}
+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}
+module T1 where
+
+data X = A
+       | B
+       | C Int
+       | D Int Int
+       | E
+       | F
+
+foo :: Int
+foo = case      _     :: X of

plugins/hls-case-split-plugin/test/testdata/TGADTadvanced.expected.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE EmptyCase #-}
+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}
+{-# LANGUAGE GADTs #-}
+module T1 where
+
+data Expr a where
+    LitInt :: Int -> Expr Int
+    LitBool :: Bool -> Expr Bool
+    Add :: Expr Int -> Expr Int -> Expr Int
+    Not :: Expr Bool -> Expr Bool
+    If :: Expr Bool -> Expr a -> Expr a -> Expr a
+
+prettyExpr :: Expr Bool -> String
+prettyExpr expr = case expr of
+  LitBool _ -> _
+  Not _ -> _
+  If _ _ _ -> _

plugins/hls-case-split-plugin/test/testdata/TGADTadvanced.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE EmptyCase #-}
+{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-}
+{-# LANGUAGE GADTs #-}
+module T1 where
+
+data Expr a where
+    LitInt :: Int -> Expr Int
+    LitBool :: Bool -> Expr Bool
+    Add :: Expr Int -> Expr Int -> Expr Int
+    Not :: Expr Bool -> Expr Bool
+    If :: Expr Bool -> Expr a -> Expr a -> Expr a
+
+prettyExpr :: Expr Bool -> String
+prettyExpr expr = case expr of