Wingman: Destruct on empty case

ghcide/session-loader/Development/IDE/Session.hs

@@ -90,6 +90,7 @@ import           HieDb.Create
 import           HieDb.Types
 import           HieDb.Utils
 import           Maybes                               (MaybeT (runMaybeT))
+import           GHC.LanguageExtensions               (Extension(EmptyCase))
 
 -- | Bump this version number when making changes to the format of the data stored in hiedb
 hiedbDataVersion :: String
@@ -771,6 +772,7 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
           setIgnoreInterfacePragmas $
           setLinkerOptions $
           disableOptimisation $
+          allowEmptyCaseButWithWarning $
           setUpTypedHoles $
           makeDynFlagsAbsolute compRoot dflags'
     -- initPackages parses the -package flags and
@@ -780,6 +782,14 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
     return (final_df, targets)
 
 
+-- | Wingman wants to support destructing of empty cases, but these are a parse
+-- error by default. So we want to enable 'EmptyCase', but then that leads to
+-- silent errors without 'Opt_WarnIncompletePatterns'.
+allowEmptyCaseButWithWarning :: DynFlags -> DynFlags
+allowEmptyCaseButWithWarning =
+  flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns
+
+
 -- we don't want to generate object code so we compile to bytecode
 -- (HscInterpreted) which implies LinkInMemory
 -- HscInterpreted

ghcide/src/Development/IDE/Core/UseStale.hs

@@ -58,7 +58,7 @@ newtype Tracked (age :: Age) a  = UnsafeTracked
 -- change. Use the 'Category' instance to compose 'PositionMapping's in order
 -- to transform between values of different stale ages.
 newtype PositionMap (from :: Age) (to :: Age) = PositionMap
-  { getPositionMapping :: P.PositionMapping
+  { _getPositionMapping :: P.PositionMapping
   }
 
 instance Category PositionMap where

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

@@ -12,6 +12,7 @@ module Development.IDE.GHC.ExactPrint
       annotateDecl,
       hoistGraft,
       graftWithM,
+      graftExprWithM,
       genericGraftWithSmallestM,
       genericGraftWithLargestM,
       graftSmallestDeclsWithM,
@@ -66,11 +67,9 @@ import Parser (parseIdentifier)
 import Data.Traversable (for)
 import Data.Foldable (Foldable(fold))
 import Data.Bool (bool)
-import Data.Monoid (All(All), Any(Any))
+import Data.Monoid (All(All), Any(Any), getAll)
 import Data.Functor.Compose (Compose(Compose))
-#if __GLASGOW_HASKELL__ == 808
 import Control.Arrow
-#endif
 
 
 ------------------------------------------------------------------------------
@@ -246,25 +245,64 @@ graftExpr ::
     LHsExpr GhcPs ->
     Graft (Either String) a
 graftExpr dst val = Graft $ \dflags a -> do
-    -- Traverse the tree, looking for our replacement node. But keep track of
-    -- the context (parent HsExpr constructor) we're in while we do it. This
-    -- lets us determine wehther or not we need parentheses.
-    let (All needs_parens, All needs_space) =
-          everythingWithContext (All True, All True) (<>)
-            ( mkQ (mempty, ) $ \x s -> case x of
-                (L src _ :: LHsExpr GhcPs) | src == dst ->
-                  (s, s)
-                L _ x' -> (mempty, needsParensSpace x')
-            ) a
+    let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a
 
     runGraft
-      (graft' needs_space dst $ bool id maybeParensAST needs_parens val)
+      (graft' needs_space dst $ mk_parens val)
       dflags
       a
 
 
+getNeedsSpaceAndParenthesize ::
+    (ASTElement ast, Data a) =>
+    SrcSpan ->
+    a ->
+    (Bool, Located ast -> Located ast)
+getNeedsSpaceAndParenthesize dst a =
+  -- Traverse the tree, looking for our replacement node. But keep track of
+  -- the context (parent HsExpr constructor) we're in while we do it. This
+  -- lets us determine wehther or not we need parentheses.
+  let (needs_parens, needs_space) =
+          everythingWithContext (Nothing, Nothing) (<>)
+            ( mkQ (mempty, ) $ \x s -> case x of
+                (L src _ :: LHsExpr GhcPs) | src == dst ->
+                  (s, s)
+                L _ x' -> (mempty, Just *** Just $ needsParensSpace x')
+            ) a
+   in ( maybe True getAll needs_space
+      , bool id maybeParensAST $ maybe False getAll needs_parens
+      )
+
+
 ------------------------------------------------------------------------------
 
+graftExprWithM ::
+    forall m a.
+    (Fail.MonadFail m, Data a) =>
+    SrcSpan ->
+    (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) ->
+    Graft m a
+graftExprWithM dst trans = Graft $ \dflags a -> do
+    let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a
+
+    everywhereM'
+        ( mkM $
+            \case
+                val@(L src _ :: LHsExpr GhcPs)
+                    | src == dst -> do
+                        mval <- trans val
+                        case mval of
+                            Just val' -> do
+                                (anns, val'') <-
+                                    hoistTransform (either Fail.fail pure) $
+                                        annotate dflags needs_space $ mk_parens val'
+                                modifyAnnsT $ mappend anns
+                                pure val''
+                            Nothing -> pure val
+                l -> pure l
+        )
+        a
+
 graftWithM ::
     forall ast m a.
     (Fail.MonadFail m, Data a, ASTElement ast) =>

plugins/hls-splice-plugin/test/testdata/TTypeAppExp.hs.expected

@@ -4,4 +4,4 @@ module TTypeAppExp where
 import Data.Proxy
 
 f :: Proxy Int
-f = (Proxy @Int)
+f = Proxy @Int

plugins/hls-tactics-plugin/hls-tactics-plugin.cabal

@@ -34,6 +34,7 @@ library
     Wingman.CodeGen.Utils
     Wingman.Context
     Wingman.Debug
+    Wingman.EmptyCase
     Wingman.FeatureSet
     Wingman.GHC
     Wingman.Judgements
@@ -121,6 +122,7 @@ test-suite tests
     CodeAction.IntrosSpec
     CodeAction.RefineSpec
     CodeAction.UseDataConSpec
+    CodeLens.EmptyCaseSpec
     ProviderSpec
     Spec
     UnificationSpec

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

@@ -1,7 +1,8 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE TupleSections    #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedLabels  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections     #-}
+{-# LANGUAGE TypeApplications  #-}
 
 module Wingman.CodeGen
   ( module Wingman.CodeGen
@@ -47,6 +48,8 @@ destructMatches
        -- ^ Type being destructed
     -> Judgement
     -> RuleM (Synthesized [RawMatch])
+-- TODO(sandy): In an ideal world, this would be the same codepath as
+-- 'destructionFor'. Make sure to change that if you ever change this.
 destructMatches f scrut t jdg = do
   let hy = jEntireHypothesis jdg
       g  = jGoal jdg
@@ -65,7 +68,7 @@ destructMatches f scrut t jdg = do
               args = conLikeInstOrigArgTys' con apps
           modify $ appEndo $ foldMap (Endo . evidenceToSubst) ev
           subst <- gets ts_unifier
-          names <- mkManyGoodNames (hyNamesInScope hy) args
+          let names = mkManyGoodNames (hyNamesInScope hy) args
           let hy' = patternHypothesis scrut con jdg
                   $ zip names
                   $ coerce args
@@ -81,6 +84,29 @@ destructMatches f scrut t jdg = do
             & #syn_val     %~ match [mkDestructPat con names] . unLoc
 
 
+------------------------------------------------------------------------------
+-- | Generate just the 'Match'es for a case split on a specific type.
+destructionFor :: Hypothesis a -> Type -> Maybe [LMatch GhcPs (LHsExpr GhcPs)]
+-- TODO(sandy): In an ideal world, this would be the same codepath as
+-- 'destructMatches'. Make sure to change that if you ever change this.
+destructionFor hy t = do
+  case tacticsGetDataCons t of
+    Nothing -> Nothing
+    Just ([], _) -> Nothing
+    Just (dcs, apps) -> do
+      for dcs $ \dc -> do
+        let con   = RealDataCon dc
+            args  = conLikeInstOrigArgTys' con apps
+            names = mkManyGoodNames (hyNamesInScope hy) args
+        pure
+          . noLoc
+          . Match noExtField CaseAlt [toPatCompat $ mkDestructPat con names]
+          . GRHSs noExtField (pure $ noLoc $ GRHS noExtField [] $ noLoc $ var "_")
+          . noLoc
+          $ EmptyLocalBinds noExtField
+
+
+
 ------------------------------------------------------------------------------
 -- | Produces a pattern for a data con and the names of its fields.
 mkDestructPat :: ConLike -> [OccName] -> Pat GhcPs

plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs

@@ -5,7 +5,7 @@ import Data.List
 import DataCon
 import Development.IDE.GHC.Compat
 import GHC.Exts
-import GHC.SourceGen (RdrNameStr, recordConE, string)
+import GHC.SourceGen (RdrNameStr (UnqualStr), recordConE, string)
 import GHC.SourceGen.Overloaded
 import GhcPlugins (nilDataCon, charTy, eqType)
 import Name
@@ -43,7 +43,7 @@ mkCon con apps (fmap unLoc -> args)
 
 
 coerceName :: HasOccName a => a -> RdrNameStr
-coerceName = fromString . occNameString . occName
+coerceName = UnqualStr . fromString . occNameString . occName
 
 
 ------------------------------------------------------------------------------

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

@@ -0,0 +1,157 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Wingman.EmptyCase where
+
+import           Control.Applicative (empty)
+import           Control.Monad
+import           Control.Monad.Except (runExcept)
+import           Control.Monad.Trans
+import           Control.Monad.Trans.Maybe
+import           Data.Aeson
+import           Data.Generics.Aliases (mkQ, GenericQ)
+import           Data.Generics.Schemes (everything)
+import           Data.Maybe
+import           Data.Monoid
+import qualified Data.Text as T
+import           Data.Traversable
+import           Development.IDE (hscEnv)
+import           Development.IDE (realSrcSpanToRange)
+import           Development.IDE.Core.RuleTypes
+import           Development.IDE.Core.Shake (IdeState (..))
+import           Development.IDE.Core.UseStale
+import           Development.IDE.GHC.Compat
+import           Development.IDE.GHC.ExactPrint
+import           Development.IDE.Spans.LocalBindings (getLocalScope)
+import           Ide.Types
+import           Language.LSP.Server
+import           Language.LSP.Types
+import           OccName
+import           Prelude hiding (span)
+import           Prelude hiding (span)
+import           TcRnTypes (tcg_binds)
+import           Wingman.CodeGen (destructionFor)
+import           Wingman.FeatureSet
+import           Wingman.GHC
+import           Wingman.Judgements
+import           Wingman.LanguageServer
+import           Wingman.Types
+
+
+------------------------------------------------------------------------------
+-- | The 'CommandId' for the empty case completion.
+emptyCaseLensCommandId :: CommandId
+emptyCaseLensCommandId = CommandId "wingman.emptyCase"
+
+
+------------------------------------------------------------------------------
+-- | A command function that just applies a 'WorkspaceEdit'.
+workspaceEditHandler :: CommandFunction IdeState WorkspaceEdit
+workspaceEditHandler _ideState wedit = do
+  _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
+  return $ Right Null
+
+
+------------------------------------------------------------------------------
+-- | Provide the "empty case completion" code lens
+codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens
+codeLensProvider state plId (CodeLensParams _ _ (TextDocumentIdentifier uri))
+  | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
+      cfg <- getTacticConfig plId
+      ccs <- getClientCapabilities
+      liftIO $ fromMaybeT (Right $ List []) $ do
+        guard $ hasFeature FeatureEmptyCase $ cfg_feature_set cfg
+
+        dflags <- getIdeDynflags state nfp
+        TrackedStale pm _ <- runStaleIde state nfp GetAnnotatedParsedSource
+        TrackedStale binds bind_map <- runStaleIde state nfp GetBindings
+        holes <- emptyCaseScrutinees state nfp
+
+        fmap (Right . List) $ for holes $ \(ss, ty) -> do
+          binds_ss <- liftMaybe $ mapAgeFrom bind_map ss
+          let bindings = getLocalScope (unTrack binds) $ unTrack binds_ss
+              range = realSrcSpanToRange $ unTrack ss
+          matches <-
+            liftMaybe $
+              destructionFor
+                (foldMap (hySingleton . occName . fst) bindings)
+                ty
+          edits <- liftMaybe $ hush $
+                mkWorkspaceEdits dflags ccs uri (unTrack pm) $
+                  graftMatchGroup (RealSrcSpan $ unTrack ss) $
+                    noLoc matches
+
+          pure $
+            CodeLens range
+              (Just
+                $ mkLspCommand
+                    plId
+                    emptyCaseLensCommandId
+                    (mkEmptyCaseLensDesc ty)
+                $ Just $ pure $ toJSON $ edits
+              )
+              Nothing
+codeLensProvider _ _ _ = pure $ Right $ List []
+
+
+------------------------------------------------------------------------------
+-- | The description for the empty case lens.
+mkEmptyCaseLensDesc :: Type -> T.Text
+mkEmptyCaseLensDesc ty =
+  "Wingman: Complete case constructors (" <> T.pack (unsafeRender ty) <> ")"
+
+
+------------------------------------------------------------------------------
+-- | Silence an error.
+hush :: Either e a -> Maybe a
+hush (Left _) = Nothing
+hush (Right a) = Just a
+
+
+------------------------------------------------------------------------------
+-- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly
+-- deals with top-level holes, in which we might need to fiddle with the
+-- 'Match's that bind variables.
+graftMatchGroup
+    :: SrcSpan
+    -> Located [LMatch GhcPs (LHsExpr GhcPs)]
+    -> Graft (Either String) ParsedSource
+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 }
+    (_ :: LHsExpr GhcPs) -> pure Nothing
+
+
+fromMaybeT :: Functor m => a -> MaybeT m a -> m a
+fromMaybeT def = fmap (fromMaybe def) . runMaybeT
+
+
+------------------------------------------------------------------------------
+-- | Find the last typechecked module, and find the most specific span, as well
+-- as the judgement at the given range.
+emptyCaseScrutinees
+    :: IdeState
+    -> NormalizedFilePath
+    -> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]
+emptyCaseScrutinees state nfp = do
+    TrackedStale tcg tcg_map <- fmap (fmap tmrTypechecked) $ runStaleIde state nfp TypeCheck
+    let tcg' = unTrack tcg
+    hscenv <- runStaleIde state nfp GhcSessionDeps
+
+    let scrutinees = traverse (emptyCaseQ . tcg_binds) tcg
+    for scrutinees $ \aged@(unTrack -> (ss, scrutinee)) -> do
+      ty <- MaybeT $ 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
+
+
+------------------------------------------------------------------------------
+-- | Get the 'SrcSpan' and scrutinee of every empty case.
+emptyCaseQ :: GenericQ [(SrcSpan, HsExpr GhcTc)]
+emptyCaseQ = everything (<>) $ mkQ mempty $ \case
+  L new_span (Case scrutinee []) -> pure (new_span, scrutinee)
+  (_ :: LHsExpr GhcTc) -> mempty
+