Wingman: Code lens for empty lambda case (#1956)

* Support empty lambdacase

* Add test

Author: isovector

ghcide/src/Development/IDE/GHC/ExactPrint.hs

@@ -188,7 +188,7 @@ needsParensSpace ::
     -- | (Needs parens, needs space)
     (All, All)
 needsParensSpace HsLam{}         = (All False, All False)
-needsParensSpace HsLamCase{}     = (All False, All False)
+needsParensSpace HsLamCase{}     = (All False, All True)
 needsParensSpace HsApp{}         = mempty
 needsParensSpace HsAppType{}     = mempty
 needsParensSpace OpApp{}         = mempty

plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs

@@ -93,6 +93,13 @@ codeLensProvider state plId (CodeLensParams _ _ (TextDocumentIdentifier uri))
 codeLensProvider _ _ _ = pure $ Right $ List []
 
 
+scrutinzedType :: EmptyCaseSort Type -> Maybe Type
+scrutinzedType (EmptyCase ty) = pure  ty
+scrutinzedType (EmptyLamCase ty) =
+  case tacticsSplitFunTy ty of
+    (_, _, tys, _) -> listToMaybe  tys
+
+
 ------------------------------------------------------------------------------
 -- | The description for the empty case lens.
 mkEmptyCaseLensDesc :: Type -> T.Text
@@ -119,6 +126,8 @@ graftMatchGroup ss l =
   hoistGraft (runExcept . runExceptString) $ graftExprWithM ss $ \case
     L span (HsCase ext scrut mg@_) -> do
       pure $ Just $ L span $ HsCase ext scrut $ mg { mg_alts = l }
+    L span (HsLamCase ext mg@_) -> do
+      pure $ Just $ L span $ HsLamCase ext $ mg { mg_alts = l }
     (_ :: LHsExpr GhcPs) -> pure Nothing
 
 
@@ -142,18 +151,26 @@ emptyCaseScrutinees state nfp = do
 
     let scrutinees = traverse (emptyCaseQ . tcg_binds) tcg
     for scrutinees $ \aged@(unTrack -> (ss, scrutinee)) -> do
-      ty <- MaybeT $ typeCheck (hscEnv $ untrackedStaleValue hscenv) tcg' scrutinee
+      ty <- MaybeT
+          . fmap (scrutinzedType <=< sequence)
+          . traverse (typeCheck (hscEnv $ untrackedStaleValue hscenv) tcg')
+          $ scrutinee
       case ss of
         RealSrcSpan r   -> do
           rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r
           pure (rss', ty)
         UnhelpfulSpan _ -> empty
 
+data EmptyCaseSort a
+  = EmptyCase a
+  | EmptyLamCase a
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
 
 ------------------------------------------------------------------------------
 -- | Get the 'SrcSpan' and scrutinee of every empty case.
-emptyCaseQ :: GenericQ [(SrcSpan, HsExpr GhcTc)]
+emptyCaseQ :: GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
 emptyCaseQ = everything (<>) $ mkQ mempty $ \case
-  L new_span (Case scrutinee []) -> pure (new_span, scrutinee)
+  L new_span (Case scrutinee []) -> pure (new_span, EmptyCase scrutinee)
+  L new_span (expr@(LamCase [])) -> pure (new_span, EmptyLamCase expr)
   (_ :: LHsExpr GhcTc) -> mempty
 

plugins/hls-tactics-plugin/src/Wingman/GHC.hs

@@ -252,6 +252,13 @@ pattern Case scrutinee matches <-
   HsCase _ (L _ scrutinee)
     (MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)})
 
+------------------------------------------------------------------------------
+-- | Like 'Case', but for lambda cases.
+pattern LamCase :: PatCompattable p => [(Pat p, LHsExpr p)] -> HsExpr p
+pattern LamCase matches <-
+  HsLamCase _
+    (MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)})
+
 
 ------------------------------------------------------------------------------
 -- | Can ths type be lambda-cased?

plugins/hls-tactics-plugin/test/CodeLens/EmptyCaseSpec.hs

@@ -17,4 +17,5 @@ spec = do
     test "EmptyCaseNested"
     test "EmptyCaseApply"
     test "EmptyCaseGADT"
+    test "EmptyCaseLamCase"
 

plugins/hls-tactics-plugin/test/golden/EmptyCaseLamCase.expected.hs

@@ -0,0 +1,6 @@
+{-# LANGUAGE LambdaCase #-}
+
+test :: Bool -> Bool
+test = \case
+  False -> _
+  True -> _

plugins/hls-tactics-plugin/test/golden/EmptyCaseLamCase.hs

@@ -0,0 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
+
+test :: Bool -> Bool
+test = \case