diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 37ca30f9e1..4a8aacf046 100644 --- a/.github/workflows/test.yml +++ b/.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 diff --git a/cabal.project b/cabal.project index 7996bfaaed..dbbe25a486 100644 --- a/cabal.project +++ b/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 diff --git a/docs/features.md b/docs/features.md index dfbb7e1c2c..0bd21bd0d2 100644 --- a/docs/features.md +++ b/docs/features.md @@ -125,6 +125,15 @@ Provided by: `hls-pragmas-plugin` Completions for language pragmas. +### `case`/`\case` pattern completion + +Provided by: `hls-case-split-plugin` + +Completion of the patterns of a `case`/`\case` expression. + +Note: The number of patterns that are inserted is limited to the value of +`-fmax-uncovered-patterns` plus 1. + ## Formatting Format your code with various Haskell code formatters. diff --git a/ghcide/src/Development/IDE/GHC/Compat/Error.hs b/ghcide/src/Development/IDE/GHC/Compat/Error.hs index 85f98a3878..622bda2bfc 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Error.hs +++ b/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 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 703b5f9589..22343f5eb9 100644 --- a/haskell-language-server.cabal +++ b/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 diff --git a/plugins/hls-case-split-plugin/src/Ide/Plugin/CaseSplit.hs b/plugins/hls-case-split-plugin/src/Ide/Plugin/CaseSplit.hs new file mode 100644 index 0000000000..4623ccd5a9 --- /dev/null +++ b/plugins/hls-case-split-plugin/src/Ide/Plugin/CaseSplit.hs @@ -0,0 +1,749 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OrPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.CaseSplit + ( caseSplitPluginCodeActionTitle + , descriptor + , Log + ) where + +import Control.Applicative (ZipList (ZipList, getZipList)) +import Control.Arrow ((&&&)) +import Control.Lens ((^.), (^?)) +import Control.Monad (mzero, when, (>=>)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.State.Strict (MonadState (get, put), + State, evalState) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) +import Data.Data (Data) +import Data.Function (on, (&)) +import Data.Generics.Schemes (everywhereM) +import Data.List.Extra (chunksOf, dropEnd, + takeEnd) +import Data.List.NonEmpty (NonEmpty ((:|)), + nonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty.Extra ((|:)) +import Data.Maybe (isJust, isNothing, + listToMaybe, mapMaybe, + maybeToList) +import Data.Semigroup (sconcat) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE (FileDiagnostic (fdStructuredMessage), + GetParsedModule (GetParsedModule), + GhcSessionDeps (GhcSessionDeps), + HscEnvEq (hscEnv), + IdeState (shakeExtras), + Pretty (pretty), + Recorder, WithPriority, + runAction, + srcSpanToRange) +import Development.IDE.Core.FileStore (getVersionedTextDoc) +import Development.IDE.Core.PluginUtils (activeDiagnosticsInRange, + runActionE, useE) +import Development.IDE.GHC.Compat (ConLike (RealDataCon), + HoleKind (HoleVar), + HsMatchContext (CaseAlt), + HscEnv (hsc_dflags), Id, + NamedThing (getName), + getLoc) +import Development.IDE.GHC.Compat.Core (AnnListItem, + EpAnnHsCase (EpAnnHsCase), + GrhsAnn (..), + HasSrcSpan, + HsLamVariant (LamCase), + HsMatchContext (LamAlt), + LocatedAn, + lann_trailing, + srcSpanStartCol, + srcSpanStartLine) +import qualified Development.IDE.GHC.Compat.Core as Ext +import Development.IDE.GHC.Compat.Error (DsMessage (DsNonExhaustivePatterns), + _DsMessage, + msgEnvelopeErrorL) +import Development.IDE.GHC.Compat.ExactPrint (d0, d1, exactPrint, + getEntryDP, + noAnnSrcSpanDP1, + setEntryDP) +import Development.IDE.Types.Diagnostics (FileDiagnostic (fdLspDiagnostic), + _SomeStructuredMessage) +import GHC (AnnList (AnnList), + AnnListBrackets (ListBraces), + DynFlags (extensions), + EpAnn (EpAnn), + EpToken (EpTok), + HasLoc (getHasLoc), + LMatch, + ParsedModule (pm_parsed_source), + ParsedSource, + realSrcSpan) +import GHC.Driver.DynFlags (OnOff (On)) +import GHC.Hs (DeltaPos (deltaColumn), + EpAnnLam (EpAnnLam), + GhcPs, + HsRecFields (HsRecFields), + XCase, XLam, deltaPos, + getDeltaLine, + unnamedHoleRdrName) +import GHC.HsToCore.Pmc.Solver.Types (Nabla (nabla_tm_st), + PmAltCon (..), + PmAltConApp (..), + TmState (ts_facts), + VarInfo (vi_pos)) +import GHC.Parser.Annotation (EpUniToken (EpUniTok), + IsUnicodeSyntax (NormalSyntax, UnicodeSyntax), + TrailingAnn (AddSemiAnn), + addTrailingAnnToA, + emptyComments, + noSrcSpanA) +import GHC.Types.Name.Reader (nameRdrName) +import GHC.Types.SrcLoc (GenLocated (L), + SrcSpan (RealSrcSpan), + combineSrcSpans) +import GHC.Types.Unique.SDFM (lookupUSDFM) +import Ide.Logger (Priority (Error), + logWith) +import Ide.Plugin.Error (PluginError, + getNormalizedFilePathE) +import Ide.PluginUtils (WithDeletions (IncludeDeletions), + diffText) +import Ide.Types (Config, HandlerM, + PluginDescriptor (pluginHandlers), + PluginId, + PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler, + pluginGetClientCapabilities) +import Language.Haskell.Syntax (HsConDetails (PrefixCon, RecCon), + HsLocalBindsLR (EmptyLocalBinds), + LHsExpr, + MatchGroup (MG, mg_alts), + NoExtField (NoExtField), + Pat (..)) +import Language.Haskell.Syntax.Expr (GRHS (GRHS), + GRHSs (GRHSs), + HsExpr (HsCase, HsHole, HsLam), + Match (..)) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeAction)) +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types (ClientCapabilities, + CodeAction (..), + CodeActionKind (CodeActionKind_QuickFix), + CodeActionParams (CodeActionParams, _range, _textDocument), + Diagnostic, + NormalizedFilePath, + Range, + TextDocumentIdentifier, + VersionedTextDocumentIdentifier, + WorkspaceEdit, + isSubrangeOf, + type (|?) (InL, InR)) +import qualified Language.LSP.Protocol.Types as Diag (Diagnostic (_range)) +import Type.Reflection (eqTypeRep, + type (:~~:) (HRefl), + typeOf, typeRep) + + +{- Note [Implementation strategy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The present plugin achieves its target of inserting the missing patterns to a + non-exhaustive @case@ (or @\case@) expression via the following strategy: + + 1. retrieve the '[FileDiagnostic]' under the cursor, + + 2. extract the 'Diagnostic' and the 'NonEmpty' list of missing + 'PmAltConApp' from the innermost "non-exhaustive patterns" diagnostic + (several can be nested, in general), + + 3. retrieve some context from the handler monad (e.g. the 'ParsedSource' + describing the AST, and whether the 'UnicodeSyntax' extension is in + use), + + 4. craft a 'CodeAction' from the output of steps 2 and 3, and return it, + + 5. fail by returning an empty list of actions if anything goes wrong. + +-} + +data Log where + LogASTUpdateError :: Log + +instance Pretty Log where + pretty LogASTUpdateError = "Error in updating the AST." + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId "Provides the split case code action") + { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction (suggestCaseSplitProvider recorder) + } + +caseSplitPluginCodeActionTitle :: Text +caseSplitPluginCodeActionTitle = "Add placeholders for missing patterns" + +suggestCaseSplitProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction +suggestCaseSplitProvider recorder state _ CodeActionParams{ _textDocument, _range = cursor } = do + + nfp <- getNormalizedFilePathE $ _textDocument ^. L.uri + + -- TODO: remove @concat <$>@ when https://github.com/haskell/haskell-language-server/pull/5041 is done. + fileDiags <- concat <$> activeDiagnosticsInRange (shakeExtras state) nfp cursor + + let diagAndMissingCtors = getInnermost $ extractDiagAndMissingCtors fileDiags + + arrowSyntax <- getArrowSyntax state nfp + psOld <- getParsedSource state nfp + caps <- lift pluginGetClientCapabilities + verTxtDocId <- lift $ getVerTxtDocId state _textDocument + + let codeAction = diagAndMissingCtors >>= makeCodeAction caps verTxtDocId psOld arrowSyntax + + when (isNothing codeAction) + $ logWith recorder Error LogASTUpdateError + + pure $ InL $ InR <$> maybeToList codeAction + + where + makeCodeAction caps verTxtDocId psOld arrowSyntax (diag, pmAltsConApps) + = do psNew <- graftMissingPatterns psOld cursor pmAltsConApps arrowSyntax + pure $ make diag $ makeEditText caps verTxtDocId psOld psNew + where + make :: Diagnostic -> WorkspaceEdit -> CodeAction + make diag edit + = CodeAction { _title = caseSplitPluginCodeActionTitle + , _kind = Just CodeActionKind_QuickFix + , _diagnostics = Just [diag] + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Just edit + , _command = Nothing + , _data_ = Nothing } + + +-- | Retrieve 'VersionedTextDocumentIdentifier' from the handler. +getVerTxtDocId :: IdeState -> TextDocumentIdentifier -> HandlerM Config VersionedTextDocumentIdentifier +getVerTxtDocId state textDoc = liftIO $ runAction "CaseSplit.GetVersionedTextDoc" state $ getVersionedTextDoc textDoc + +-- | Retrieve 'ParsedSource' from the handler. +getParsedSource :: IdeState -> NormalizedFilePath -> ExceptT PluginError (HandlerM Config) ParsedSource +getParsedSource state nfp = pm_parsed_source <$> runActionE "CaseSplit.GetParsedModule" + state + (useE GetParsedModule nfp) + +-- | Retrieve 'IsUnicodeSyntax' from the handler. +getArrowSyntax :: IdeState -> NormalizedFilePath -> ExceptT PluginError (HandlerM Config) IsUnicodeSyntax +getArrowSyntax state nfp = do + (hsc_dflags . hscEnv -> dynFlags) <- runActionE "CaseSplit.GhcSessionDeps" state $ useE GhcSessionDeps nfp + pure $ if On Ext.UnicodeSyntax `elem` extensions dynFlags + then UnicodeSyntax + else NormalSyntax + +-- | Obtain a 'WorkspaceEdit' as 'diffText' of 'exactPrint'-ed versions of old +-- and new 'ParsedSource's. +makeEditText :: ClientCapabilities -> VersionedTextDocumentIdentifier -> ParsedSource -> ParsedSource -> WorkspaceEdit +makeEditText caps verTxtDocId psOld psNew = do + let old = T.pack $ exactPrint psOld + let new = T.pack $ exactPrint psNew + diffText caps (verTxtDocId, old) new IncludeDeletions + +-- | Type synonym for slighly improved readability. +type MissingPatterns = NonEmpty PmAltConApp + +-- | Given a @[FileDiagnostic]@ retain only those relative +-- to the GHC-62161 diagnostic and extract the list of missing +-- patterns from those. +extractDiagAndMissingCtors :: [FileDiagnostic] -> [(Diagnostic, MissingPatterns)] +extractDiagAndMissingCtors = map -- For each 'FileDiagnostic', + (fdLspDiagnostic -- extract is 'Diagnostic' + &&& + -- and 'Maybe' a 'NonEmpty' list of 'PmAltConApp', + (getDsMessage >=> getPmAltConApps >=> nonEmpty)) + -- finally, discard the irrelevant diagnostics. + .> (mapMaybe sequence :: [(a, Maybe b)] -> [(a, b)]) + where + (.>) = flip (.) + + getDsMessage :: FileDiagnostic -> Maybe DsMessage + getDsMessage d = fdStructuredMessage d ^? _SomeStructuredMessage . msgEnvelopeErrorL . _DsMessage + + getPmAltConApps :: DsMessage -> Maybe [PmAltConApp] + getPmAltConApps = + \case DsNonExhaustivePatterns CaseAlt _ _ [identifier] nablas -> nablasToPmAlts identifier nablas + DsNonExhaustivePatterns (LamAlt LamCase) _ _ [identifier] nablas -> nablasToPmAlts identifier nablas + _ -> Nothing + +-- | Get the innermost (in the sense of 'isSubrangeOf') @(Diagnostic, a)@, +-- accounting for failure. +getInnermost :: [(Diagnostic, a)] -> Maybe (Diagnostic, a) +getInnermost [] = Nothing +getInnermost (a : as) = foldl' go (Just a) as + where + go Nothing _ = Nothing + go (Just acc) a = case (ordSubrange `on` Diag._range . fst) acc a of + Just GT -> Just a + Just _ -> Just acc + Nothing -> Nothing -- If non-total order, give up. + +-- | Assign an 'Ordering' to two 'Range's @r1@ and @r2@ according to the +-- 'isSubrangeOf' relationshipt between them. If neither 'isSubrangeOf' the +-- other, return `Nothing`. +ordSubrange :: Range -> Range -> Maybe Ordering +ordSubrange r1 r2 + | r1 == r2 = Just EQ + | r1 `isSubrangeOf` r2 = Just LT + | r2 `isSubrangeOf` r1 = Just GT + | otherwise = Nothing + +-- | Retrieve list of pattern match constructors +-- for the type identified by the given 'Id'. +-- +-- Relevant information at https://simon.peytonjones.org/assets/pdfs/lower-your-guards.pdf +nablasToPmAlts :: Id -> [Nabla] -> Maybe [PmAltConApp] +nablasToPmAlts identifier nablas = fmap concat $ traverse go nablas + where + go = fmap vi_pos + . flip lookupUSDFM identifier + . ts_facts + . nabla_tm_st + +-- Given a 'ParsedSource' and a 'Range' representing the cursor position into +-- it, this function uses a bottom-up traversal of the AST to detect the +-- innermost @case@/@\case@@ expression encompassing the cursor's 'Range', and +-- it appends the 'MissingPatterns' to the existing ones, if any, using the +-- syntax @->@ or @→@ depending on the provided 'IsUnicodeSyntax'. The new +-- 'ParsedSource' is returned in the 'Maybe' monad to account for failure. +-- +-- Implementation detail: since we want to update exactly one node of the AST +-- we run the computation in a 'State Bool' monad to bail out after one update. +graftMissingPatterns :: ParsedSource -> Range -> MissingPatterns -> IsUnicodeSyntax -> Maybe ParsedSource +graftMissingPatterns ps cursor missingPs arrowSyntax + = runMaybeT (everywhereM go ps) `evalState` False + where + go :: forall a. Data a => a -> MaybeT (State Bool) a + go node = do + found <- get + if | -- Proceed only if we haven't found & edited the node yet, + not found + -- only inspect nodes of the appropriate type, + , Just HRefl <- typeOf node `eqTypeRep` typeRep @(HsExpr GhcPs) + -- parse the current @case@-like expressions into a 'CaseLike' + -- (see also 'parseCaseLikeExpr' for more details), + , Just (CaseLike {..}) <- parseCaseLikeExpr node + -- make sure the 'cursor' is somewhere in the span of that + -- expression, + , cursor `inSpan` _span + -> do -- take note we've found the node, + put True + -- extract existing matches + let existingMatches = getMatchGroup _expr + -- make a match out of each missing pattern, + case traverse (makeMatch arrowSyntax) missingPs of + -- If something went wrong, we communicate abortion, + Nothing -> mzero + -- otherwise we continue + Just missingMatches -> -- by appending the missing matches to the existing ones + appendMissingPats _layout existingMatches missingMatches + -- and setting those matches in a new expression. + & setMatches _expr + & pure + -- Anything else, leave the node unchanged. + | otherwise -> pure node + + -- | Predicate telling the given 'Range' falls within the given 'SrcSpan'. + inSpan :: Range -> SrcSpan -> Bool + inSpan range s = maybe False (range `isSubrangeOf`) (srcSpanToRange s) + +-- | While @HsExpr GhcPs@ can contain any expression, the following refined +-- type can only contain a @case@ or a @\case@ expression. +data CaseLikeExpr = Case (XCase GhcPs) (LHsExpr GhcPs) (MatchGroup GhcPs (LHsExpr GhcPs)) + | LambdaCase (XLam GhcPs) (MatchGroup GhcPs (LHsExpr GhcPs)) + +-- | A 'CaseLikeExpr' enriched with the 'SrcSpan' it occupies, together with +-- its 'MatchLayout'. +data CaseLike = CaseLike { _expr :: CaseLikeExpr + , _span :: SrcSpan + , _layout :: MatchLayout + } + +-- | Get the 'MatchGroup' out of a 'CaseLikeExpr'. +getMatchGroup :: CaseLikeExpr -> MatchGroup GhcPs (LHsExpr GhcPs) +getMatchGroup (Case _ _ mg) = mg +getMatchGroup (LambdaCase _ mg) = mg + +-- | Parse an @HsCase _ _ mg@ or @HsLam _ LamCase mg@ out of a @HsExpr GhcPs@ +-- into the refined type 'ConLike'. +parseCaseLikeExpr :: HsExpr GhcPs -> Maybe CaseLike + +parseCaseLikeExpr (HsCase ext scrut matchGroup) + | EpAnnHsCase (EpTok caseTok) (EpTok ofTok) <- ext + , let caseSSpan = getHasLoc caseTok + ofSSpan = getHasLoc ofTok + , MG _ (L (EpAnn endTok _ _) _) <- matchGroup + , let endSSpan = getHasLoc endTok + span = caseExprSpan caseSSpan ofSSpan endSSpan + = Just $ CaseLike { _expr = Case ext scrut matchGroup + , _span = span + , _layout = getMatchesLayout matchGroup + } + +parseCaseLikeExpr (HsLam ext LamCase matchGroup) + | EpAnnLam (EpTok backslashTok) (Just caseTok) <- ext + , let backslashSSpan = getHasLoc backslashTok + caseSSpan = getHasLoc caseTok + , MG _ (L (EpAnn endTok _ _) _) <- matchGroup + , let endSSpan = getHasLoc endTok + span = caseExprSpan backslashSSpan caseSSpan endSSpan + = Just $ CaseLike { _expr = LambdaCase ext matchGroup + , _span = span + , _layout = getMatchesLayout matchGroup + } + +parseCaseLikeExpr _ = Nothing + +-- | Isomorphic to @Maybe Matches@, this type encodes whether a @case@-like +-- expression has braces; if it does, the type also records whether there are +-- pre-existing matches. +-- +-- See also 'Matches'. +data MatchLayout = Braced Matches | NonBraced + +-- | Isomorphic to @Maybe Int@, this type encodes whether there are +-- pre-existing matches in a @case@-like expression **with braces**, and - if +-- there are - what's the indentation of the first of them. +-- +-- Note: it could also model the same concept for the non-braced case, but that's +-- not needed (see also 'MatchLayout'). +data Matches = NoMatches | SomeMatches Int + +-- | Given a 'MatchGroup', this function returns its 'MatchLayout'. +getMatchesLayout :: MatchGroup GhcPs (LHsExpr GhcPs) -> MatchLayout +getMatchesLayout (MG { mg_alts = L altsLoc existingMatches }) + = case (getOpeningBraceCol altsLoc, getStartCol <$> listToMaybe existingMatches) of + (Nothing, _) -> NonBraced + (_, Nothing) -> Braced NoMatches + (Just openingBraceCol, Just fstExistingMatchCol) + -> let indent = fstExistingMatchCol - openingBraceCol + in Braced $ SomeMatches indent + +-- | Given a @case@ or @\case@ expression wrapped in the refined 'CaseLikeExpr' +-- type and a 'MatchGroup', it creates an actual corresponding @HsExpr GhcPs@ +-- with that 'MatchGroup' in it. +setMatches :: CaseLikeExpr -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs +setMatches (Case x s _) mg = HsCase x s mg +setMatches (LambdaCase x _) mg = HsLam x LamCase mg + +-- | Given the 'SrcSpan' of the @case@ token, the @of@ token, and the end of +-- the alternatives, this function combines them to return a 'SrcSpan' that goes +-- from the @case@ token to the end of the whole @case@ expression. +caseExprSpan :: SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan +caseExprSpan caseSSpan _ endSSpan@(RealSrcSpan _ _) = combineSrcSpans caseSSpan endSSpan +caseExprSpan caseSSpan ofSSpan _ = combineSrcSpans caseSSpan ofSSpan + +-- | Given a 'MatchGroup' and a list of 'LMatch'es, this function inserts the +-- latter matches in the former group, trying to honor the existing layout, +-- returning the new 'MatchGroup' in the 'Maybe' monad to account for failure. +-- +-- For the meaning of the first argument of type @Maybe Int@, see +-- 'getIndentation'. +-- +-- Honoring the existing layout means two things: +-- +-- 1. producing valid code, which means: +-- +-- - adding semicolons wherever they are needed, i.e. +-- +-- - if matches are braced, for every matches, +-- +-- - otherwise, for all but the last matches for groups of matches +-- that are not aligned vertically, e.g. +-- +-- - matches shown on the same line, which this plugin can produce, +-- +-- - matches shown on different lines but in a "staircase" way, +-- which this plugin never produces). +-- +-- - using the correct indentation when matches are not braced (when +-- matches are braced, the code will stay valid irrespective of the +-- indentation of the alternatives). +-- +-- 2. such valid code tries to adhere to the existing layout, which means: +-- +-- - don't alter position of existing matches nor of the opening @{@; +-- +-- - when matches are not braced, we align the first match we insert +-- with the pre-existing previous match +-- +-- - we have to make some arbitrary decision +-- +-- - when matches are not braced and no previous match exists, +-- we indent by @indentation def@ with respect to whatever layout +-- context is the current one; +-- +-- - as regards the number of matches to print per line, we inspect the +-- last group of matches appearing on one line, to determine how many +-- matches per line we insert. +-- +-- - when matches are braced, we also align them vertically (it would +-- not be necessary, in principle). +-- +-- +-- Refer to test cases to see practical examples. +appendMissingPats :: MatchLayout + -> MatchGroup GhcPs (LHsExpr GhcPs) + -> NonEmpty (LMatch GhcPs (LHsExpr GhcPs)) + -> MatchGroup GhcPs (LHsExpr GhcPs) +appendMissingPats matchLayout mg@(MG { mg_alts = L altsLoc existingMatches }) missingMatches + = let -- Choose how many patterns per line we are emitting: + chunkSize = case existingMatches of + [] -> 1 -- trivially 1 if there's no existing matches, + -- otherwise, set the size equal to the length + -- of the last group of @existingMatches@ that + -- are on the same line: + _ -> NE.length + $ NE.last + $ NE.groupBy1 startSameLine (NE.fromList existingMatches) + + -- Chunkify the matches to be inserted: + missingGroup :| missingGroups = prettyChunksOf chunkSize missingMatches + + -- Detect if the list of alternatives is between @{@ and @}@: + isBraced = isJust $ getOpeningBraceCol altsLoc + + -- Finally, lay out the missing matches: + missingMatchesEP = -- indent the first group and the following ones (see discussion above) + mapFirst indentHead missingGroup :| map (mapFirst indentTail) missingGroups + -- add a semicolon to the end of each group only if the alternatives are braced + & (if isBraced then addSemicols else id) + -- put each group on its own line + & NE.map (mapFirst putOnNewLine) + -- concatenate the groups + & sconcat + -- turn into an ordinary list + & NE.toList + where + -- add semicolons: + addSemicols = NE.zipWith ($) + -- for each one-line group of matches, + (replicate (length missingGroups) + -- only to the last match of the group, + (mapLast addSemiCol) + -- except for the last group + |: id) + + -- Indentation is complicated. + -- + -- For a non-braced @case@-like expression, the first match **of the + -- whole expression** (I mean, not the first match **to be inserted**) + -- has some anchor that depends on the surrounding code, while the + -- following matches all use their own predecessor as the anchor. + -- + -- Otherwise (i.e. for a braced @case@-like expression), all matches + -- including the first one have the same anchor that depends on the + -- surrounding code. + -- + -- Therefore, here's how we set the DeltaPos for the first and + -- following matches: + (setDPCol -> indentHead, setDPCol -> indentTail) + = case matchLayout of + NonBraced | null existingMatches -> (indentation def, 0) + NonBraced -> (0, 0) + Braced (SomeMatches indent) -> (indent, indent) + Braced NoMatches -> let indent = indentation def + in (indent, indent) + + -- Only if there's braces do we need to make sure the last of the + -- existing matches ends with @;@: + existingMatchesEP = if isBraced + then dropEnd 1 existingMatches <> (addSemiCol <$> takeEnd 1 existingMatches) + else existingMatches + + in mg { mg_alts = L altsLoc (existingMatchesEP <> missingMatchesEP) } + +-- | Accepts a @NonEmpty (LocatedAn AnnListItem a)@ and chunkifies it by the given 'size', +-- putting all matches of each chunk on the same line, leaving 1 space in between, and +-- keeping the code valid by adding semicolons to all but the last match of each chunk. +prettyChunksOf :: Int -> NonEmpty (LocatedAn AnnListItem a) -> NonEmpty (NonEmpty (LocatedAn AnnListItem a)) +prettyChunksOf size allMatches = do + -- For each chunk + chunk <- chunksOf1 size allMatches + pure $ fromZipList + $ do -- of all the matches of chunk + match <- toZipList chunk + -- from the second match onwards, they go the same line, one space apart + putBeside <- toZipList $ id :| repeat (setDP 0 1) + -- all but the last match get a semicolon + addSemicols <- toZipList $ replicate (length chunk - 1) addSemiCol |: id + -- apply + pure $ addSemicols $ putBeside match + where + toZipList = ZipList . NE.toList + fromZipList = NE.fromList . getZipList + +-- | Given a 'IsUnicodeSyntax', describing whether to use @->@ or @→@, and a +-- 'PmAltConApp', this function produces an 'LMatch' (to be inserted in the +-- list of existing 'LMatch'es contained by a 'MatchGroup'), returning it into +-- a 'Maybe' to account for failure. +-- +-- The 'LMatch' is constructed in its entirety, by passing "default" values wherever +-- possible, except, obviously, for two: +-- +-- - the constructor name, +-- - the arguments to the constructor, all rendered as individual underscores +-- when there's less than @maxUnderscores def@, or as a single @{}@ otherwise. +makeMatch :: IsUnicodeSyntax -> PmAltConApp -> Maybe (LMatch GhcPs (LHsExpr GhcPs)) +makeMatch arrow pmAltConApp = makeLMatch <$> parseSimpleConMatch arrow pmAltConApp + +parseSimpleConMatch :: IsUnicodeSyntax -> PmAltConApp -> Maybe SimpleConMatch +parseSimpleConMatch arrow PACA{ paca_con = PmAltConLike (RealDataCon dataCon) + , paca_ids + } + = let locatedCon = L noSrcSpanA $ nameRdrName $ getName dataCon + conPat = case length paca_ids of + -- for low number of arguments + n | n <= maxUnderscores def + -- create as many underscores as needed + -> ConPat { pat_con_ext = (Nothing, Nothing) + , pat_con = locatedCon + , pat_args = PrefixCon $ map (const $ L noAnnSrcSpanDP1 $ WildPat NoExtField) paca_ids + } + -- otherwise use braces. + _ -> ConPat { pat_con_ext = (Just (EpTok d1), Just (EpTok d0)) + , pat_con = locatedCon + , pat_args = RecCon (HsRecFields NoExtField [] Nothing) + } + in Just + $ SimpleConMatch { _arrow = arrow + , _conPat = conPat } + +parseSimpleConMatch _ _ = Nothing + +-- | Wrapper to the all the non-default info needed to construct an 'LMatch': +-- +-- - the arrow syntax (@->@ or @→@), +-- - the constructor pattern (e.g. @Foo _ _@ for a binary ctor). +data SimpleConMatch = SimpleConMatch { _arrow :: IsUnicodeSyntax + , _conPat :: Pat GhcPs + } + +-- | Produce an 'LMatch' using defaults for all but the information contained +-- in the given a 'SimpleConMatch'. +makeLMatch :: SimpleConMatch -> LMatch GhcPs (LHsExpr GhcPs) +makeLMatch SimpleConMatch{..} + = L noSrcSpanA $ Match { m_ext = NoExtField + , m_ctxt = CaseAlt + , m_pats = L noSrcSpanA [L noSrcSpanA _conPat] + , m_grhss = GRHSs emptyComments + -- TODO: check whether ga_sep default choice is really not printing anything. + (NE.singleton $ L noSrcSpanA $ GRHS (EpAnn noSrcSpanA + (GrhsAnn{ ga_vbar = Nothing + , ga_sep = Right $ EpUniTok d1 _arrow }) + emptyComments) [] + $ L noSrcSpanA $ HsHole $ HoleVar $ L noAnnSrcSpanDP1 $ unnamedHoleRdrName) + (EmptyLocalBinds NoExtField) + } + +-- | TODO: We could could make these values customizable via HLS plugin +-- settings. +-- +-- Other things that we could store here are: +-- +-- - the maximum number of alternatives on one line +-- - whether or not to put the @;@ for the last alternative +data Default = Default { + -- | Max number of underscores to show for the constructor of an alternative. + -- Beyond this, the record syntax with empty braces is used. + maxUnderscores :: Int + -- | Indentation used when there's no existing alternatives to refer to. + -- Such indentation is with respect to the current layout context. +, indentation :: Int +} + +def :: Default +def = Default { maxUnderscores = 3 + , indentation = 2 } + +-- | Predicate telling if two located annotations are (actually, start) on the +-- same line. +startSameLine :: LocatedAn ann e -> LocatedAn ann e -> Bool +startSameLine = (==) `on` getStartLine + where + -- | Get the starting line of an 'HasSrcSpan'. + getStartLine :: HasSrcSpan a => a -> Int + getStartLine = srcSpanStartLine . realSrcSpan . getLoc + + +-- | Given an @EpAnn (AnnList a)@ return the starting column of +-- its opening brace, if any, otherwise 'Nothing'. +getOpeningBraceCol :: EpAnn (AnnList a) -> Maybe Int +getOpeningBraceCol (EpAnn _ (AnnList _ (ListBraces (EpTok col) _) _ _ _) _) = Just $ getStartCol $ getHasLoc col +getOpeningBraceCol _ = Nothing + +-- | Get the starting column of an 'HasSrcSpan'. +getStartCol :: HasSrcSpan a => a -> Int +getStartCol = srcSpanStartCol . realSrcSpan . getLoc + +-- | Set the DeltaPos for the given annotation. +setDP :: Int -> Int -> LocatedAn t a -> LocatedAn t a +setDP deltaLine deltaColumn lann = setEntryDP lann $ deltaPos deltaLine deltaColumn + +-- | Set the deltaColumn for the given annotation. +setDPCol :: Int -> LocatedAn t a -> LocatedAn t a +setDPCol deltaColumn lann = setEntryDP lann + $ (\d -> deltaPos (getDeltaLine d) deltaColumn) + $ getEntryDP lann + +-- | Set the deltaLine for the given annotation. +setDPLine :: Int -> LocatedAn t a -> LocatedAn t a +setDPLine deltaLine lann = setEntryDP lann + $ (\d -> deltaPos deltaLine (deltaColumn d)) + $ getEntryDP lann + +-- | Useful helper. +putOnNewLine :: LocatedAn t a -> LocatedAn t a +putOnNewLine = setDPLine 1 + +-- | Add semicolon, unless one is already present. +addSemiCol :: LocatedAn AnnListItem a -> LocatedAn AnnListItem a +addSemiCol (L l@(EpAnn _ ls _) e) + | none isSemiCol (lann_trailing ls) + = L (addTrailingAnnToA (AddSemiAnn (EpTok d0)) emptyComments l) e + where + isSemiCol :: TrailingAnn -> Bool + isSemiCol (AddSemiAnn _) = True + isSemiCol _ = False +addSemiCol l = l + +-- | Version of 'Data.List.Extra.chunksOf' (**not** to be confused with +-- 'Data.List.Split.chunksOf') for a 'NonEmpty' lists. +chunksOf1 :: Int -> NonEmpty a -> NonEmpty (NonEmpty a) +chunksOf1 n xs + | n >= 1 + , (b:before, after) <- NE.splitAt n xs + = (b :| before) :| case after of + [] -> [] + _ -> map NE.fromList $ chunksOf n after + | otherwise = error "chunksOf1: the `Int` argument should be ≥ 1" + +-- | Maps a function @f@ over the first element of a 'NonEmpty' list. +mapFirst :: (a -> a) -> NonEmpty a -> NonEmpty a +mapFirst f (a :| as) = f a :| as + +-- | Maps a function @f@ over the last element of a 'NonEmpty' list. +mapLast :: (a -> a) -> NonEmpty a -> NonEmpty a +mapLast f (a :| []) = f a :| [] +mapLast f (a :| as) = a :| mapLast' f as + where + mapLast' f as = init as ++ [f $ last as] + +-- | Convenient negation of 'any'. +none :: Foldable t => (a -> Bool) -> t a -> Bool +none p xs = not $ any p xs diff --git a/plugins/hls-case-split-plugin/test/Main.hs b/plugins/hls-case-split-plugin/test/Main.hs new file mode 100644 index 0000000000..35be740ce0 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/Main.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) where + +import Control.Lens (Prism', prism', (^.), + (^..), (^?)) +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" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "Some patterns, no braces" "TSomePatternsNoBraces" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "Some patterns, with braces" "TSomePatternsWithBraces" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "No patterns, with braces" "TNoPatternsWithBraces" $ + Prelude.flip inspectCodeAction [title] + + -- Patterns with irregular indentation + , goldenWithClass "Jagged patterns, no braces" "TJaggedNoBraces" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "Jagged patterns, with braces" "TJaggedWithBraces" $ + Prelude.flip inspectCodeAction [title] + + -- Patterns on one line + , goldenWithClass "Some patterns on one line, no braces" "TSomePatternsOnOneLineNoBraces" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "Some patterns on one line, with braces" "TSomePatternsOnOneLineWithBraces" $ + Prelude.flip inspectCodeAction [title] + + -- Records + , goldenWithClass "Records' field names are ignored" "TRecordsFieldNamesIgnored" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "Too many fields are collapsed" "TManyFields" $ + Prelude.flip inspectCodeAction [title] + + -- GADTs + , goldenWithClass "GADT - simple" "TGADTsimple" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "GADT - advanced" "TGADTadvanced" $ + Prelude.flip inspectCodeAction [title] + + -- LambdaCase + , goldenWithClass "LambdaCase, no patterns, no braces" "TLambdaCaseNoPatternsNoBraces" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "LambdaCase, no patterns, with braces" "TLambdaCaseNoPatternsWithBraces" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "LambdaCase, some patterns, no braces" "TLambdaCaseSomePatternsNoBraces" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "LambdaCase, some patterns, with braces" "TLambdaCaseSomePatternsWithBraces" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "LambdaCase in `do`, no patterns, no braces" "TLambdaCaseInDoNoPatternsNoBraces" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "LambdaCase in `do`, no patterns, with braces" "TLambdaCaseInDoNoPatternsWithBraces" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "LambdaCase in `do`, some patterns, no braces" "TLambdaCaseInDoSomePatternsNoBraces" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "LambdaCase in `do`, some patterns, with braces" "TLambdaCaseInDoSomePatternsWithBraces" $ + Prelude.flip inspectCodeAction [title] + + -- Inside where + , expectNoCodeActionAvailable "Inside `where`, without signature" "TInsideWhereWithoutSignature" + , goldenWithClass "Inside `where`" "TInsideWhere" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "Inside nested `where`" "TInsideNestedWhere" $ + Prelude.flip inspectCodeAction [title] + + -- Overlapping diagnostics + , goldenWithClass "Expression is `_`" "TExpressionIsUnderscore" $ + Prelude.flip inspectCodeAction [title] + , goldenWithRange "Overlapping pattern matches" "TOverlappingExistingPatterns" $ + Range (Position 15 4) (Position 15 5) + + -- Inside let + , goldenWithClass "Inside `let`'s declarations" "TInsideLetDeclarations" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "Inside `let`'s expression" "TInsideLetExpression" $ + Prelude.flip inspectCodeAction [title] + + -- Inside do + , goldenWithClass "Inside `let`'s declarations inside `do`" "TInsideLetDeclarationsInsideDo" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "Inside `let`'s expression inside `do`" "TInsideLetExpressionInsideDo" $ + Prelude.flip inspectCodeAction [title] + , goldenWithClass "Inside `do`" "TInsideDo" $ + Prelude.flip inspectCodeAction [title] + + -- Nested case expressions + , goldenWithClass "Complete `case` nested in incomplete `case`" "TCompleteCaseInsideIncompleteCase" $ + Prelude.flip inspectCodeAction [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" $ + Prelude.flip inspectCodeAction [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 -> ([Command |? CodeAction] -> IO CodeAction) -> TestTree +goldenWithClass title path findAction = + goldenWithHaskellDocInTmpDir def caseSplitPlugin title (mkFs $ FS.directProject (path <.> "hs")) path "expected" "hs" $ \doc -> do + _ <- waitForDiagnosticsFrom doc + actions <- getAllCodeActions doc + action <- liftIO $ findAction actions + executeCodeAction action + +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 diff --git a/plugins/hls-case-split-plugin/test/testdata/TCompleteCaseInsideIncompleteCase.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TCompleteCaseInsideIncompleteCase.expected.hs new file mode 100644 index 0000000000..e55d2d2a55 --- /dev/null +++ b/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 -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TCompleteCaseInsideIncompleteCase.hs b/plugins/hls-case-split-plugin/test/testdata/TCompleteCaseInsideIncompleteCase.hs new file mode 100644 index 0000000000..81c154c920 --- /dev/null +++ b/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 diff --git a/plugins/hls-case-split-plugin/test/testdata/TExpressionIsUnderscore.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TExpressionIsUnderscore.expected.hs new file mode 100644 index 0000000000..ac42f79936 --- /dev/null +++ b/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 -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TExpressionIsUnderscore.hs b/plugins/hls-case-split-plugin/test/testdata/TExpressionIsUnderscore.hs new file mode 100644 index 0000000000..2bcdd2c048 --- /dev/null +++ b/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 diff --git a/plugins/hls-case-split-plugin/test/testdata/TGADTadvanced.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TGADTadvanced.expected.hs new file mode 100644 index 0000000000..9fa4952ecf --- /dev/null +++ b/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 _ _ _ -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TGADTadvanced.hs b/plugins/hls-case-split-plugin/test/testdata/TGADTadvanced.hs new file mode 100644 index 0000000000..52020e11c9 --- /dev/null +++ b/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 diff --git a/plugins/hls-case-split-plugin/test/testdata/TGADTsimple.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TGADTsimple.expected.hs new file mode 100644 index 0000000000..d12ed9d5e3 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TGADTsimple.expected.hs @@ -0,0 +1,19 @@ +{-# 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 a -> String +prettyExpr expr = case expr of + LitInt _ -> _ + LitBool _ -> _ + Add _ _ -> _ + Not _ -> _ + If _ _ _ -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TGADTsimple.hs b/plugins/hls-case-split-plugin/test/testdata/TGADTsimple.hs new file mode 100644 index 0000000000..825d509a2c --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TGADTsimple.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 a -> String +prettyExpr expr = case expr of diff --git a/plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideCompleteCase.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideCompleteCase.expected.hs new file mode 100644 index 0000000000..3cbc50b5d9 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideCompleteCase.expected.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +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 -> case a of + B -> 4 + C _ -> 5 + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideCompleteCase.hs b/plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideCompleteCase.hs new file mode 100644 index 0000000000..734d201fa6 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideCompleteCase.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +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 -> case a of + B -> 4 + C _ -> 5 diff --git a/plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideIncompleteCase.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideIncompleteCase.expected.hs new file mode 100644 index 0000000000..c2938c4800 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideIncompleteCase.expected.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 _ -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideIncompleteCase.hs b/plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideIncompleteCase.hs new file mode 100644 index 0000000000..c75c98c74f --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TIncompleteCaseInsideIncompleteCase.hs @@ -0,0 +1,17 @@ +{-# 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 diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideDo.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideDo.expected.hs new file mode 100644 index 0000000000..1d5a87b6e1 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideDo.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T15 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> IO () +foo x = do case x of + A -> _ + B -> _ + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideDo.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideDo.hs new file mode 100644 index 0000000000..b251bb6a8c --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideDo.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T15 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> IO () +foo x = do case x of diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarations.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarations.expected.hs new file mode 100644 index 0000000000..0c7df26663 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarations.expected.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T10 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> a +foo x = let r = case x of + A -> _ + B -> _ + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ + in r diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarations.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarations.hs new file mode 100644 index 0000000000..b2e2f9aa1c --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarations.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T10 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> a +foo x = let r = case x of + in r diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarationsInsideDo.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarationsInsideDo.expected.hs new file mode 100644 index 0000000000..1327cf3bc0 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarationsInsideDo.expected.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T15 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> IO () +foo x = do + let r = case x of + A -> _ + B -> _ + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ + in r diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarationsInsideDo.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarationsInsideDo.hs new file mode 100644 index 0000000000..a6860d18d1 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideLetDeclarationsInsideDo.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T15 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> IO () +foo x = do + let r = case x of + in r diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideLetExpression.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideLetExpression.expected.hs new file mode 100644 index 0000000000..bc0f635292 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideLetExpression.expected.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T8 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> a +foo x = let r = x + in case r of + A -> _ + B -> _ + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideLetExpression.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideLetExpression.hs new file mode 100644 index 0000000000..613f09c5d4 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideLetExpression.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T8 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> a +foo x = let r = x + in case r of diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideLetExpressionInsideDo.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideLetExpressionInsideDo.expected.hs new file mode 100644 index 0000000000..cbcedc9f63 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideLetExpressionInsideDo.expected.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T15 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> IO () +foo x = do + let r = x + in case r of + A -> _ + B -> _ + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideLetExpressionInsideDo.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideLetExpressionInsideDo.hs new file mode 100644 index 0000000000..a6f83452f3 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideLetExpressionInsideDo.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T15 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> IO () +foo x = do + let r = x + in case r of diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideNestedWhere.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideNestedWhere.expected.hs new file mode 100644 index 0000000000..7ee930a2e0 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideNestedWhere.expected.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T8 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> a +foo x = bar x + where + bar :: X -> a + bar = baz + where + baz :: X -> a + baz x' = case x' of + A -> _ + B -> _ + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideNestedWhere.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideNestedWhere.hs new file mode 100644 index 0000000000..1061e64ee7 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideNestedWhere.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T8 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> a +foo x = bar x + where + bar :: X -> a + bar = baz + where + baz :: X -> a + baz x' = case x' of diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideWhere.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideWhere.expected.hs new file mode 100644 index 0000000000..1fe1afb4ee --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideWhere.expected.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T8 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> a +foo x = bar x + where + bar :: X -> a + bar x' = case x' of + A -> _ + B -> _ + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideWhere.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideWhere.hs new file mode 100644 index 0000000000..c0876945fa --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideWhere.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T8 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> a +foo x = bar x + where + bar :: X -> a + bar x' = case x' of diff --git a/plugins/hls-case-split-plugin/test/testdata/TInsideWhereWithoutSignature.hs b/plugins/hls-case-split-plugin/test/testdata/TInsideWhereWithoutSignature.hs new file mode 100644 index 0000000000..6779a4db4b --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TInsideWhereWithoutSignature.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T8 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> a +foo x = bar x + where + bar x' = case x' of diff --git a/plugins/hls-case-split-plugin/test/testdata/TJaggedNoBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TJaggedNoBraces.expected.hs new file mode 100644 index 0000000000..0c44f45d87 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TJaggedNoBraces.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T2 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of + A -> 3; + B -> 4; + C _ -> 5 + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TJaggedNoBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TJaggedNoBraces.hs new file mode 100644 index 0000000000..30713b889e --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TJaggedNoBraces.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T2 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of + A -> 3; + B -> 4; + C _ -> 5 diff --git a/plugins/hls-case-split-plugin/test/testdata/TJaggedWithBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TJaggedWithBraces.expected.hs new file mode 100644 index 0000000000..06cb42c3ce --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TJaggedWithBraces.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T2 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of { + A -> 3; + B -> 4; + C _ -> 5; + D _ _ -> _; + E -> _; + F -> _ } diff --git a/plugins/hls-case-split-plugin/test/testdata/TJaggedWithBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TJaggedWithBraces.hs new file mode 100644 index 0000000000..4a95d374ea --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TJaggedWithBraces.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T2 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of { + A -> 3; + B -> 4; + C _ -> 5 } diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsNoBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsNoBraces.expected.hs new file mode 100644 index 0000000000..46c03406c5 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsNoBraces.expected.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = do ( \ case + A -> _ + B -> _ + C _ -> _ + D _ _ -> _ + E -> _ + F -> _) x diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsNoBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsNoBraces.hs new file mode 100644 index 0000000000..bdcc3cc492 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsNoBraces.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = do ( \ case) x diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsWithBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsWithBraces.expected.hs new file mode 100644 index 0000000000..df70e91709 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsWithBraces.expected.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = do (\ case { + A -> _; + B -> _; + C _ -> _; + D _ _ -> _; + E -> _; + F -> _}) x diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsWithBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsWithBraces.hs new file mode 100644 index 0000000000..780f1aad24 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoNoPatternsWithBraces.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = do (\ case {}) x diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsNoBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsNoBraces.expected.hs new file mode 100644 index 0000000000..2085f12466 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsNoBraces.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = do (\case A -> 1 + B -> 2 + C _ -> _ + D _ _ -> _ + E -> _ + F -> _) x diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsNoBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsNoBraces.hs new file mode 100644 index 0000000000..8b17ac01bf --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsNoBraces.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = do (\case A -> 1 + B -> 2) x diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsWithBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsWithBraces.expected.hs new file mode 100644 index 0000000000..c808a95658 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsWithBraces.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = do (\case { A -> 1; + B -> 2; + C _ -> _; + D _ _ -> _; + E -> _; + F -> _ }) x diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsWithBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsWithBraces.hs new file mode 100644 index 0000000000..104a67b05f --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseInDoSomePatternsWithBraces.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = do (\case { A -> 1; + B -> 2 }) x diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsNoBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsNoBraces.expected.hs new file mode 100644 index 0000000000..a7501f3378 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsNoBraces.expected.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Maybe Int +foo x = pure x >>= \case + A -> _ + B -> _ + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsNoBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsNoBraces.hs new file mode 100644 index 0000000000..0edaa4a415 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsNoBraces.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Maybe Int +foo x = pure x >>= \case diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsWithBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsWithBraces.expected.hs new file mode 100644 index 0000000000..3f1e8108e4 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsWithBraces.expected.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Maybe Int +foo x = pure x >>= \case { + A -> _; + B -> _; + C _ -> _; + D _ _ -> _; + E -> _; + F -> _} diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsWithBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsWithBraces.hs new file mode 100644 index 0000000000..a36893b964 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseNoPatternsWithBraces.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Maybe Int +foo x = pure x >>= \case {} diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsNoBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsNoBraces.expected.hs new file mode 100644 index 0000000000..1f04593546 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsNoBraces.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Maybe Int +foo x = pure x >>= \case A -> Just 1 + B -> Just 2 + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsNoBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsNoBraces.hs new file mode 100644 index 0000000000..b4a9cfba5c --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsNoBraces.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Maybe Int +foo x = pure x >>= \case A -> Just 1 + B -> Just 2 diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsWithBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsWithBraces.expected.hs new file mode 100644 index 0000000000..aa4286899e --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsWithBraces.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Maybe Int +foo x = pure x >>= \case { A -> Just 1; + B -> Just 2; + C _ -> _; + D _ _ -> _; + E -> _; + F -> _ } diff --git a/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsWithBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsWithBraces.hs new file mode 100644 index 0000000000..a169ad2f0b --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TLambdaCaseSomePatternsWithBraces.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +{-# LANGUAGE LambdaCase #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Maybe Int +foo x = pure x >>= \case { A -> Just 1; + B -> Just 2 } diff --git a/plugins/hls-case-split-plugin/test/testdata/TManyFields.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TManyFields.expected.hs new file mode 100644 index 0000000000..24851de7af --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TManyFields.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module TManyFields where + +data X = A + | B Int + | C Int Int + | D Int Int Int + | E Int Int Int Int + | F Int Int Int Int Int + +foo :: X -> Int +foo x = case x of + A {} -> 1 + B _ -> 2 + C _ _ -> _ + D _ _ _ -> _ + E {} -> _ + F {} -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TManyFields.hs b/plugins/hls-case-split-plugin/test/testdata/TManyFields.hs new file mode 100644 index 0000000000..461900e090 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TManyFields.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module TManyFields where + +data X = A + | B Int + | C Int Int + | D Int Int Int + | E Int Int Int Int + | F Int Int Int Int Int + +foo :: X -> Int +foo x = case x of + A {} -> 1 + B _ -> 2 diff --git a/plugins/hls-case-split-plugin/test/testdata/TNoPatternsNoBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TNoPatternsNoBraces.expected.hs new file mode 100644 index 0000000000..33ed4f31d3 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TNoPatternsNoBraces.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 :: X -> Int +foo x = case x of + A -> _ + B -> _ + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TNoPatternsNoBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TNoPatternsNoBraces.hs new file mode 100644 index 0000000000..926df62e51 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TNoPatternsNoBraces.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 :: X -> Int +foo x = case x of diff --git a/plugins/hls-case-split-plugin/test/testdata/TNoPatternsWithBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TNoPatternsWithBraces.expected.hs new file mode 100644 index 0000000000..e0e29dadfb --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TNoPatternsWithBraces.expected.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T4 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of + { + A -> _; + B -> _; + C _ -> _; + D _ _ -> _; + E -> _; + F -> _} diff --git a/plugins/hls-case-split-plugin/test/testdata/TNoPatternsWithBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TNoPatternsWithBraces.hs new file mode 100644 index 0000000000..d90d7ca69c --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TNoPatternsWithBraces.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T4 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of + {} diff --git a/plugins/hls-case-split-plugin/test/testdata/TOverlappingExistingPatterns.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TOverlappingExistingPatterns.expected.hs new file mode 100644 index 0000000000..d1dc01a8b1 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TOverlappingExistingPatterns.expected.hs @@ -0,0 +1,20 @@ +{-# 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; B) -> _ + B -> _ + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TOverlappingExistingPatterns.hs b/plugins/hls-case-split-plugin/test/testdata/TOverlappingExistingPatterns.hs new file mode 100644 index 0000000000..012d2defea --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TOverlappingExistingPatterns.hs @@ -0,0 +1,16 @@ +{-# 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; B) -> _ + B -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TRecordsFieldNamesIgnored.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TRecordsFieldNamesIgnored.expected.hs new file mode 100644 index 0000000000..95e61c49e7 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TRecordsFieldNamesIgnored.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T7 where + +data X = A + | B + | C { foo :: Int } + | D { bar :: Int, baz :: Int } + | E + | F + +f :: X -> Int +f x = case x of + A -> _ + B -> _ + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TRecordsFieldNamesIgnored.hs b/plugins/hls-case-split-plugin/test/testdata/TRecordsFieldNamesIgnored.hs new file mode 100644 index 0000000000..ee33bfecd3 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TRecordsFieldNamesIgnored.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T7 where + +data X = A + | B + | C { foo :: Int } + | D { bar :: Int, baz :: Int } + | E + | F + +f :: X -> Int +f x = case x of diff --git a/plugins/hls-case-split-plugin/test/testdata/TSomePatternsNoBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsNoBraces.expected.hs new file mode 100644 index 0000000000..c7c4f72c56 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsNoBraces.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T2 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of + A -> 3 + B -> 4 + C _ -> _ + D _ _ -> _ + E -> _ + F -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TSomePatternsNoBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsNoBraces.hs new file mode 100644 index 0000000000..d9a6efb60f --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsNoBraces.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T2 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of + A -> 3 + B -> 4 diff --git a/plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineNoBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineNoBraces.expected.hs new file mode 100644 index 0000000000..90b87855ce --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineNoBraces.expected.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T2 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + | G + | H + +foo :: X -> Int +foo x = case x of + A -> 3 + B -> 4; C _ -> 5 + D _ _ -> _; E -> _ + F -> _; G -> _ + H -> _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineNoBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineNoBraces.hs new file mode 100644 index 0000000000..6d3c87a9b6 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineNoBraces.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T2 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + | G + | H + +foo :: X -> Int +foo x = case x of + A -> 3 + B -> 4; C _ -> 5 diff --git a/plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineWithBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineWithBraces.expected.hs new file mode 100644 index 0000000000..7bb0b4659c --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineWithBraces.expected.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T3 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of + { A -> 3 ; B -> 4; + C _ -> _; D _ _ -> _; + E -> _; F -> _ } diff --git a/plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineWithBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineWithBraces.hs new file mode 100644 index 0000000000..808769a663 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsOnOneLineWithBraces.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T3 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of + { A -> 3 ; B -> 4 } diff --git a/plugins/hls-case-split-plugin/test/testdata/TSomePatternsWithBraces.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsWithBraces.expected.hs new file mode 100644 index 0000000000..98f2f208d8 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsWithBraces.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T3 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of + { A -> 3; + B -> _; + C _ -> _; + D _ _ -> _; + E -> _; + F -> _ } diff --git a/plugins/hls-case-split-plugin/test/testdata/TSomePatternsWithBraces.hs b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsWithBraces.hs new file mode 100644 index 0000000000..28914acad4 --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TSomePatternsWithBraces.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T3 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of + { A -> 3 } diff --git a/plugins/hls-case-split-plugin/test/testdata/TUnicodeArrow.expected.hs b/plugins/hls-case-split-plugin/test/testdata/TUnicodeArrow.expected.hs new file mode 100644 index 0000000000..99b9203cbd --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TUnicodeArrow.expected.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of + A → _ + B → _ + C _ → _ + D _ _ → _ + E → _ + F → _ diff --git a/plugins/hls-case-split-plugin/test/testdata/TUnicodeArrow.hs b/plugins/hls-case-split-plugin/test/testdata/TUnicodeArrow.hs new file mode 100644 index 0000000000..b67650216e --- /dev/null +++ b/plugins/hls-case-split-plugin/test/testdata/TUnicodeArrow.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# OPTIONS_GHC -Wall -fmax-uncovered-patterns=99 #-} +module T1 where + +data X = A + | B + | C Int + | D Int Int + | E + | F + +foo :: X -> Int +foo x = case x of diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index bf0c3ffec6..bb71cb0147 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -35,7 +35,9 @@ import qualified Ide.Plugin.Eval as Eval import qualified Ide.Plugin.ExplicitImports as ExplicitImports #endif - +#if hls_caseSplit +import qualified Ide.Plugin.CaseSplit as CaseSplit +#endif #if hls_rename import qualified Ide.Plugin.Rename as Rename @@ -196,6 +198,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins #if hls_importLens let pId = "importLens" in ExplicitImports.descriptor (pluginRecorder pId) pId: #endif +#if hls_caseSplit + let pId = "caseSplit" in CaseSplit.descriptor (pluginRecorder pId) pId: +#endif #if hls_qualifyImportedNames QualifyImportedNames.descriptor "qualifyImportedNames" : #endif diff --git a/test/testdata/schema/ghc914/default-config.golden.json b/test/testdata/schema/ghc914/default-config.golden.json index 648f537033..5d7773cb79 100644 --- a/test/testdata/schema/ghc914/default-config.golden.json +++ b/test/testdata/schema/ghc914/default-config.golden.json @@ -34,6 +34,9 @@ "callHierarchy": { "globalOn": true }, + "caseSplit": { + "globalOn": true + }, "changeTypeSignature": { "globalOn": true }, diff --git a/test/testdata/schema/ghc914/vscode-extension-schema.golden.json b/test/testdata/schema/ghc914/vscode-extension-schema.golden.json index e8172db769..2a3d936360 100644 --- a/test/testdata/schema/ghc914/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc914/vscode-extension-schema.golden.json @@ -59,6 +59,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.caseSplit.globalOn": { + "default": true, + "description": "Enables caseSplit plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.changeTypeSignature.globalOn": { "default": true, "description": "Enables changeTypeSignature plugin",