diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 0b9386ec70..91f0428788 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/UseStale.hs b/ghcide/src/Development/IDE/Core/UseStale.hs index c9f3df3aec..8ea736b7a9 100644 --- a/ghcide/src/Development/IDE/Core/UseStale.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index 4e494eb82d..7535ba4c0a 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/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) => diff --git a/plugins/hls-splice-plugin/test/testdata/TTypeAppExp.hs.expected b/plugins/hls-splice-plugin/test/testdata/TTypeAppExp.hs.expected index 0dc0e40f2a..b74d153ee2 100644 --- a/plugins/hls-splice-plugin/test/testdata/TTypeAppExp.hs.expected +++ b/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 diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index aff9d3f087..eba0f97916 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/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 diff --git a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs index 528a2056f8..b4390fdb54 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs +++ b/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 diff --git a/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs index 22237904b9..1f1738dacc 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs +++ b/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 ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs new file mode 100644 index 0000000000..c4635ca40d --- /dev/null +++ b/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 + diff --git a/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs b/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs index 962e8e5645..edd6bc4be8 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs @@ -25,6 +25,7 @@ data Feature | FeatureUseDataCon | FeatureRefineHole | FeatureKnownMonoid + | FeatureEmptyCase deriving (Eq, Ord, Show, Read, Enum, Bounded) diff --git a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs index c77d183ceb..83ed6a93fb 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs @@ -7,6 +7,7 @@ import ConLike import Control.Applicative (empty) import Control.Monad.State import Control.Monad.Trans.Maybe (MaybeT(..)) +import CoreUtils (exprType) import Data.Function (on) import Data.Functor ((<&>)) import Data.List (isPrefixOf) @@ -18,7 +19,9 @@ import Data.Traversable import DataCon import Development.IDE (HscEnvEq (hscEnv)) import Development.IDE.Core.Compile (lookupName) -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding (exprType) +import DsExpr (dsExpr) +import DsMonad (initDs) import GHC.SourceGen (lambda) import Generics.SYB (Data, everything, everywhere, listify, mkQ, mkT) import GhcPlugins (extractModule, GlobalRdrElt (gre_name)) @@ -341,6 +344,14 @@ knownThing f tcg hscenv occ = do Just tt -> liftMaybe $ f tt _ -> empty + liftMaybe :: Monad m => Maybe a -> MaybeT m a liftMaybe a = MaybeT $ pure a + +------------------------------------------------------------------------------ +-- | Get the type of an @HsExpr GhcTc@. This is slow and you should prefer to +-- not use it, but sometimes it can't be helped. +typeCheck :: HscEnv -> TcGblEnv -> HsExpr GhcTc -> IO (Maybe Type) +typeCheck hscenv tcg = fmap snd . initDs hscenv tcg . fmap exprType . dsExpr + diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs index e551e492c9..27cc02e953 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs @@ -40,6 +40,13 @@ buildHypothesis | otherwise = Nothing +------------------------------------------------------------------------------ +-- | Build a trivial hypothesis containing only a single name. The corresponding +-- HyInfo has no provenance or type. +hySingleton :: OccName -> Hypothesis () +hySingleton n = Hypothesis . pure $ HyInfo n UserPrv () + + blacklistingDestruct :: Judgement -> Judgement blacklistingDestruct = field @"_jBlacklistDestruct" .~ True diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 64d33f9d6a..204bea81fa 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -1,14 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Wingman.LanguageServer where import ConLike -import Control.Arrow +import Control.Arrow ((***)) import Control.Monad import Control.Monad.State (State, get, put, evalState) import Control.Monad.Trans.Maybe +import Data.Bifunctor (first) import Data.Coerce import Data.Functor ((<&>)) import Data.Generics.Aliases (mkQ) @@ -32,6 +34,7 @@ import qualified Development.IDE.Core.Shake as IDE import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (realSrcSpanToRange) +import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings) import Development.Shake (Action, RuleResult, Rules, action) import Development.Shake.Classes (Typeable, Binary, Hashable, NFData) @@ -44,6 +47,7 @@ import Ide.PluginUtils (usePropertyLsp) import Ide.Types (PluginId) import Language.LSP.Server (MonadLsp, sendNotification) import Language.LSP.Types +import Language.LSP.Types.Capabilities import OccName import Prelude hiding (span) import SrcLoc (containsSpan) @@ -199,6 +203,7 @@ judgementForHole state nfp range features = do pure (fmap realSrcSpanToRange new_rss, jdg, ctx, dflags) + mkJudgementAndContext :: FeatureSet -> Type @@ -514,3 +519,17 @@ mkDiagnostic severity r = (Just $ List [DtUnnecessary]) Nothing + +------------------------------------------------------------------------------ +-- | Transform a 'Graft' over the AST into a 'WorkspaceEdit'. +mkWorkspaceEdits + :: DynFlags + -> ClientCapabilities + -> Uri + -> Annotated ParsedSource + -> Graft (Either String) ParsedSource + -> Either UserFacingMessage WorkspaceEdit +mkWorkspaceEdits dflags ccs uri pm g = do + let response = transform dflags ccs uri g pm + in first (InfrastructureError . T.pack) response + diff --git a/plugins/hls-tactics-plugin/src/Wingman/Naming.hs b/plugins/hls-tactics-plugin/src/Wingman/Naming.hs index 810cb5311f..f0d133d837 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Naming.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Naming.hs @@ -77,12 +77,12 @@ mkGoodName in_scope t = ------------------------------------------------------------------------------ -- | Like 'mkGoodName' but creates several apart names. mkManyGoodNames - :: (Traversable t, Monad m) + :: (Traversable t) => Set OccName -> t Type - -> m (t OccName) + -> t OccName mkManyGoodNames in_scope args = - flip evalStateT in_scope $ for args $ \at -> do + flip evalState in_scope $ for args $ \at -> do in_scope <- get let n = mkGoodName in_scope at modify $ S.insert n diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index ec38683a4c..59f99b3052 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -12,7 +12,6 @@ import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.Maybe import Data.Aeson -import Data.Bifunctor (first) import Data.Data import Data.Foldable (for_) import Data.Maybe @@ -29,6 +28,7 @@ import OccName import Prelude hiding (span) import System.Timeout import Wingman.CaseSplit +import Wingman.EmptyCase import Wingman.GHC import Wingman.LanguageServer import Wingman.LanguageServer.TacticProviders @@ -41,14 +41,23 @@ import Wingman.Types descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCommands - = fmap (\tc -> - PluginCommand - (tcCommandId tc) - (tacticDesc $ tcCommandName tc) - (tacticCmd (commandTactic tc) plId)) - [minBound .. maxBound] - , pluginHandlers = - mkPluginHandler STextDocumentCodeAction codeActionProvider + = mconcat + [ fmap (\tc -> + PluginCommand + (tcCommandId tc) + (tacticDesc $ tcCommandName tc) + (tacticCmd (commandTactic tc) plId)) + [minBound .. maxBound] + , pure $ + PluginCommand + emptyCaseLensCommandId + "Complete the empty case" + workspaceEditHandler + ] + , pluginHandlers = mconcat + [ mkPluginHandler STextDocumentCodeAction codeActionProvider + , mkPluginHandler STextDocumentCodeLens codeLensProvider + ] , pluginRules = wingmanRules plId , pluginCustomConfig = mkCustomConfig properties @@ -103,7 +112,7 @@ tacticCmd tac pId state (TacticParams uri range var_name) case rtr_extract rtr of L _ (HsVar _ (L _ rdr)) | isHole (occName rdr) -> Left NothingToDo - _ -> pure $ mkWorkspaceEdits pm_span dflags ccs uri pm rtr + _ -> pure $ mkTacticResultEdits pm_span dflags ccs uri pm rtr case res of Nothing -> do @@ -140,7 +149,7 @@ mkErr code err = ResponseError code err Nothing ------------------------------------------------------------------------------ -- | Turn a 'RunTacticResults' into concrete edits to make in the source -- document. -mkWorkspaceEdits +mkTacticResultEdits :: Tracked age RealSrcSpan -> DynFlags -> ClientCapabilities @@ -148,14 +157,12 @@ mkWorkspaceEdits -> Tracked age (Annotated ParsedSource) -> RunTacticResults -> Either UserFacingMessage WorkspaceEdit -mkWorkspaceEdits (unTrack -> span) dflags ccs uri (unTrack -> pm) rtr = do +mkTacticResultEdits (unTrack -> span) dflags ccs uri (unTrack -> pm) rtr = do for_ (rtr_other_solns rtr) $ \soln -> do traceMX "other solution" $ syn_val soln traceMX "with score" $ scoreSolution soln (rtr_jdg rtr) [] traceMX "solution" $ rtr_extract rtr - let g = graftHole (RealSrcSpan span) rtr - response = transform dflags ccs uri g pm - in first (InfrastructureError . T.pack) response + mkWorkspaceEdits dflags ccs uri pm $ graftHole (RealSrcSpan span) rtr ------------------------------------------------------------------------------ @@ -210,7 +217,3 @@ graftDecl dflags dst ix make_decl (L src (AMatch (FunRhs (L _ name) _ _) pats _) _ -> lift $ Left "annotateDecl didn't produce a funbind" graftDecl _ _ _ _ x = pure $ pure x - -fromMaybeT :: Functor m => a -> MaybeT m a -> m a -fromMaybeT def = fmap (fromMaybe def) . runMaybeT - diff --git a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs index 30f9c953fa..a64233ca6f 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs @@ -99,7 +99,7 @@ intros = rule $ \jdg -> do case tcSplitFunTys $ unCType g of ([], _) -> throwError $ GoalMismatch "intros" g (as, b) -> do - vs <- mkManyGoodNames (hyNamesInScope $ jEntireHypothesis jdg) as + let vs = mkManyGoodNames (hyNamesInScope $ jEntireHypothesis jdg) as let top_hole = isTopHole ctx jdg hy' = lambdaHypothesis top_hole $ zip vs $ coerce as jdg' = introduce hy' diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs index bb38c15d3a..64e7f5e00e 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs @@ -117,6 +117,9 @@ instance Show Class where instance Show (HsExpr GhcPs) where show = unsafeRender +instance Show (HsExpr GhcTc) where + show = unsafeRender + instance Show (HsDecl GhcPs) where show = unsafeRender diff --git a/plugins/hls-tactics-plugin/test/CodeLens/EmptyCaseSpec.hs b/plugins/hls-tactics-plugin/test/CodeLens/EmptyCaseSpec.hs new file mode 100644 index 0000000000..c670697c6d --- /dev/null +++ b/plugins/hls-tactics-plugin/test/CodeLens/EmptyCaseSpec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module CodeLens.EmptyCaseSpec where + +import Test.Hspec +import Utils +import Wingman.FeatureSet (allFeatures) + + +spec :: Spec +spec = do + let test = mkCodeLensTest allFeatures + + describe "golden" $ do + test "EmptyCaseADT.hs" + test "EmptyCaseShadow.hs" + test "EmptyCaseParens.hs" + test "EmptyCaseNested.hs" + test "EmptyCaseApply.hs" + test "EmptyCaseGADT.hs" + diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index 37f93e16e2..2e78105682 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -9,7 +9,7 @@ module Utils where import Control.DeepSeq (deepseq) import qualified Control.Exception as E -import Control.Lens hiding (failing, (<.>), (.=)) +import Control.Lens hiding (List, failing, (<.>), (.=)) import Control.Monad (unless) import Control.Monad.IO.Class import Data.Aeson @@ -29,11 +29,11 @@ import System.FilePath import Test.Hls import Test.Hspec import Test.Hspec.Formatters (FailureReason(ExpectedButGot)) -import Test.Tasty.HUnit (Assertion, HUnitFailure(..)) import Wingman.FeatureSet (FeatureSet, allFeatures, prettyFeatureSet) import Wingman.LanguageServer (mkShowMessageParams) import Wingman.Types + plugin :: PluginDescriptor IdeState plugin = Tactic.descriptor "tactics" @@ -126,6 +126,37 @@ mkGoldenTest eq features tc occ line col input = expected <- liftIO $ T.readFile expected_name liftIO $ edited `eq` expected + +mkCodeLensTest + :: FeatureSet + -> FilePath + -> SpecWith () +mkCodeLensTest features input = + it (input <> " (golden)") $ do + runSessionWithServer plugin tacticPath $ do + setFeatureSet features + doc <- openDoc input "haskell" + _ <- waitForDiagnostics + lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc + for_ lenses $ \(CodeLens _ (Just cmd) _) -> + executeCommand cmd + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) + edited <- documentContents doc + let expected_name = input <.> "expected" + -- Write golden tests if they don't already exist + liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do + T.writeFile expected_name edited + expected <- liftIO $ T.readFile expected_name + liftIO $ edited `shouldBe` expected + + + +isWingmanLens :: CodeLens -> Bool +isWingmanLens (CodeLens _ (Just (Command _ cmd _)) _) + = T.isInfixOf ":tactics:" cmd +isWingmanLens _ = False + + mkShowMessageTest :: FeatureSet -> TacticCommand diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseADT.hs b/plugins/hls-tactics-plugin/test/golden/EmptyCaseADT.hs new file mode 100644 index 0000000000..37d3b6c357 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/EmptyCaseADT.hs @@ -0,0 +1,5 @@ +data Foo = A Int | B Bool | C + +foo :: Foo -> () +foo x = case x of + diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseADT.hs.expected b/plugins/hls-tactics-plugin/test/golden/EmptyCaseADT.hs.expected new file mode 100644 index 0000000000..199bbb0db9 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/EmptyCaseADT.hs.expected @@ -0,0 +1,8 @@ +data Foo = A Int | B Bool | C + +foo :: Foo -> () +foo x = case x of + A i -> _ + B b -> _ + C -> _ + diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseApply.hs b/plugins/hls-tactics-plugin/test/golden/EmptyCaseApply.hs new file mode 100644 index 0000000000..29647e2cda --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/EmptyCaseApply.hs @@ -0,0 +1 @@ +blah = case show 5 of diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseApply.hs.expected b/plugins/hls-tactics-plugin/test/golden/EmptyCaseApply.hs.expected new file mode 100644 index 0000000000..fe22299c93 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/EmptyCaseApply.hs.expected @@ -0,0 +1,3 @@ +blah = case show 5 of + [] -> _ + c : l_c -> _ diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseGADT.hs b/plugins/hls-tactics-plugin/test/golden/EmptyCaseGADT.hs new file mode 100644 index 0000000000..ba08ddae54 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/EmptyCaseGADT.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GADTs #-} + +data GADT a where + MyInt :: GADT Int + MyBool :: GADT Bool + MyVar :: GADT a + + +test :: GADT Int -> GADT Bool +test x = case x of + diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseGADT.hs.expected b/plugins/hls-tactics-plugin/test/golden/EmptyCaseGADT.hs.expected new file mode 100644 index 0000000000..409be2aa03 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/EmptyCaseGADT.hs.expected @@ -0,0 +1,13 @@ +{-# LANGUAGE GADTs #-} + +data GADT a where + MyInt :: GADT Int + MyBool :: GADT Bool + MyVar :: GADT a + + +test :: GADT Int -> GADT Bool +test x = case x of + MyInt -> _ + MyVar -> _ + diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseNested.hs b/plugins/hls-tactics-plugin/test/golden/EmptyCaseNested.hs new file mode 100644 index 0000000000..a72781a7c6 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/EmptyCaseNested.hs @@ -0,0 +1,3 @@ +test = + case (case (Just "") of) of + True -> _ diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseNested.hs.expected b/plugins/hls-tactics-plugin/test/golden/EmptyCaseNested.hs.expected new file mode 100644 index 0000000000..10c6925951 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/EmptyCaseNested.hs.expected @@ -0,0 +1,5 @@ +test = + case (case (Just "") of + Nothing -> _ + Just l_c -> _) of + True -> _ diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseParens.hs b/plugins/hls-tactics-plugin/test/golden/EmptyCaseParens.hs new file mode 100644 index 0000000000..2ac71b042e --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/EmptyCaseParens.hs @@ -0,0 +1 @@ +test = True && case True of diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseParens.hs.expected b/plugins/hls-tactics-plugin/test/golden/EmptyCaseParens.hs.expected new file mode 100644 index 0000000000..18aacf2ae2 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/EmptyCaseParens.hs.expected @@ -0,0 +1,3 @@ +test = True && (case True of + False -> _ + True -> _) diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseShadow.hs b/plugins/hls-tactics-plugin/test/golden/EmptyCaseShadow.hs new file mode 100644 index 0000000000..c57af5b849 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/EmptyCaseShadow.hs @@ -0,0 +1,7 @@ +data Foo = A Int | B Bool | C + +-- Make sure we don't shadow the i and b bindings when we empty case +-- split +foo :: Int -> Bool -> Foo -> () +foo i b x = case x of + diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseShadow.hs.expected b/plugins/hls-tactics-plugin/test/golden/EmptyCaseShadow.hs.expected new file mode 100644 index 0000000000..d35cf1a1f5 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/EmptyCaseShadow.hs.expected @@ -0,0 +1,10 @@ +data Foo = A Int | B Bool | C + +-- Make sure we don't shadow the i and b bindings when we empty case +-- split +foo :: Int -> Bool -> Foo -> () +foo i b x = case x of + A i3 -> _ + B b3 -> _ + C -> _ + diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutSplitGuard.hs.expected b/plugins/hls-tactics-plugin/test/golden/LayoutSplitGuard.hs.expected index 3d68d8ac96..cd3cca6c2e 100644 --- a/plugins/hls-tactics-plugin/test/golden/LayoutSplitGuard.hs.expected +++ b/plugins/hls-tactics-plugin/test/golden/LayoutSplitGuard.hs.expected @@ -1,5 +1,5 @@ test :: Bool -> Bool -> Bool test a b - | a = (case b of - False -> _ - True -> _) + | a = case b of + False -> _ + True -> _