From bd33819948e8d814b4746424c222628ce2e14f97 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Fri, 2 Apr 2021 23:07:49 -0700 Subject: [PATCH 01/21] Start tracking provenance of stale data It's amazing how wrong this code used to be --- .../src/Wingman/Judgements.hs | 5 +- .../src/Wingman/Judgements/Theta.hs | 6 +- .../src/Wingman/LanguageServer.hs | 107 ++++++++++++------ .../Wingman/LanguageServer/TacticProviders.hs | 17 +-- .../hls-tactics-plugin/src/Wingman/Plugin.hs | 35 +++--- .../hls-tactics-plugin/src/Wingman/Range.hs | 69 ++++++++++- .../hls-tactics-plugin/src/Wingman/Types.hs | 2 - 7 files changed, 168 insertions(+), 73 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs index 92c1f7fdd9..6c39966caf 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs @@ -17,13 +17,14 @@ import OccName import SrcLoc import Type import Wingman.GHC (algebraicTyCon) +import Wingman.Range (Tracked(..)) import Wingman.Types ------------------------------------------------------------------------------ -- | Given a 'SrcSpan' and a 'Bindings', create a hypothesis. -hypothesisFromBindings :: RealSrcSpan -> Bindings -> Hypothesis CType -hypothesisFromBindings span bs = buildHypothesis $ getLocalScope bs span +hypothesisFromBindings :: Tracked age RealSrcSpan -> Tracked age Bindings -> Hypothesis CType +hypothesisFromBindings (unTrack -> span) (unTrack -> bs) = buildHypothesis $ getLocalScope bs span ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs index ff359eb6bf..e8ec4f36b5 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs @@ -25,6 +25,7 @@ import TcEvidence import TcType (tcTyConAppTyCon_maybe) import TysPrim (eqPrimTyCon) import Wingman.Machinery +import Wingman.Range (Tracked(..)) import Wingman.Types @@ -50,11 +51,12 @@ mkEvidence _ = Nothing ------------------------------------------------------------------------------ -- | Compute all the 'Evidence' implicitly bound at the given 'SrcSpan'. -getEvidenceAtHole :: SrcSpan -> LHsBinds GhcTc -> [Evidence] -getEvidenceAtHole dst +getEvidenceAtHole :: Tracked age SrcSpan -> Tracked age (LHsBinds GhcTc) -> [Evidence] +getEvidenceAtHole (unTrack -> dst) = mapMaybe mkEvidence . (everything (<>) $ mkQ mempty (absBinds dst) `extQ` wrapperBinds dst `extQ` matchBinds dst) + . unTrack ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 417cc0e4ea..0484f9ec82 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -18,10 +18,9 @@ import Data.Monoid import qualified Data.Set as S import qualified Data.Text as T import Data.Traversable -import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake (IdeState (..), useWithStale) +import Development.IDE.Core.Shake (IdeState (..), useWithStale, use) import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (realSrcSpanToRange) import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings) @@ -62,6 +61,19 @@ runIde :: IdeState -> Action a -> IO a runIde state = runAction "tactic" state +runCurrentIde + :: forall a r + . ( r ~ RuleResult a + , Eq a , Hashable a , Binary a , Show a , Typeable a , NFData a + , Show r, Typeable r, NFData r + ) + => IdeState + -> NormalizedFilePath + -> a + -> MaybeT IO (Tracked 'Current r) +runCurrentIde state nfp a = MaybeT $ coerce $ runIde state $ use a nfp + + runStaleIde :: forall a r . ( r ~ RuleResult a @@ -71,8 +83,25 @@ runStaleIde => IdeState -> NormalizedFilePath -> a - -> MaybeT IO (r, PositionMapping) -runStaleIde state nfp a = MaybeT $ runIde state $ useWithStale a nfp + -> MaybeT IO (TrackedStale r) +runStaleIde state nfp a = do + (r, pm) <- MaybeT $ runIde state $ useWithStale a nfp + pure $ TrackedStale (coerce r) (coerce pm) + + +unsafeRunStaleIde + :: forall a r + . ( r ~ RuleResult a + , Eq a , Hashable a , Binary a , Show a , Typeable a , NFData a + , Show r, Typeable r, NFData r + ) + => IdeState + -> NormalizedFilePath + -> a + -> MaybeT IO r +unsafeRunStaleIde state nfp a = do + (r, _) <- MaybeT $ runIde state $ useWithStale a nfp + pure r ------------------------------------------------------------------------------ @@ -107,7 +136,7 @@ getIdeDynflags getIdeDynflags state nfp = do -- Ok to use the stale 'ModIface', since all we need is its 'DynFlags' -- which don't change very often. - (msr, _) <- runStaleIde state nfp GetModSummaryWithoutTimestamps + msr <- unsafeRunStaleIde state nfp GetModSummaryWithoutTimestamps pure $ ms_hspp_opts $ msrModSummary msr @@ -117,18 +146,20 @@ getIdeDynflags state nfp = do judgementForHole :: IdeState -> NormalizedFilePath - -> Range + -> Tracked 'Current Range -> FeatureSet - -> MaybeT IO (Range, Judgement, Context, DynFlags) + -> MaybeT IO (Tracked 'Current Range, Judgement, Context, DynFlags) judgementForHole state nfp range features = do - (asts, amapping) <- runStaleIde state nfp GetHieAst - case asts of + TrackedStale asts amapping <- runStaleIde state nfp GetHieAst + case unTrack asts of HAR _ _ _ _ (HieFromDisk _) -> fail "Need a fresh hie file" - HAR _ hf _ _ HieFresh -> do - (binds, _) <- runStaleIde state nfp GetBindings - (tcmod, _) <- runStaleIde state nfp TypeCheck - (rss, g) <- liftMaybe $ getSpanAndTypeAtHole amapping range hf - resulting_range <- liftMaybe $ toCurrentRange amapping $ realSrcSpanToRange rss + HAR _ (cautiousCopyAge asts -> hf) _ _ HieFresh -> do + range' <- liftMaybe $ fromCurrentRange amapping range + TrackedStale binds bmapping <- runStaleIde state nfp GetBindings + TrackedStale tcmod tcmmapping <- runStaleIde state nfp TypeCheck + + (rss, g) <- liftMaybe $ getSpanAndTypeAtHole range' hf + resulting_range <- liftMaybe $ toCurrentRange amapping $ fmap realSrcSpanToRange rss let (jdg, ctx) = mkJudgementAndContext features g binds rss tcmod dflags <- getIdeDynflags state nfp pure (resulting_range, jdg, ctx, dflags) @@ -137,21 +168,21 @@ judgementForHole state nfp range features = do mkJudgementAndContext :: FeatureSet -> Type - -> Bindings - -> RealSrcSpan - -> TcModuleResult + -> Tracked age Bindings + -> Tracked age RealSrcSpan + -> Tracked age TcModuleResult -> (Judgement, Context) mkJudgementAndContext features g binds rss tcmod = do - let tcg = tmrTypechecked tcmod - tcs = tcg_binds tcg + let tcg = fmap tmrTypechecked tcmod + tcs = fmap tcg_binds tcg ctx = mkContext features (mapMaybe (sequenceA . (occName *** coerce)) - $ getDefiningBindings binds rss) - tcg + $ getDefiningBindings (unTrack binds) $ unTrack rss) + (unTrack tcg) top_provs = getRhsPosVals rss tcs local_hy = spliceProvenance top_provs $ hypothesisFromBindings rss binds - evidence = getEvidenceAtHole (RealSrcSpan rss) tcs + evidence = getEvidenceAtHole (fmap RealSrcSpan rss) tcs cls_hy = foldMap evidenceToHypothesis evidence subst = ts_unifier $ appEndo (foldMap (Endo . evidenceToSubst) evidence) defaultTacticState in ( fmap (CType . substTyAddInScope subst . unCType) $ mkFirstJudgement @@ -163,14 +194,12 @@ mkJudgementAndContext features g binds rss tcmod = do getSpanAndTypeAtHole - :: PositionMapping - -> Range - -> HieASTs b - -> Maybe (Span, b) -getSpanAndTypeAtHole amapping range hf = do - range' <- fromCurrentRange amapping range + :: Tracked age Range + -> Tracked age (HieASTs b) + -> Maybe (Tracked age RealSrcSpan, b) +getSpanAndTypeAtHole (unTrack -> range) (unTrack -> hf) = do join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> - case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range') ast of + case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range) ast of Nothing -> Nothing Just ast' -> do let info = nodeInfo ast' @@ -179,7 +208,7 @@ getSpanAndTypeAtHole amapping range hf = do -- Ensure we're actually looking at a hole here guard $ all (either (const False) $ isHole . occName) $ M.keysSet $ nodeIdentifiers info - pure (nodeSpan ast', ty) + pure (Tracked $ nodeSpan ast', ty) liftMaybe :: Monad m => Maybe a -> MaybeT m a @@ -200,8 +229,11 @@ spliceProvenance top x = ------------------------------------------------------------------------------ -- | Compute top-level position vals of a function -getRhsPosVals :: RealSrcSpan -> TypecheckedSource -> Hypothesis CType -getRhsPosVals rss tcs +getRhsPosVals + :: Tracked age RealSrcSpan + -> Tracked age TypecheckedSource + -> Hypothesis CType +getRhsPosVals (unTrack -> rss) (unTrack -> tcs) = everything (<>) (mkQ mempty $ \case TopLevelRHS name ps (L (RealSrcSpan span) -- body with no guards and a single defn @@ -344,11 +376,12 @@ mkIdHypothesis (splitId -> (name, ty)) prov = ------------------------------------------------------------------------------ -- | Is this hole immediately to the right of an equals sign? -isRhsHole :: RealSrcSpan -> TypecheckedSource -> Bool -isRhsHole rss tcs = everything (||) (mkQ False $ \case - TopLevelRHS _ _ (L (RealSrcSpan span) _) -> containsSpan rss span - _ -> False - ) tcs +isRhsHole :: Tracked age RealSrcSpan -> Tracked age TypecheckedSource -> Bool +isRhsHole (unTrack -> rss) (unTrack -> tcs) = + everything (||) (mkQ False $ \case + TopLevelRHS _ _ (L (RealSrcSpan span) _) -> containsSpan rss span + _ -> False + ) tcs ufmSeverity :: UserFacingMessage -> MessageType diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs index 549af57716..61cfecc1d5 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs @@ -23,18 +23,19 @@ import DataCon (dataConName) import Development.IDE.GHC.Compat import GHC.Generics import GHC.LanguageExtensions.Type (Extension (LambdaCase)) -import Wingman.Auto -import Wingman.FeatureSet -import Wingman.GHC -import Wingman.Judgements -import Wingman.Tactics -import Wingman.Types import Ide.PluginUtils import Ide.Types import Language.LSP.Types import OccName import Prelude hiding (span) import Refinery.Tactic (goal) +import Wingman.Auto +import Wingman.FeatureSet +import Wingman.GHC +import Wingman.Judgements +import Wingman.Range +import Wingman.Tactics +import Wingman.Types ------------------------------------------------------------------------------ @@ -150,14 +151,14 @@ data TacticProviderData = TacticProviderData , tpd_config :: Config , tpd_plid :: PluginId , tpd_uri :: Uri - , tpd_range :: Range + , tpd_range :: Tracked 'Current Range , tpd_jdg :: Judgement } data TacticParams = TacticParams { tp_file :: Uri -- ^ Uri of the file to fill the hole in - , tp_range :: Range -- ^ The range of the hole + , tp_range :: Tracked 'Current Range -- ^ The range of the hole , tp_var_name :: T.Text } deriving stock (Show, Eq, Generic) diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index a2b84ad807..1d9f46d587 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -13,9 +13,9 @@ 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 -import Data.Proxy (Proxy(..)) import qualified Data.Text as T import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.GHC.Compat @@ -39,21 +39,22 @@ 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 - , pluginCustomConfig = - mkCustomConfig properties - } + { pluginCommands + = fmap (\tc -> + PluginCommand + (tcCommandId tc) + (tacticDesc $ tcCommandName tc) + (tacticCmd (commandTactic tc) plId)) + [minBound .. maxBound] + , pluginHandlers = + mkPluginHandler STextDocumentCodeAction codeActionProvider + , pluginCustomConfig = + mkCustomConfig properties + } + codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction -codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range _ctx) +codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) (cautiousToCurrent -> range) _ctx) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do cfg <- getTacticConfig plId liftIO $ fromMaybeT (Right $ List []) $ do @@ -88,8 +89,8 @@ tacticCmd tac pId state (TacticParams uri range var_name) ccs <- getClientCapabilities res <- liftIO $ runMaybeT $ do (range', jdg, ctx, dflags) <- judgementForHole state nfp range features - let span = rangeToRealSrcSpan (fromNormalizedFilePath nfp) range' - pm <- MaybeT $ useAnnotatedSource "tacticsCmd" state nfp + let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath nfp)) range' + pm <- runStaleIde state nfp GetAnnotatedParsedSource timingOut 2e8 $ join $ case runTactic ctx jdg $ tac $ mkVarOcc $ T.unpack var_name of @@ -98,7 +99,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 span dflags ccs uri pm rtr + _ -> pure $ mkWorkspaceEdits (unTrack span) dflags ccs uri pm rtr case res of Nothing -> do diff --git a/plugins/hls-tactics-plugin/src/Wingman/Range.hs b/plugins/hls-tactics-plugin/src/Wingman/Range.hs index 470e207742..81bd3276bf 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Range.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Range.hs @@ -1,18 +1,77 @@ -module Wingman.Range where +{-# LANGUAGE KindSignatures #-} -import Development.IDE.Types.Location +{-# LANGUAGE RankNTypes #-} +module Wingman.Range + ( module Wingman.Range + ) where + +import Control.DeepSeq (NFData) +import Data.Aeson +import Data.Coerce (coerce) +import Data.Kind (Type) +import Development.IDE hiding (rangeToRealSrcSpan) +import qualified Development.IDE.Core.PositionMapping as P import qualified FastString as FS import SrcLoc + + ------------------------------------------------------------------------------ -- | Convert a DAML compiler Range to a GHC SrcSpan -- TODO(sandy): this doesn't belong here rangeToSrcSpan :: String -> Range -> SrcSpan rangeToSrcSpan file range = RealSrcSpan $ rangeToRealSrcSpan file range + rangeToRealSrcSpan :: String -> Range -> RealSrcSpan rangeToRealSrcSpan file (Range (Position startLn startCh) (Position endLn endCh)) = - mkRealSrcSpan - (mkRealSrcLoc (FS.fsLit file) (startLn + 1) (startCh + 1)) - (mkRealSrcLoc (FS.fsLit file) (endLn + 1) (endCh + 1)) + mkRealSrcSpan + (mkRealSrcLoc (FS.fsLit file) (startLn + 1) (startCh + 1)) + (mkRealSrcLoc (FS.fsLit file) (endLn + 1) (endCh + 1)) + + +data Age = Current | Stale Type + +newtype Tracked (age :: Age) a = Tracked + { unTrack :: a + } + deriving stock Functor + deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData) + + +newtype PositionMapping s = PositionMapping + { getPositionMapping :: P.PositionMapping + } + + +data TrackedStale a where + TrackedStale + :: Tracked (Stale s) a + -> PositionMapping s + -> TrackedStale a + + +cautiousToCurrent :: age -> Tracked 'Current age +cautiousToCurrent = coerce + + +cautiousToStale :: age -> Tracked (Stale s) age +cautiousToStale = coerce + +cautiousCopyAge :: Tracked age a -> b -> Tracked age b +cautiousCopyAge _ = coerce + + +fromCurrentRange + :: PositionMapping s + -> Tracked 'Current Range + -> Maybe (Tracked (Stale s) Range) +fromCurrentRange = coerce P.fromCurrentRange + + +toCurrentRange + :: PositionMapping s + -> Tracked (Stale s) Range + -> Maybe (Tracked 'Current Range) +toCurrentRange = coerce P.toCurrentRange diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs index cf5aa9655d..4db95dd5e1 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs @@ -11,7 +11,6 @@ module Wingman.Types , Type , TyVar , Span - , Range ) where import ConLike (ConLike) @@ -29,7 +28,6 @@ import qualified Data.Text as T import Data.Tree import Development.IDE.GHC.Compat hiding (Node) import Development.IDE.GHC.Orphans () -import Development.IDE.Types.Location import GHC.Generics import GHC.SourceGen (var) import OccName From 489f2164002588cb38d67832675e6eb5ec28dbef Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Fri, 2 Apr 2021 23:31:16 -0700 Subject: [PATCH 02/21] Add some machinery for automagically updating the age --- .../src/Wingman/LanguageServer.hs | 30 +++++++++++-------- .../hls-tactics-plugin/src/Wingman/Range.hs | 28 +++++++++++++++++ 2 files changed, 46 insertions(+), 12 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 0484f9ec82..75672fc8ca 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -37,7 +37,7 @@ import Language.LSP.Types import OccName import Prelude hiding (span) import SrcLoc (containsSpan) -import TcRnTypes (tcg_binds) +import TcRnTypes (tcg_binds, TcGblEnv) import Wingman.Context import Wingman.FeatureSet import Wingman.GHC @@ -155,14 +155,20 @@ judgementForHole state nfp range features = do HAR _ _ _ _ (HieFromDisk _) -> fail "Need a fresh hie file" HAR _ (cautiousCopyAge asts -> hf) _ _ HieFresh -> do range' <- liftMaybe $ fromCurrentRange amapping range - TrackedStale binds bmapping <- runStaleIde state nfp GetBindings - TrackedStale tcmod tcmmapping <- runStaleIde state nfp TypeCheck - - (rss, g) <- liftMaybe $ getSpanAndTypeAtHole range' hf - resulting_range <- liftMaybe $ toCurrentRange amapping $ fmap realSrcSpanToRange rss - let (jdg, ctx) = mkJudgementAndContext features g binds rss tcmod + TrackedStale old_binds bmapping <- runStaleIde state nfp GetBindings + TrackedStale old_tcmod tcmmapping <- fmap (fmap tmrTypechecked) + $ runStaleIde state nfp TypeCheck + binds <- liftMaybe $ mapPositionsToCurrent bmapping old_binds + tcmod <- liftMaybe $ mapPositionsToCurrent tcmmapping old_tcmod + + (old_rss, g) <- liftMaybe $ getSpanAndTypeAtHole range' hf + new_rss <- liftMaybe + $ fmap cautiousToCurrent + $ mapRangeOfRealSrcSpan (unsafeToCurrentRange amapping) + $ unTrack old_rss + let (jdg, ctx) = mkJudgementAndContext features g binds new_rss tcmod dflags <- getIdeDynflags state nfp - pure (resulting_range, jdg, ctx, dflags) + pure (fmap realSrcSpanToRange new_rss, jdg, ctx, dflags) mkJudgementAndContext @@ -170,11 +176,10 @@ mkJudgementAndContext -> Type -> Tracked age Bindings -> Tracked age RealSrcSpan - -> Tracked age TcModuleResult + -> Tracked age TcGblEnv -> (Judgement, Context) -mkJudgementAndContext features g binds rss tcmod = do - let tcg = fmap tmrTypechecked tcmod - tcs = fmap tcg_binds tcg +mkJudgementAndContext features g binds rss tcg = do + let tcs = fmap tcg_binds tcg ctx = mkContext features (mapMaybe (sequenceA . (occName *** coerce)) $ getDefiningBindings (unTrack binds) $ unTrack rss) @@ -397,3 +402,4 @@ mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show uf showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m () showLspMessage = sendNotification SWindowShowMessage + diff --git a/plugins/hls-tactics-plugin/src/Wingman/Range.hs b/plugins/hls-tactics-plugin/src/Wingman/Range.hs index 81bd3276bf..a0794299f1 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Range.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Range.hs @@ -13,6 +13,7 @@ import Development.IDE hiding (rangeToRealSrcSpan) import qualified Development.IDE.Core.PositionMapping as P import qualified FastString as FS import SrcLoc +import Generics.SYB @@ -50,6 +51,10 @@ data TrackedStale a where -> PositionMapping s -> TrackedStale a +instance Functor TrackedStale where + fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm + + cautiousToCurrent :: age -> Tracked 'Current age cautiousToCurrent = coerce @@ -75,3 +80,26 @@ toCurrentRange -> Maybe (Tracked 'Current Range) toCurrentRange = coerce P.toCurrentRange +unsafeToCurrentRange :: PositionMapping s -> Range -> Maybe Range +unsafeToCurrentRange = coerce P.toCurrentRange + + +mapRangeOfRealSrcSpan :: Functor f => (Range -> f Range) -> RealSrcSpan -> f RealSrcSpan +mapRangeOfRealSrcSpan f rss + = fmap (rangeToRealSrcSpan $ FS.unpackFS $ srcSpanFile rss) + . f + $ realSrcSpanToRange rss + + +mapPositionsToCurrent + :: Data a + => PositionMapping s + -> Tracked (Stale s) a + -> Maybe (Tracked Current a) +mapPositionsToCurrent (PositionMapping am) (Tracked t) + = fmap Tracked + $ everywhereM + ( mkM (P.toCurrentRange am) + `extM` (mapRangeOfRealSrcSpan (P.toCurrentRange am)) + ) t + From 4398610d362adfa5c5bd296fe41eeb45f926a5ed Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Sat, 3 Apr 2021 08:41:36 -0700 Subject: [PATCH 03/21] Add an applicative instance --- plugins/hls-tactics-plugin/src/Wingman/Range.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/plugins/hls-tactics-plugin/src/Wingman/Range.hs b/plugins/hls-tactics-plugin/src/Wingman/Range.hs index a0794299f1..15ffa79c08 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Range.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Range.hs @@ -14,6 +14,7 @@ import qualified Development.IDE.Core.PositionMapping as P import qualified FastString as FS import SrcLoc import Generics.SYB +import Data.Functor.Identity (Identity(Identity)) @@ -38,6 +39,7 @@ newtype Tracked (age :: Age) a = Tracked } deriving stock Functor deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData) + deriving Applicative via Identity newtype PositionMapping s = PositionMapping From 8fb6be7074810055313d55e943386a4006c9f228 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Sat, 3 Apr 2021 12:49:11 -0700 Subject: [PATCH 04/21] Tracked ages makes everything much easier to reason about --- .../Development/IDE/Core/PositionMapping.hs | 1 + .../src/Wingman/LanguageServer.hs | 70 ++++++++-------- .../hls-tactics-plugin/src/Wingman/Plugin.hs | 11 +-- .../hls-tactics-plugin/src/Wingman/Range.hs | 81 ++++++++++--------- 4 files changed, 87 insertions(+), 76 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/PositionMapping.hs b/ghcide/src/Development/IDE/Core/PositionMapping.hs index a9bd4aae7f..4048908b7c 100644 --- a/ghcide/src/Development/IDE/Core/PositionMapping.hs +++ b/ghcide/src/Development/IDE/Core/PositionMapping.hs @@ -11,6 +11,7 @@ module Development.IDE.Core.PositionMapping , PositionDelta(..) , addDelta , idDelta + , composeDelta , mkDelta , toCurrentRange , fromCurrentRange diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 75672fc8ca..c58fdf1237 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -154,19 +154,14 @@ judgementForHole state nfp range features = do case unTrack asts of HAR _ _ _ _ (HieFromDisk _) -> fail "Need a fresh hie file" HAR _ (cautiousCopyAge asts -> hf) _ _ HieFresh -> do - range' <- liftMaybe $ fromCurrentRange amapping range - TrackedStale old_binds bmapping <- runStaleIde state nfp GetBindings - TrackedStale old_tcmod tcmmapping <- fmap (fmap tmrTypechecked) - $ runStaleIde state nfp TypeCheck - binds <- liftMaybe $ mapPositionsToCurrent bmapping old_binds - tcmod <- liftMaybe $ mapPositionsToCurrent tcmmapping old_tcmod - - (old_rss, g) <- liftMaybe $ getSpanAndTypeAtHole range' hf - new_rss <- liftMaybe - $ fmap cautiousToCurrent - $ mapRangeOfRealSrcSpan (unsafeToCurrentRange amapping) - $ unTrack old_rss - let (jdg, ctx) = mkJudgementAndContext features g binds new_rss tcmod + range' <- liftMaybe $ mapAgeFrom amapping range + binds <- runStaleIde state nfp GetBindings + tcmod <- fmap (fmap tmrTypechecked) + $ runStaleIde state nfp TypeCheck + + (rss, g) <- liftMaybe $ getSpanAndTypeAtHole range' hf + new_rss <- liftMaybe $ mapAgeTo amapping rss + (jdg, ctx) <- liftMaybe $ mkJudgementAndContext features g binds new_rss tcmod dflags <- getIdeDynflags state nfp pure (fmap realSrcSpanToRange new_rss, jdg, ctx, dflags) @@ -174,28 +169,33 @@ judgementForHole state nfp range features = do mkJudgementAndContext :: FeatureSet -> Type - -> Tracked age Bindings - -> Tracked age RealSrcSpan - -> Tracked age TcGblEnv - -> (Judgement, Context) -mkJudgementAndContext features g binds rss tcg = do - let tcs = fmap tcg_binds tcg - ctx = mkContext features - (mapMaybe (sequenceA . (occName *** coerce)) - $ getDefiningBindings (unTrack binds) $ unTrack rss) - (unTrack tcg) - top_provs = getRhsPosVals rss tcs - local_hy = spliceProvenance top_provs - $ hypothesisFromBindings rss binds - evidence = getEvidenceAtHole (fmap RealSrcSpan rss) tcs - cls_hy = foldMap evidenceToHypothesis evidence - subst = ts_unifier $ appEndo (foldMap (Endo . evidenceToSubst) evidence) defaultTacticState - in ( fmap (CType . substTyAddInScope subst . unCType) $ mkFirstJudgement - (local_hy <> cls_hy) - (isRhsHole rss tcs) - g - , ctx - ) + -> TrackedStale Bindings + -> Tracked 'Current RealSrcSpan + -> TrackedStale TcGblEnv + -> Maybe (Judgement, Context) +mkJudgementAndContext features g (TrackedStale binds bmap) rss (TrackedStale tcg tcgmap) = do + binds_rss <- mapAgeFrom bmap rss + tcg_rss <- mapAgeFrom tcgmap rss + + let tcs = fmap tcg_binds tcg + ctx = mkContext features + (mapMaybe (sequenceA . (occName *** coerce)) + $ unTrack + $ getDefiningBindings <$> binds <*> binds_rss) + (unTrack tcg) + top_provs = getRhsPosVals tcg_rss tcs + local_hy = spliceProvenance top_provs + $ hypothesisFromBindings binds_rss binds + evidence = getEvidenceAtHole (fmap RealSrcSpan tcg_rss) tcs + cls_hy = foldMap evidenceToHypothesis evidence + subst = ts_unifier $ appEndo (foldMap (Endo . evidenceToSubst) evidence) defaultTacticState + pure + ( fmap (CType . substTyAddInScope subst . unCType) $ mkFirstJudgement + (local_hy <> cls_hy) + (isRhsHole tcg_rss tcs) + g + , ctx + ) getSpanAndTypeAtHole diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index 1d9f46d587..fadf0c24db 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -90,7 +90,8 @@ tacticCmd tac pId state (TacticParams uri range var_name) res <- liftIO $ runMaybeT $ do (range', jdg, ctx, dflags) <- judgementForHole state nfp range features let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath nfp)) range' - pm <- runStaleIde state nfp GetAnnotatedParsedSource + TrackedStale pm pmmap <- runStaleIde state nfp GetAnnotatedParsedSource + pm_span <- liftMaybe $ mapAgeFrom pmmap span timingOut 2e8 $ join $ case runTactic ctx jdg $ tac $ mkVarOcc $ T.unpack var_name of @@ -99,7 +100,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 (unTrack span) dflags ccs uri pm rtr + _ -> pure $ mkWorkspaceEdits pm_span dflags ccs uri pm rtr case res of Nothing -> do @@ -131,14 +132,14 @@ mkErr code err = ResponseError code err Nothing -- | Turn a 'RunTacticResults' into concrete edits to make in the source -- document. mkWorkspaceEdits - :: RealSrcSpan + :: Tracked age RealSrcSpan -> DynFlags -> ClientCapabilities -> Uri - -> Annotated ParsedSource + -> Tracked age (Annotated ParsedSource) -> RunTacticResults -> Either UserFacingMessage WorkspaceEdit -mkWorkspaceEdits span dflags ccs uri pm rtr = do +mkWorkspaceEdits (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) [] diff --git a/plugins/hls-tactics-plugin/src/Wingman/Range.hs b/plugins/hls-tactics-plugin/src/Wingman/Range.hs index 15ffa79c08..1f0278c6c6 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Range.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Range.hs @@ -5,16 +5,18 @@ module Wingman.Range ( module Wingman.Range ) where +import Control.Arrow +import Control.Category (Category) +import qualified Control.Category as C import Control.DeepSeq (NFData) import Data.Aeson import Data.Coerce (coerce) +import Data.Functor.Identity (Identity(Identity)) import Data.Kind (Type) import Development.IDE hiding (rangeToRealSrcSpan) import qualified Development.IDE.Core.PositionMapping as P import qualified FastString as FS import SrcLoc -import Generics.SYB -import Data.Functor.Identity (Identity(Identity)) @@ -37,25 +39,62 @@ data Age = Current | Stale Type newtype Tracked (age :: Age) a = Tracked { unTrack :: a } - deriving stock Functor + deriving stock (Functor, Foldable, Traversable) deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData) deriving Applicative via Identity -newtype PositionMapping s = PositionMapping +newtype PositionMapping (from :: Age) (to :: Age) = PositionMapping { getPositionMapping :: P.PositionMapping } +dual :: PositionMapping from to -> PositionMapping to from +dual (PositionMapping (P.PositionMapping (P.PositionDelta from to))) = + PositionMapping $ P.PositionMapping $ P.PositionDelta to from + +instance Category PositionMapping where + id = coerce P.zeroMapping + (.) = coerce P.composeDelta + data TrackedStale a where TrackedStale :: Tracked (Stale s) a - -> PositionMapping s + -> PositionMapping (Stale s) Current -> TrackedStale a instance Functor TrackedStale where fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm +class MapAge a where + {-# MINIMAL mapAgeFrom | mapAgeTo #-} + mapAgeFrom :: PositionMapping from to -> Tracked to a -> Maybe (Tracked from a) + mapAgeFrom = mapAgeTo . dual + + mapAgeTo :: PositionMapping from to -> Tracked from a -> Maybe (Tracked to a) + mapAgeTo = mapAgeFrom . dual + + +instance MapAge Range where + mapAgeFrom = coerce P.fromCurrentRange + mapAgeTo = coerce P.toCurrentRange + + +instance MapAge RealSrcSpan where + mapAgeFrom = + invMapAge (\fs -> rangeToRealSrcSpan (FS.unpackFS fs)) + (srcSpanFile &&& realSrcSpanToRange) + . mapAgeFrom + +invMapAge + :: (c -> a -> b) + -> (b -> (c, a)) + -> (Tracked from a -> Maybe (Tracked to a)) + -> Tracked from b + -> Maybe (Tracked to b) +invMapAge to from f t = + let (c, t') = unTrack $ fmap from t + in fmap (fmap $ to c) $ f $ Tracked t' cautiousToCurrent :: age -> Tracked 'Current age @@ -69,39 +108,9 @@ cautiousCopyAge :: Tracked age a -> b -> Tracked age b cautiousCopyAge _ = coerce -fromCurrentRange - :: PositionMapping s - -> Tracked 'Current Range - -> Maybe (Tracked (Stale s) Range) -fromCurrentRange = coerce P.fromCurrentRange - - -toCurrentRange - :: PositionMapping s - -> Tracked (Stale s) Range - -> Maybe (Tracked 'Current Range) -toCurrentRange = coerce P.toCurrentRange - -unsafeToCurrentRange :: PositionMapping s -> Range -> Maybe Range -unsafeToCurrentRange = coerce P.toCurrentRange - - -mapRangeOfRealSrcSpan :: Functor f => (Range -> f Range) -> RealSrcSpan -> f RealSrcSpan +mapRangeOfRealSrcSpan :: (Range -> Maybe Range) -> RealSrcSpan -> Maybe RealSrcSpan mapRangeOfRealSrcSpan f rss = fmap (rangeToRealSrcSpan $ FS.unpackFS $ srcSpanFile rss) . f $ realSrcSpanToRange rss - -mapPositionsToCurrent - :: Data a - => PositionMapping s - -> Tracked (Stale s) a - -> Maybe (Tracked Current a) -mapPositionsToCurrent (PositionMapping am) (Tracked t) - = fmap Tracked - $ everywhereM - ( mkM (P.toCurrentRange am) - `extM` (mapRangeOfRealSrcSpan (P.toCurrentRange am)) - ) t - From a648a2521c531006b343c5827f97a9f8ecd681e6 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Sat, 3 Apr 2021 12:58:00 -0700 Subject: [PATCH 05/21] Formatting --- plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index c58fdf1237..90584b815b 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -185,7 +185,7 @@ mkJudgementAndContext features g (TrackedStale binds bmap) rss (TrackedStale tcg (unTrack tcg) top_provs = getRhsPosVals tcg_rss tcs local_hy = spliceProvenance top_provs - $ hypothesisFromBindings binds_rss binds + $ hypothesisFromBindings binds_rss binds evidence = getEvidenceAtHole (fmap RealSrcSpan tcg_rss) tcs cls_hy = foldMap evidenceToHypothesis evidence subst = ts_unifier $ appEndo (foldMap (Endo . evidenceToSubst) evidence) defaultTacticState From f1b1c492c5aa54043fa4419cb2e77c701260f144 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Sun, 4 Apr 2021 14:30:18 -0700 Subject: [PATCH 06/21] Haddock and small changes --- .../src/Wingman/LanguageServer.hs | 2 +- .../hls-tactics-plugin/src/Wingman/Range.hs | 54 ++++++++++++------- 2 files changed, 36 insertions(+), 20 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 90584b815b..daaaaf2938 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -213,7 +213,7 @@ getSpanAndTypeAtHole (unTrack -> range) (unTrack -> hf) = do -- Ensure we're actually looking at a hole here guard $ all (either (const False) $ isHole . occName) $ M.keysSet $ nodeIdentifiers info - pure (Tracked $ nodeSpan ast', ty) + pure (UnsafeTracked $ nodeSpan ast', ty) liftMaybe :: Monad m => Maybe a -> MaybeT m a diff --git a/plugins/hls-tactics-plugin/src/Wingman/Range.hs b/plugins/hls-tactics-plugin/src/Wingman/Range.hs index 1f0278c6c6..ede4b2fb67 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Range.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Range.hs @@ -1,9 +1,7 @@ {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RankNTypes #-} -module Wingman.Range - ( module Wingman.Range - ) where +module Wingman.Range where import Control.Arrow import Control.Category (Category) @@ -13,7 +11,7 @@ import Data.Aeson import Data.Coerce (coerce) import Data.Functor.Identity (Identity(Identity)) import Data.Kind (Type) -import Development.IDE hiding (rangeToRealSrcSpan) +import Development.IDE hiding (rangeToRealSrcSpan, rangeToSrcSpan) import qualified Development.IDE.Core.PositionMapping as P import qualified FastString as FS import SrcLoc @@ -34,29 +32,46 @@ rangeToRealSrcSpan file (Range (Position startLn startCh) (Position endLn endCh) (mkRealSrcLoc (FS.fsLit file) (endLn + 1) (endCh + 1)) +------------------------------------------------------------------------------ +-- | A data kind for 'Tracked'. data Age = Current | Stale Type -newtype Tracked (age :: Age) a = Tracked + +------------------------------------------------------------------------------ +-- | Some value, tagged with its age. All 'Current' ages are considered to be +-- the same thing, but 'Stale' values are protected by an untouchable variable +-- to ensure they can't be unified. +newtype Tracked (age :: Age) a = UnsafeTracked { unTrack :: a } deriving stock (Functor, Foldable, Traversable) deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData) - deriving Applicative via Identity + deriving (Applicative, Monad) via Identity +------------------------------------------------------------------------------ +-- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values +-- change. Use the 'Category' instance to compose 'PositionMapping's in order +-- to transform between values of different stale ages. newtype PositionMapping (from :: Age) (to :: Age) = PositionMapping { getPositionMapping :: P.PositionMapping } -dual :: PositionMapping from to -> PositionMapping to from -dual (PositionMapping (P.PositionMapping (P.PositionDelta from to))) = - PositionMapping $ P.PositionMapping $ P.PositionDelta to from - instance Category PositionMapping where id = coerce P.zeroMapping (.) = coerce P.composeDelta +------------------------------------------------------------------------------ +-- | Run a 'PositionMapping' backwards. +dual :: PositionMapping from to -> PositionMapping to from +dual (PositionMapping (P.PositionMapping (P.PositionDelta from to))) = + PositionMapping $ P.PositionMapping $ P.PositionDelta to from + + +------------------------------------------------------------------------------ +-- | A pair containing a @'Tracked' 'Stale'@ value, as well as +-- a 'PositionMapping' that will fast-forward values to the current age. data TrackedStale a where TrackedStale :: Tracked (Stale s) a @@ -66,6 +81,10 @@ data TrackedStale a where instance Functor TrackedStale where fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm + +------------------------------------------------------------------------------ +-- | A class for which 'Tracked' values can be run across a 'PositionMapping' +-- to change their ages. class MapAge a where {-# MINIMAL mapAgeFrom | mapAgeTo #-} mapAgeFrom :: PositionMapping from to -> Tracked to a -> Maybe (Tracked from a) @@ -86,6 +105,10 @@ instance MapAge RealSrcSpan where (srcSpanFile &&& realSrcSpanToRange) . mapAgeFrom + +------------------------------------------------------------------------------ +-- | Helper function for deriving 'MapAge' for values in terms of other +-- instances. invMapAge :: (c -> a -> b) -> (b -> (c, a)) @@ -94,7 +117,7 @@ invMapAge -> Maybe (Tracked to b) invMapAge to from f t = let (c, t') = unTrack $ fmap from t - in fmap (fmap $ to c) $ f $ Tracked t' + in fmap (fmap $ to c) $ f $ UnsafeTracked t' cautiousToCurrent :: age -> Tracked 'Current age @@ -107,10 +130,3 @@ cautiousToStale = coerce cautiousCopyAge :: Tracked age a -> b -> Tracked age b cautiousCopyAge _ = coerce - -mapRangeOfRealSrcSpan :: (Range -> Maybe Range) -> RealSrcSpan -> Maybe RealSrcSpan -mapRangeOfRealSrcSpan f rss - = fmap (rangeToRealSrcSpan $ FS.unpackFS $ srcSpanFile rss) - . f - $ realSrcSpanToRange rss - From 4b77f7f5cbdcdefc87d0355f1564117dbd353117 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Sun, 4 Apr 2021 15:05:31 -0700 Subject: [PATCH 07/21] Update haddock on IdeAction --- ghcide/src/Development/IDE/Core/Shake.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 85c3dd1406..35b6456afa 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -828,12 +828,14 @@ usesWithStale_ key files = do Nothing -> liftIO $ throwIO $ BadDependency (show key) Just v -> return v -newtype IdeAction a = IdeAction { runIdeActionT :: (ReaderT ShakeExtras IO) a } - deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad) - -- | IdeActions are used when we want to return a result immediately, even if it -- is stale Useful for UI actions like hover, completion where we don't want to -- block. +-- +-- Run via 'runIdeAction'. +newtype IdeAction a = IdeAction { runIdeActionT :: (ReaderT ShakeExtras IO) a } + deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad) + runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a runIdeAction _herald s i = runReaderT (runIdeActionT i) s From 2285f68523673c54fa8104f8b80bb757af7e09b8 Mon Sep 17 00:00:00 2001 From: wz1000 Date: Thu, 1 Apr 2021 22:14:08 +0530 Subject: [PATCH 08/21] Update to lsp-1.2 (#1631) * Update to lsp-1.2 * fix stack * fix splice plugin tests * fix tactic plugin tests * fix some tests * fix some tests * fix outline tests * hlint * fix func-test --- cabal.project | 2 +- ghcide/exe/Main.hs | 3 +- ghcide/ghcide.cabal | 8 +-- ghcide/src/Development/IDE/Core/Shake.hs | 12 ++-- .../src/Development/IDE/LSP/LanguageServer.hs | 11 ++- .../src/Development/IDE/LSP/Notifications.hs | 1 - ghcide/src/Development/IDE/LSP/Outline.hs | 7 +- ghcide/src/Development/IDE/Main.hs | 10 +-- .../src/Development/IDE/Plugin/CodeAction.hs | 11 ++- .../IDE/Plugin/CodeAction/ExactPrint.hs | 1 + .../IDE/Plugin/Completions/Logic.hs | 9 +-- ghcide/src/Development/IDE/Plugin/HLS.hs | 21 +++--- .../src/Development/IDE/Plugin/TypeLenses.hs | 2 +- ghcide/src/Development/IDE/Spans/AtPoint.hs | 2 +- ghcide/test/exe/Main.hs | 68 ++++++++++--------- haskell-language-server.cabal | 2 +- hls-plugin-api/hls-plugin-api.cabal | 2 +- hls-plugin-api/src/Ide/Plugin/Properties.hs | 7 +- hls-plugin-api/src/Ide/PluginUtils.hs | 16 ++--- hls-plugin-api/src/Ide/Types.hs | 6 +- hls-test-utils/hls-test-utils.cabal | 4 +- hls-test-utils/src/Test/Hls/Util.hs | 2 +- plugins/default/src/Ide/Plugin/Example.hs | 10 +-- plugins/default/src/Ide/Plugin/Example2.hs | 10 +-- plugins/default/src/Ide/Plugin/Fourmolu.hs | 2 +- plugins/default/src/Ide/Plugin/ModuleName.hs | 2 +- plugins/default/src/Ide/Plugin/Ormolu.hs | 2 +- plugins/default/src/Ide/Plugin/Pragmas.hs | 4 +- .../hls-class-plugin/src/Ide/Plugin/Class.hs | 5 +- .../src/Ide/Plugin/Eval/CodeLens.hs | 2 +- .../src/Ide/Plugin/ExplicitImports.hs | 10 +-- .../src/Ide/Plugin/HaddockComments.hs | 3 + .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 4 +- .../src/Ide/Plugin/Retrie.hs | 4 +- .../src/Ide/Plugin/Splice.hs | 20 ++++-- plugins/hls-splice-plugin/test/Main.hs | 2 +- .../Wingman/LanguageServer/TacticProviders.hs | 16 +++-- plugins/hls-tactics-plugin/test/Utils.hs | 2 +- stack-8.10.2.yaml | 6 +- stack-8.10.3.yaml | 6 +- stack-8.10.4.yaml | 6 +- stack-8.6.4.yaml | 6 +- stack-8.6.5.yaml | 6 +- stack-8.8.2.yaml | 6 +- stack-8.8.3.yaml | 6 +- stack-8.8.4.yaml | 6 +- stack.yaml | 6 +- test/functional/FunctionalCodeAction.hs | 4 +- test/functional/Symbol.hs | 40 +++++------ 49 files changed, 212 insertions(+), 191 deletions(-) diff --git a/cabal.project b/cabal.project index 745f326e6e..f3b33a86bc 100644 --- a/cabal.project +++ b/cabal.project @@ -27,7 +27,7 @@ package ghcide write-ghc-environment-files: never -index-state: 2021-03-02T21:23:14Z +index-state: 2021-03-29T21:23:14Z allow-newer: active:base, diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 042afed11c..041c6a6186 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -12,7 +12,6 @@ import Control.Monad.Extra (unless, when, whenJust) import qualified Data.Aeson.Encode.Pretty as A import Data.Default (Default (def)) import Data.List.Extra (upper) -import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Text.Lazy.Encoding (decodeUtf8) @@ -122,7 +121,7 @@ main = do then Test.plugin else mempty - ,Main.argsIdeOptions = \(fromMaybe def -> config) sessionLoader -> + ,Main.argsIdeOptions = \config sessionLoader -> let defOptions = defaultIdeOptions sessionLoader in defOptions { optShakeProfiling = argsShakeProfiling diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 82417ac0e3..e61b07aa88 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -59,8 +59,8 @@ library hls-plugin-api ^>= 1.1.0.0, lens, hiedb == 0.3.0.1, - lsp-types == 1.1.*, - lsp == 1.1.1.0, + lsp-types == 1.2.*, + lsp == 1.2.*, mtl, network-uri, parallel, @@ -339,7 +339,7 @@ test-suite ghcide-tests hls-plugin-api, network-uri, lens, - lsp-test == 0.13.0.0, + lsp-test == 0.14.0.0, optparse-applicative, process, QuickCheck, @@ -396,7 +396,7 @@ executable ghcide-bench extra, filepath, ghcide, - lsp-test == 0.13.0.0, + lsp-test == 0.14.0.0, optparse-applicative, process, safe-exceptions, diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 35b6456afa..f3d18eb40f 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -50,7 +50,7 @@ module Development.IDE.Core.Shake( getIdeOptions, getIdeOptionsIO, GlobalIdeOptions(..), - getClientConfig, + HLS.getClientConfig, getPluginConfig, garbageCollect, knownTargets, @@ -230,14 +230,10 @@ getShakeExtrasRules = do Just x <- getShakeExtraRules @ShakeExtras return x -getClientConfig :: LSP.MonadLsp Config m => ShakeExtras -> m Config -getClientConfig ShakeExtras { defaultConfig } = - fromMaybe defaultConfig <$> HLS.getClientConfig - getPluginConfig - :: LSP.MonadLsp Config m => ShakeExtras -> PluginId -> m PluginConfig -getPluginConfig extras plugin = do - config <- getClientConfig extras + :: LSP.MonadLsp Config m => PluginId -> m PluginConfig +getPluginConfig plugin = do + config <- HLS.getClientConfig return $ HLS.configForPlugin config plugin -- | Register a function that will be called to get the "stale" result of a rule, possibly from disk diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index bc8a121c8b..53a2aee1e0 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -23,7 +23,6 @@ import Data.Aeson (Value) import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T -import qualified Development.IDE.GHC.Util as Ghcide import Development.IDE.LSP.Server import Development.IDE.Session (runWithDb) import Ide.Types (traceWithSpan) @@ -50,11 +49,12 @@ runLanguageServer -> Handle -- input -> Handle -- output -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project - -> (IdeState -> Value -> IO (Either T.Text config)) + -> config + -> (config -> Value -> Either T.Text config) -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> HieDb -> IndexQueue -> IO IdeState) -> IO () -runLanguageServer options inH outH getHieDbLoc onConfigurationChange userHandlers getIdeState = do +runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do -- These barriers are signaled when the threads reading from these chans exit. -- This should not happen but if it does, we will make sure that the whole server @@ -103,9 +103,8 @@ runLanguageServer options inH outH getHieDbLoc onConfigurationChange userHandler let serverDefinition = LSP.ServerDefinition - { LSP.onConfigurationChange = \v -> do - (_chan, ide) <- ask - liftIO $ onConfigurationChange ide v + { LSP.onConfigurationChange = onConfigurationChange + , LSP.defaultConfig = defaultConfig , LSP.doInitialize = handleInit exit clearReqId waitForCancel clientMsgChan , LSP.staticHandlers = asyncHandlers , LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index e1909691f9..883e97bdf9 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -19,7 +19,6 @@ import qualified Language.LSP.Types.Capabilities as LSP import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.LSP.Server import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index f6897aaa6d..046c0c9339 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -19,7 +19,7 @@ import qualified Data.Text as T import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.GHC.Compat -import Development.IDE.GHC.Error (realSrcSpanToRange) +import Development.IDE.GHC.Error (realSrcSpanToRange, rangeToRealSrcSpan) import Development.IDE.Types.Location import Language.LSP.Server (LspM) import Language.LSP.Types @@ -183,12 +183,10 @@ documentSymbolForImportSummary importSymbols = mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs) importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols in - Just (defDocumentSymbol empty :: DocumentSymbol) + Just (defDocumentSymbol (rangeToRealSrcSpan "" importRange)) { _name = "imports" , _kind = SkModule , _children = Just (List importSymbols) - , _range = importRange - , _selectionRange = importRange } documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol @@ -213,6 +211,7 @@ defDocumentSymbol l = DocumentSymbol { .. } where _range = realSrcSpanToRange l _selectionRange = realSrcSpanToRange l _children = Nothing + _tags = Nothing showRdrName :: RdrName -> Text showRdrName = pprText diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 6efc21c17b..778f4536bd 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -88,7 +88,7 @@ data Arguments = Arguments , argsHlsPlugins :: IdePlugins IdeState , argsGhcidePlugin :: Plugin Config -- ^ Deprecated , argsSessionLoadingOptions :: SessionLoadingOptions - , argsIdeOptions :: Maybe Config -> Action IdeGhcSession -> IdeOptions + , argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions , argsLspOptions :: LSP.Options , argsDefaultHlsConfig :: Config , argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project @@ -142,11 +142,11 @@ defaultMain Arguments{..} = do logger <- argsLogger hSetBuffering stderr LineBuffering - let hlsPlugin = asGhcIdePlugin argsDefaultHlsConfig argsHlsPlugins + let hlsPlugin = asGhcIdePlugin argsHlsPlugins hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin options = argsLspOptions { LSP.executeCommandCommands = Just hlsCommands } - argsOnConfigChange _ide = pure . getConfigFromNotification argsDefaultHlsConfig + argsOnConfigChange = getConfigFromNotification rules = argsRules >> pluginRules plugins debouncer <- argsDebouncer @@ -158,7 +158,7 @@ defaultMain Arguments{..} = do t <- offsetTime hPutStrLn stderr "Starting LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - runLanguageServer options inH outH argsGetHieDbLoc argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do + runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t @@ -214,7 +214,7 @@ defaultMain Arguments{..} = do putStrLn "\nStep 3/4: Initializing the IDE" vfs <- makeVFSHandle sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir - let options = (argsIdeOptions Nothing sessionLoader) + let options = (argsIdeOptions argsDefaultHlsConfig sessionLoader) { optCheckParents = pure NeverCheck , optCheckProject = pure False } diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index a1b54841bc..857e686c7b 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -117,7 +117,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod actions = [ mkCA title kind isPreferred [x] edit | x <- xs, (title, kind, isPreferred, tedit) <- suggestAction $ CodeActionArgs exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings gblSigs x - , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing ] actions' = caRemoveRedundantImports parsedModule text diag xs uri <> actions @@ -126,7 +126,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) mkCA title kind isPreferred diags edit = - InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing + InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing Nothing suggestAction :: CodeActionArgs -> GhcideCodeActions suggestAction caa = @@ -282,6 +282,7 @@ caRemoveRedundantImports m contents digs ctxDigs uri removeSingle title tedit diagnostic = mkCA title (Just CodeActionQuickFix) Nothing [diagnostic] WorkspaceEdit{..} where _changes = Just $ Map.singleton uri $ List tedit _documentChanges = Nothing + _changeAnnotations = Nothing removeAll tedit = InR $ CodeAction{..} where _changes = Just $ Map.singleton uri $ List tedit _title = "Remove all redundant imports" @@ -292,6 +293,8 @@ caRemoveRedundantImports m contents digs ctxDigs uri _isPreferred = Nothing _command = Nothing _disabled = Nothing + _xdata = Nothing + _changeAnnotations = Nothing caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] caRemoveInvalidExports m contents digs ctxDigs uri @@ -328,6 +331,8 @@ caRemoveInvalidExports m contents digs ctxDigs uri _command = Nothing _isPreferred = Nothing _disabled = Nothing + _xdata = Nothing + _changeAnnotations = Nothing removeAll [] = Nothing removeAll ranges = Just $ InR $ CodeAction{..} where tedit = concatMap (\r -> [TextEdit r ""]) ranges @@ -340,6 +345,8 @@ caRemoveInvalidExports m contents digs ctxDigs uri _command = Nothing _isPreferred = Nothing _disabled = Nothing + _xdata = Nothing + _changeAnnotations = Nothing suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range]) suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 403c318f8e..fcd8625d59 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -83,6 +83,7 @@ rewriteToWEdit dflags uri anns r = do WorkspaceEdit { _changes = Just (fromList [(uri, List edits)]) , _documentChanges = Nothing + , _changeAnnotations = Nothing } ------------------------------------------------------------------------------ diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 94cdfc6a9d..dcbe94376d 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -186,6 +186,7 @@ mkCompl _filterText = Nothing, _insertText = Just insertText, _insertTextFormat = Just Snippet, + _insertTextMode = Nothing, _textEdit = Nothing, _additionalTextEdits = Nothing, _commitCharacters = Nothing, @@ -272,13 +273,13 @@ mkModCompl :: T.Text -> CompletionItem mkModCompl label = CompletionItem label (Just CiModule) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing mkImportCompl :: T.Text -> T.Text -> CompletionItem mkImportCompl enteredQual label = CompletionItem m (Just CiModule) Nothing (Just label) Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing where m = fromMaybe "" (T.stripPrefix enteredQual label) @@ -286,13 +287,13 @@ mkExtCompl :: T.Text -> CompletionItem mkExtCompl label = CompletionItem label (Just CiKeyword) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing mkPragmaCompl :: T.Text -> T.Text -> CompletionItem mkPragmaCompl label insertText = CompletionItem label (Just CiKeyword) Nothing Nothing Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) - Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> IO CachedCompletions diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 1a87e36582..66d611ea14 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -20,7 +20,6 @@ import Data.Either import qualified Data.List as List import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) import Data.String import qualified Data.Text as T import Development.IDE.Core.Shake @@ -44,12 +43,12 @@ import UnliftIO.Exception (catchAny) -- -- | Map a set of plugins to the underlying ghcide engine. -asGhcIdePlugin :: Config -> IdePlugins IdeState -> Plugin Config -asGhcIdePlugin defaultConfig mp = +asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config +asGhcIdePlugin mp = mkPlugin rulesPlugins HLS.pluginRules <> mkPlugin executeCommandPlugins HLS.pluginCommands <> - mkPlugin (extensiblePlugins defaultConfig) HLS.pluginHandlers <> - mkPlugin (extensibleNotificationPlugins defaultConfig) HLS.pluginNotificationHandlers + mkPlugin extensiblePlugins HLS.pluginHandlers <> + mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers where ls = Map.toList (ipMap mp) @@ -133,8 +132,8 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd -- --------------------------------------------------------------------- -extensiblePlugins :: Config -> [(PluginId, PluginHandlers IdeState)] -> Plugin Config -extensiblePlugins defaultConfig xs = Plugin mempty handlers +extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config +extensiblePlugins xs = Plugin mempty handlers where IdeHandlers handlers' = foldMap bakePluginId xs bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers @@ -144,7 +143,7 @@ extensiblePlugins defaultConfig xs = Plugin mempty handlers handlers = mconcat $ do (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers' pure $ requestHandler m $ \ide params -> do - config <- fromMaybe defaultConfig <$> Ide.PluginUtils.getClientConfig + config <- Ide.PluginUtils.getClientConfig let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs' case nonEmpty fs of Nothing -> pure $ Left $ ResponseError InvalidRequest @@ -161,8 +160,8 @@ extensiblePlugins defaultConfig xs = Plugin mempty handlers pure $ Right $ combineResponses m config caps params xs -- --------------------------------------------------------------------- -extensibleNotificationPlugins :: Config -> [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config -extensibleNotificationPlugins defaultConfig xs = Plugin mempty handlers +extensibleNotificationPlugins :: [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config +extensibleNotificationPlugins xs = Plugin mempty handlers where IdeNotificationHandlers handlers' = foldMap bakePluginId xs bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers @@ -172,7 +171,7 @@ extensibleNotificationPlugins defaultConfig xs = Plugin mempty handlers handlers = mconcat $ do (IdeNotification m :=> IdeNotificationHandler fs') <- DMap.assocs handlers' pure $ notificationHandler m $ \ide params -> do - config <- fromMaybe defaultConfig <$> Ide.PluginUtils.getClientConfig + config <- Ide.PluginUtils.getClientConfig let fs = filter (\(pid,_) -> plcGlobalOn $ configForPlugin config pid) fs' case nonEmpty fs of Nothing -> do diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 196c161212..dfeed10713 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -117,7 +117,7 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif diag <- getDiagnostics ideState hDiag <- getHiddenDiagnostics ideState - let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing generateLensForGlobal sig@GlobalBindingTypeSig{..} = do range <- srcSpanToRange $ gbSrcSpan sig tedit <- gblBindingTypeSigToEdit sig diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 2ae56b2cca..0d33e88dff 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -344,7 +344,7 @@ toUri = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' defRowToSymbolInfo :: Res DefRow -> Maybe SymbolInformation defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile)) - = Just $ SymbolInformation (showGhc defNameOcc) kind Nothing loc Nothing + = Just $ SymbolInformation (showGhc defNameOcc) kind Nothing Nothing loc Nothing where kind | isVarOcc defNameOcc = SkVariable diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index f8e39b025f..28081dbb65 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -846,7 +846,7 @@ typeWildCardActionTests = testGroup "type wildcard actions" ] doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) + actionsOrCommands <- getAllCodeActions doc let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands , "Use type signature" `T.isInfixOf` actionTitle ] @@ -866,7 +866,7 @@ typeWildCardActionTests = testGroup "type wildcard actions" ] doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) + actionsOrCommands <- getAllCodeActions doc let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands , "Use type signature" `T.isInfixOf` actionTitle ] @@ -889,7 +889,7 @@ typeWildCardActionTests = testGroup "type wildcard actions" ] doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10)) + actionsOrCommands <- getAllCodeActions doc let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands , "Use type signature" `T.isInfixOf` actionTitle ] @@ -906,6 +906,7 @@ typeWildCardActionTests = testGroup "type wildcard actions" liftIO $ expectedContentAfterAction @=? contentAfterAction ] +{-# HLINT ignore "Use nubOrd" #-} removeImportTests :: TestTree removeImportTests = testGroup "remove import actions" [ testSession "redundant" $ do @@ -1111,7 +1112,7 @@ removeImportTests = testGroup "remove import actions" doc <- createDoc "ModuleC.hs" "haskell" content _ <- waitForDiagnostics [_, _, _, _, InR action@CodeAction { _title = actionTitle }] - <- getCodeActions doc (Range (Position 2 0) (Position 2 5)) + <- nub <$> getAllCodeActions doc liftIO $ "Remove all redundant imports" @=? actionTitle executeCodeAction action contentAfterAction <- documentContents doc @@ -1149,7 +1150,7 @@ extendImportTests = testGroup "extend import actions" , "import ModuleA as A (stuffB)" , "main = print (stuffA, stuffB)" ]) - (Range (Position 3 17) (Position 3 18)) + (Range (Position 2 17) (Position 2 18)) ["Add stuffA to the import list of ModuleA"] (T.unlines [ "module ModuleB where" @@ -1169,7 +1170,7 @@ extendImportTests = testGroup "extend import actions" , "import ModuleA as A (stuffB)" , "main = print (stuffB .* stuffB)" ]) - (Range (Position 3 17) (Position 3 18)) + (Range (Position 2 17) (Position 2 18)) ["Add (.*) to the import list of ModuleA"] (T.unlines [ "module ModuleB where" @@ -1206,7 +1207,7 @@ extendImportTests = testGroup "extend import actions" , "b :: A" , "b = Constructor" ]) - (Range (Position 2 5) (Position 2 5)) + (Range (Position 3 5) (Position 3 5)) ["Add A(Constructor) to the import list of ModuleA"] (T.unlines [ "module ModuleB where" @@ -1225,7 +1226,7 @@ extendImportTests = testGroup "extend import actions" , "b :: A" , "b = Constructor" ]) - (Range (Position 2 5) (Position 2 5)) + (Range (Position 3 5) (Position 3 5)) ["Add A(Constructor) to the import list of ModuleA"] (T.unlines [ "module ModuleB where" @@ -1245,7 +1246,7 @@ extendImportTests = testGroup "extend import actions" , "b :: A" , "b = ConstructorFoo" ]) - (Range (Position 2 5) (Position 2 5)) + (Range (Position 3 5) (Position 3 5)) ["Add A(ConstructorFoo) to the import list of ModuleA"] (T.unlines [ "module ModuleB where" @@ -1266,7 +1267,7 @@ extendImportTests = testGroup "extend import actions" , "import qualified ModuleA as A (stuffB)" , "main = print (A.stuffA, A.stuffB)" ]) - (Range (Position 3 17) (Position 3 18)) + (Range (Position 2 17) (Position 2 18)) ["Add stuffA to the import list of ModuleA"] (T.unlines [ "module ModuleB where" @@ -1682,9 +1683,7 @@ suggestImportDisambiguationTests = testGroup "suggest import disambiguation acti doc <- openDoc file "haskell" waitForProgressDone void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])] - contents <- documentContents doc - let range = Range (Position 0 0) (Position (length $ T.lines contents) 0) - actions <- getCodeActions doc range + actions <- getAllCodeActions doc k doc actions withHideFunction = withTarget ("HideFunction" <.> "hs") @@ -1891,7 +1890,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions" _ <- waitForDiagnostics InR action@CodeAction { _title = actionTitle } : _ <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 1 0 1 50) + getCodeActions docB (R 0 0 0 50) liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" executeCodeAction action contentAfterAction <- documentContents docB @@ -1915,7 +1914,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions" _ <- waitForDiagnostics InR action@CodeAction { _title = actionTitle } : _ <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 1 0 1 50) + getCodeActions docB (R 0 0 0 50) liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" executeCodeAction action contentAfterAction <- documentContents docB @@ -2063,15 +2062,15 @@ deleteUnusedDefinitionTests = testGroup "delete unused definition action" docId <- createDoc "A.hs" "haskell" source expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ] - (action, title) <- extractCodeAction docId "Delete" + (action, title) <- extractCodeAction docId "Delete" pos liftIO $ title @?= expectedTitle executeCodeAction action contentAfterAction <- documentContents docId liftIO $ contentAfterAction @?= expectedResult - extractCodeAction docId actionPrefix = do - [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix] + extractCodeAction docId actionPrefix (l, c) = do + [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R l c l c) [actionPrefix] return (action, actionTitle) addTypeAnnotationsToLiteralsTest :: TestTree @@ -2196,15 +2195,16 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t docId <- createDoc "A.hs" "haskell" source expectDiagnostics [ ("A.hs", diag) ] - (action, title) <- extractCodeAction docId "Add type annotation" + let cursors = map snd3 diag + (action, title) <- extractCodeAction docId "Add type annotation" (minimum cursors) (maximum cursors) liftIO $ title @?= expectedTitle executeCodeAction action contentAfterAction <- documentContents docId liftIO $ contentAfterAction @?= expectedResult - extractCodeAction docId actionPrefix = do - [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix] + extractCodeAction docId actionPrefix (l,c) (l', c')= do + [action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R l c l' c') [actionPrefix] return (action, actionTitle) @@ -2250,7 +2250,7 @@ importRenameActionTests = testGroup "import rename actions" ] doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16)) + actionsOrCommands <- getCodeActions doc (Range (Position 1 8) (Position 1 16)) let [changeToMap] = [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] executeCodeAction changeToMap contentAfterAction <- documentContents doc @@ -2380,7 +2380,7 @@ addInstanceConstraintTests = let check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do doc <- createDoc "Testing.hs" "haskell" originalCode _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 68)) + actionsOrCommands <- getAllCodeActions doc chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands executeCodeAction chosenAction modifiedCode <- documentContents doc @@ -2532,7 +2532,7 @@ checkCodeAction :: String -> T.Text -> T.Text -> T.Text -> TestTree checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do doc <- createDoc "Testing.hs" "haskell" originalCode _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound)) + actionsOrCommands <- getAllCodeActions doc chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands executeCodeAction chosenAction modifiedCode <- documentContents doc @@ -2615,7 +2615,7 @@ removeRedundantConstraintsTests = let check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do doc <- createDoc "Testing.hs" "haskell" originalCode _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound)) + actionsOrCommands <- getAllCodeActions doc chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands executeCodeAction chosenAction modifiedCode <- documentContents doc @@ -2625,7 +2625,7 @@ removeRedundantConstraintsTests = let checkPeculiarFormatting title code = testSession title $ do doc <- createDoc "Testing.hs" "haskell" code _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound)) + actionsOrCommands <- getAllCodeActions doc liftIO $ assertBool "Found some actions" (null actionsOrCommands) in testGroup "remove redundant function constraints" @@ -2769,7 +2769,7 @@ exportUnusedTests = testGroup "export unused actions" , " ) where" , "foo = id" , "bar = foo"]) - (R 4 0 4 3) + (R 5 0 5 3) "Export ‘bar’" (Just $ T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" @@ -4286,19 +4286,20 @@ outlineTests = testGroup ] where docSymbol name kind loc = - DocumentSymbol name Nothing kind Nothing loc loc Nothing + DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing docSymbol' name kind loc selectionLoc = - DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing docSymbolD name detail kind loc = - DocumentSymbol name (Just detail) kind Nothing loc loc Nothing + DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing docSymbolWithChildren name kind loc cc = - DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc) + DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just $ List cc) docSymbolWithChildren' name kind loc selectionLoc cc = - DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc) + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just $ List cc) moduleSymbol name loc cc = DocumentSymbol name Nothing SkFile Nothing + Nothing (R 0 0 maxBound 0) loc (Just $ List cc) @@ -4306,6 +4307,7 @@ outlineTests = testGroup (Just "class") SkInterface Nothing + Nothing loc loc (Just $ List cc) @@ -4861,7 +4863,7 @@ asyncTests = testGroup "async" , "foo = id" ] void waitForDiagnostics - actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0)) + actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0)) liftIO $ [ _title | InR CodeAction{_title} <- actions] @=? [ "add signature: foo :: a -> a" ] ] diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 43a277118b..380870733b 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -391,7 +391,7 @@ test-suite func-test , lsp-types , aeson , hls-plugin-api >= 1.0 && < 1.2 - , lsp-test == 0.13.0.0 + , lsp-test == 0.14.0.0 , containers , unordered-containers diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index ef91e712e4..b3189b6f2a 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -39,7 +39,7 @@ library , containers , data-default , Diff - , lsp ^>=1.1.0 + , lsp ^>=1.2.0 , hashable , hslogger , lens diff --git a/hls-plugin-api/src/Ide/Plugin/Properties.hs b/hls-plugin-api/src/Ide/Plugin/Properties.hs index 266ea7348c..8554ec342d 100644 --- a/hls-plugin-api/src/Ide/Plugin/Properties.hs +++ b/hls-plugin-api/src/Ide/Plugin/Properties.hs @@ -215,12 +215,9 @@ useProperty :: (HasProperty s k t r) => KeyNameProxy s -> Properties r -> - Maybe A.Object -> + A.Object -> ToHsType t -useProperty kn p = - maybe - (defaultValue metadata) - (fromRight (defaultValue metadata) . usePropertyEither kn p) +useProperty kn p = fromRight (defaultValue metadata) . usePropertyEither kn p where (_, metadata) = find kn p diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index d0ae8d8132..896256df40 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -121,13 +121,13 @@ diffTextEdit fText f2Text withDeletions = J.List r diffText' :: Bool -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit diffText' supports (f,fText) f2Text withDeletions = if supports - then WorkspaceEdit Nothing (Just docChanges) - else WorkspaceEdit (Just h) Nothing + then WorkspaceEdit Nothing (Just docChanges) Nothing + else WorkspaceEdit (Just h) Nothing Nothing where diff = diffTextEdit fText f2Text withDeletions h = H.singleton f diff docChanges = J.List [InL docEdit] - docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f (Just 0)) diff + docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f (Just 0)) $ fmap InL diff -- --------------------------------------------------------------------- @@ -136,7 +136,7 @@ clientSupportsDocumentChanges caps = let ClientCapabilities mwCaps _ _ _ = caps supports = do wCaps <- mwCaps - WorkspaceEditClientCapabilities mDc _ _ <- _workspaceEdit wCaps + WorkspaceEditClientCapabilities mDc _ _ _ _ <- _workspaceEdit wCaps mDc in Just True == supports @@ -152,7 +152,7 @@ pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginI -- cache the returned value of this function, as clients can at runitime change -- their configuration. -- -getClientConfig :: MonadLsp Config m => m (Maybe Config) +getClientConfig :: MonadLsp Config m => m Config getClientConfig = getConfig -- --------------------------------------------------------------------- @@ -160,10 +160,10 @@ getClientConfig = getConfig -- | Returns the current plugin configuration. It is not wise to permanently -- cache the returned value of this function, as clients can change their -- configuration at runtime. -getPluginConfig :: MonadLsp Config m => PluginId -> m (Maybe PluginConfig) +getPluginConfig :: MonadLsp Config m => PluginId -> m PluginConfig getPluginConfig plugin = do config <- getClientConfig - return $ flip configForPlugin plugin <$> config + return $ flip configForPlugin plugin config -- --------------------------------------------------------------------- @@ -176,7 +176,7 @@ usePropertyLsp :: m (ToHsType t) usePropertyLsp kn pId p = do config <- getPluginConfig pId - return $ useProperty kn p $ plcConfig <$> config + return $ useProperty kn p $ plcConfig config -- --------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 4324d12817..1983b6025d 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -143,8 +143,8 @@ instance PluginMethod TextDocumentDocumentSymbol where res | supportsHierarchy = InL $ sconcat $ fmap (either id (fmap siToDs)) dsOrSi | otherwise = InR $ sconcat $ fmap (either (List . concatMap dsToSi) id) dsOrSi - siToDs (SymbolInformation name kind dep (Location _uri range) cont) - = DocumentSymbol name cont kind dep range range Nothing + siToDs (SymbolInformation name kind _tags dep (Location _uri range) cont) + = DocumentSymbol name cont kind Nothing dep range range Nothing dsToSi = go Nothing go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation] go parent ds = @@ -152,7 +152,7 @@ instance PluginMethod TextDocumentDocumentSymbol where children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children)) loc = Location uri' (ds ^. range) name' = ds ^. name - si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent + si = SymbolInformation name' (ds ^. kind) Nothing (ds ^. deprecated) loc parent in [si] <> children' instance PluginMethod TextDocumentCompletion where diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index 8e9dc107ff..f0ec162c34 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -45,8 +45,8 @@ library , hspec , hspec-core , lens - , lsp-test ==0.13.0.0 - , lsp-types ^>=1.1 + , lsp-test ==0.14.0.0 + , lsp-types ^>=1.2 , tasty , tasty-ant-xml >=1.1.6 , tasty-expected-failure diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index 8573089847..b01a003a1d 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -66,7 +66,7 @@ codeActionSupportCaps :: C.ClientCapabilities codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps } where textDocumentCaps = def { C._codeAction = Just codeActionCaps } - codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) + codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing literalSupport = CodeActionLiteralSupport def -- --------------------------------------------------------------------- diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 4ef1528e4a..c9e0e6c098 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -111,9 +111,9 @@ codeAction state _pid (CodeActionParams _ _ (TextDocumentIdentifier uri) _range title = "Add TODO Item 1" tedit = [TextEdit (Range (Position 2 0) (Position 2 0)) "-- TODO1 added by Example Plugin directly\n"] - edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing pure $ Right $ List - [ InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) Nothing Nothing (Just edit) Nothing] + [ InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) Nothing Nothing (Just edit) Nothing Nothing] -- --------------------------------------------------------------------- @@ -155,6 +155,7 @@ addTodoCmd _ide (AddTodoParams uri todoText) = do res = WorkspaceEdit (Just $ Map.singleton uri textEdits) Nothing + Nothing _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ()) return $ Right Null @@ -196,7 +197,7 @@ symbols :: PluginMethodHandler IdeState TextDocumentDocumentSymbol symbols _ide _pid (DocumentSymbolParams _ _ _doc) = pure $ Right $ InL $ List [r] where - r = DocumentSymbol name detail kind deprecation range selR chList + r = DocumentSymbol name detail kind Nothing deprecation range selR chList name = "Example_symbol_name" detail = Nothing kind = SkVariable @@ -212,7 +213,7 @@ completion _ide _pid (CompletionParams _doc _pos _ _ _mctxt) = pure $ Right $ InL $ List [r] where r = CompletionItem label kind tags detail documentation deprecated preselect - sortText filterText insertText insertTextFormat + sortText filterText insertText insertTextFormat insertTextMode textEdit additionalTextEdits commitCharacters command xd label = "Example completion" @@ -225,6 +226,7 @@ completion _ide _pid (CompletionParams _doc _pos _ _ _mctxt) sortText = Nothing filterText = Nothing insertText = Nothing + insertTextMode = Nothing insertTextFormat = Nothing textEdit = Nothing additionalTextEdits = Nothing diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs index b7f28779ce..61651c6fc8 100644 --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -107,9 +107,9 @@ codeAction _state _pid (CodeActionParams _ _ (TextDocumentIdentifier uri) _range title = "Add TODO2 Item" tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) "-- TODO2 added by Example2 Plugin directly\n"] - edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing pure $ Right $ List - [ InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) Nothing Nothing (Just edit) Nothing ] + [ InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) Nothing Nothing (Just edit) Nothing Nothing] -- --------------------------------------------------------------------- @@ -148,6 +148,7 @@ addTodoCmd _ide (AddTodoParams uri todoText) = do res = WorkspaceEdit (Just $ Map.singleton uri textEdits) Nothing + Nothing _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ()) return $ Right Null @@ -189,7 +190,7 @@ symbols :: PluginMethodHandler IdeState TextDocumentDocumentSymbol symbols _ide _ (DocumentSymbolParams _ _ _doc) = pure $ Right $ InL $ List [r] where - r = DocumentSymbol name detail kind deprecation range selR chList + r = DocumentSymbol name detail kind Nothing deprecation range selR chList name = "Example2_symbol_name" detail = Nothing kind = SkVariable @@ -205,7 +206,7 @@ completion _ide _pid (CompletionParams _doc _pos _ _ _mctxt) = pure $ Right $ InL $ List [r] where r = CompletionItem label kind tags detail documentation deprecated preselect - sortText filterText insertText insertTextFormat + sortText filterText insertText insertTextFormat insertTextMode textEdit additionalTextEdits commitCharacters command xd label = "Example2 completion" @@ -218,6 +219,7 @@ completion _ide _pid (CompletionParams _doc _pos _ _ _mctxt) sortText = Nothing filterText = Nothing insertText = Nothing + insertTextMode = Nothing insertTextFormat = Nothing textEdit = Nothing additionalTextEdits = Nothing diff --git a/plugins/default/src/Ide/Plugin/Fourmolu.hs b/plugins/default/src/Ide/Plugin/Fourmolu.hs index 9186e2a007..1855462da8 100644 --- a/plugins/default/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/default/src/Ide/Plugin/Fourmolu.hs @@ -25,7 +25,7 @@ import Ide.PluginUtils (makeDiffTextEdit) import Control.Monad.IO.Class import Ide.Types -import Language.LSP.Server +import Language.LSP.Server hiding (defaultConfig) import Language.LSP.Types import Language.LSP.Types.Lens import "fourmolu" Ormolu diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs index 326c9ccd4b..58ee66ccc8 100644 --- a/plugins/default/src/Ide/Plugin/ModuleName.hs +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -88,7 +88,7 @@ data Action = Replace {aUri :: Uri, aRange :: Range, aTitle :: Text, aCode :: Te -- | Convert an Action to the corresponding edit operation asEdit :: Action -> WorkspaceEdit asEdit act@Replace{..} = - WorkspaceEdit (Just $ Map.singleton aUri $ List (asTextEdits act)) Nothing + WorkspaceEdit (Just $ Map.singleton aUri $ List (asTextEdits act)) Nothing Nothing asTextEdits :: Action -> [TextEdit] asTextEdits Replace{..} = [TextEdit aRange aCode] diff --git a/plugins/default/src/Ide/Plugin/Ormolu.hs b/plugins/default/src/Ide/Plugin/Ormolu.hs index e447b84062..780276188c 100644 --- a/plugins/default/src/Ide/Plugin/Ormolu.hs +++ b/plugins/default/src/Ide/Plugin/Ormolu.hs @@ -21,7 +21,7 @@ import GHC.LanguageExtensions.Type import GhcPlugins (HscEnv (hsc_dflags)) import Ide.PluginUtils import Ide.Types -import Language.LSP.Server +import Language.LSP.Server hiding (defaultConfig) import Language.LSP.Types import "ormolu" Ormolu import System.FilePath (takeFileName) diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index 75c540d2d0..9eb0a96761 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -55,7 +55,7 @@ codeActionProvider state _plId (CodeActionParams _ _ docId _ (J.CodeActionContex -- thus, not validated. pragmaEditToAction :: Uri -> Range -> PragmaEdit -> (Command |? CodeAction) pragmaEditToAction uri range (title, p) = - InR $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) Nothing Nothing (Just edit) Nothing + InR $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) Nothing Nothing (Just edit) Nothing Nothing where render (OptGHC x) = "{-# OPTIONS_GHC -Wno-" <> x <> " #-}\n" render (LangExt x) = "{-# LANGUAGE " <> x <> " #-}\n" @@ -64,6 +64,7 @@ pragmaEditToAction uri range (title, p) = J.WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing + Nothing suggest :: Maybe DynFlags -> Diagnostic -> [PragmaEdit] suggest dflags diag = @@ -166,6 +167,7 @@ completion _ide _ complParams = do _filterText = Nothing, _insertText = Nothing, _insertTextFormat = Nothing, + _insertTextMode = Nothing, _textEdit = Nothing, _additionalTextEdits = Nothing, _commitCharacters = Nothing, diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 2ed4c2e3f9..90f45851fe 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -163,10 +163,9 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr mkCmdParams methodGroup = [toJSON (AddMinimalMethodsParams uri range (List methodGroup))] - mkCodeAction title + mkCodeAction title cmd = InR - . CodeAction title (Just CodeActionQuickFix) (Just (List [])) Nothing Nothing Nothing - . Just + $ CodeAction title (Just CodeActionQuickFix) (Just (List [])) Nothing Nothing Nothing (Just cmd) Nothing findClassIdentifier docPath range = do (hieAstResult, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 76a968cf39..ab0cac5865 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -332,7 +332,7 @@ runEvalCmd st EvalParams{..} = tests let workspaceEditsMap = HashMap.fromList [(_uri, List $ addFinalReturn mdlText edits)] - let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing + let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing return workspaceEdits in perf "evalCmd" $ diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index a3aa1821fb..739605c5da 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -139,12 +139,14 @@ codeActionProvider ideState _pId (CodeActionParams _ _ docId range _context) _title = "Make all imports explicit" _kind = Just CodeActionQuickFix _command = Nothing - _edit = Just WorkspaceEdit {_changes, _documentChanges} + _edit = Just WorkspaceEdit {_changes, _documentChanges, _changeAnnotations} _changes = Just $ HashMap.singleton _uri $ List edits _documentChanges = Nothing _diagnostics = Nothing _isPreferred = Nothing _disabled = Nothing + _xdata = Nothing + _changeAnnotations = Nothing return $ Right $ List [caExplicitImports | not (null edits)] | otherwise = return $ Right $ List [] @@ -232,13 +234,13 @@ mkExplicitEdit posMapping (L src imp) explicit -- | Given an import declaration, generate a code lens unless it has an -- explicit import list or it's qualified generateLens :: PluginId -> Uri -> TextEdit -> IO (Maybe CodeLens) -generateLens pId uri importEdit@TextEdit {_range} = do +generateLens pId uri importEdit@TextEdit {_range, _newText} = do -- The title of the command is just the minimal explicit import decl - let title = _newText importEdit + let title = _newText -- the code lens has no extra data _xdata = Nothing -- an edit that replaces the whole declaration with the explicit one - edit = WorkspaceEdit (Just editsMap) Nothing + edit = WorkspaceEdit (Just editsMap) Nothing Nothing editsMap = HashMap.fromList [(uri, List [importEdit])] -- the command argument is simply the edit _arguments = Just [toJSON $ ImportCommandParams edit] diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index 6ee8d0ff88..58ee2c914a 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -125,6 +125,9 @@ toAction title uri edit = CodeAction {..} _edit = Just WorkspaceEdit {..} _isPreferred = Nothing _disabled = Nothing + _xdata = Nothing + _changeAnnotations = Nothing + toRange :: SrcSpan -> Maybe Range toRange src diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 34a6b4b1b0..e72bf3e7eb 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -289,7 +289,7 @@ codeActionProvider ideState plId (CodeActionParams _ _ docId _ context) = Right applyAllAction = let args = Just [toJSON (docId ^. LSP.uri)] cmd = mkLspCommand plId "applyAll" "Apply all hints" args - in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing Nothing Nothing (Just cmd) + in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing Nothing Nothing (Just cmd) Nothing applyOneActions :: [LSP.CodeAction] applyOneActions = mapMaybe mkHlintAction (filter validCommand diags) @@ -306,7 +306,7 @@ codeActionProvider ideState plId (CodeActionParams _ _ docId _ context) = Right mkHlintAction diag@(LSP.Diagnostic (LSP.Range start _) _s (Just (InR code)) (Just "hlint") _ _ _) = Just . codeAction $ mkLspCommand plId "applyOne" title (Just args) where - codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing Nothing Nothing (Just cmd) + codeAction cmd = LSP.CodeAction title (Just LSP.CodeActionQuickFix) (Just (LSP.List [diag])) Nothing Nothing Nothing (Just cmd) Nothing -- we have to recover the original ideaHint removing the prefix ideaHint = T.replace "refact:" "" code title = "Apply hint: " <> ideaHint diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index d5690a4547..a39fd7ca54 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -203,7 +203,7 @@ provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) commands <- lift $ forM rewrites $ \(title, kind, params) -> liftIO $ do let c = mkLspCommand plId (coerce retrieCommandName) title (Just [toJSON params]) - return $ CodeAction title (Just kind) Nothing Nothing Nothing Nothing (Just c) + return $ CodeAction title (Just kind) Nothing Nothing Nothing Nothing (Just c) Nothing return $ J.List [InR c | c <- commands] @@ -430,7 +430,7 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do let (errors :: [CallRetrieError], replacements) = partitionEithers results editParams :: WorkspaceEdit editParams = - WorkspaceEdit (Just $ asEditMap replacements) Nothing + WorkspaceEdit (Just $ asEditMap replacements) Nothing Nothing return (errors, editParams) where diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index c0651de875..aefd5d270c 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -14,6 +14,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} module Ide.Plugin.Splice ( descriptor, @@ -23,7 +24,7 @@ where import Control.Applicative (Alternative ((<|>))) import Control.Arrow import qualified Control.Foldl as L -import Control.Lens (ix, view, (%~), (<&>), (^.)) +import Control.Lens (ix, view, (%~), (<&>), (^.), Identity(..)) import Control.Monad import Control.Monad.Extra (eitherM) import qualified Control.Monad.Fail as Fail @@ -238,8 +239,8 @@ setupDynFlagsForGHCiLike env dflags = do initializePlugins env dflags4 adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit -adjustToRange uri ran (WorkspaceEdit mhult mlt) = - WorkspaceEdit (adjustWS <$> mhult) (fmap adjustDoc <$> mlt) +adjustToRange uri ran (WorkspaceEdit mhult mlt x) = + WorkspaceEdit (adjustWS <$> mhult) (fmap adjustDoc <$> mlt) x where adjustTextEdits :: Traversable f => f TextEdit -> f TextEdit adjustTextEdits eds = @@ -248,12 +249,21 @@ adjustToRange uri ran (WorkspaceEdit mhult mlt) = (L.premap (view J.range) L.minimum) eds in adjustLine minStart <$> eds + + adjustATextEdits :: Traversable f => f (TextEdit |? AnnotatedTextEdit) -> f (TextEdit |? AnnotatedTextEdit) + adjustATextEdits = fmap $ \case + InL t -> InL $ runIdentity $ adjustTextEdits (Identity t) + InR AnnotatedTextEdit{_range, _newText, _annotationId} -> + let oldTE = TextEdit{_range,_newText} + in let TextEdit{_range,_newText} = runIdentity $ adjustTextEdits (Identity oldTE) + in InR $ AnnotatedTextEdit{_range,_newText,_annotationId} + adjustWS = ix uri %~ adjustTextEdits adjustDoc :: DocumentChange -> DocumentChange adjustDoc (InR es) = InR es adjustDoc (InL es) | es ^. J.textDocument . J.uri == uri = - InL $ es & J.edits %~ adjustTextEdits + InL $ es & J.edits %~ adjustATextEdits | otherwise = InL es adjustLine :: Range -> TextEdit -> TextEdit @@ -405,7 +415,7 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ act = mkLspCommand plId cmdId title (Just [toJSON params]) pure $ InR $ - CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing Nothing Nothing (Just act) + CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing Nothing Nothing (Just act) Nothing pure $ maybe mempty List mcmds where diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index 78304cccd6..53cc62ed88 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -128,4 +128,4 @@ pointRange -- | Get the title of a code action. codeActionTitle :: (Command |? CodeAction) -> Maybe Text codeActionTitle InL{} = Nothing -codeActionTitle (InR(CodeAction title _ _ _ _ _ _)) = Just title +codeActionTitle (InR(CodeAction title _ _ _ _ _ _ _)) = Just title diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs index 61cfecc1d5..b1e3869ae8 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs @@ -262,13 +262,15 @@ provide tc name TacticProviderData{..} = do $ pure $ InR $ CodeAction - title - (Just $ mkTacticKind tc) - Nothing - (Just $ tacticPreferred tc) - Nothing - Nothing - $ Just cmd + { _title = title + , _kind = Just $ mkTacticKind tc + , _diagnostics = Nothing + , _isPreferred = Just $ tacticPreferred tc + , _disabled = Nothing + , _edit = Nothing + , _command = Just cmd + , _xdata = Nothing + } ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index 87c0dcefb1..4dae186079 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -46,7 +46,7 @@ pointRange -- | Get the title of a code action. codeActionTitle :: (Command |? CodeAction) -> Maybe Text codeActionTitle InL{} = Nothing -codeActionTitle (InR(CodeAction title _ _ _ _ _ _)) = Just title +codeActionTitle (InR(CodeAction title _ _ _ _ _ _ _)) = Just title ------------------------------------------------------------------------------ diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index d6839f1327..1d11d7019c 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -32,9 +32,9 @@ extra-deps: - ghc-exactprint-0.6.3.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - - lsp-1.1.1.0 - - lsp-types-1.1.0.0 - - lsp-test-0.13.0.0 + - lsp-1.2.0.0 + - lsp-types-1.2.0.0 + - lsp-test-0.14.0.0 - haddock-library-1.10.0 - heapsize-0.3.0 - hie-bios-0.7.4 diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index 066ec10edc..dbd1447991 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -43,9 +43,9 @@ extra-deps: - temporary-1.2.1.1 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - - lsp-1.1.1.0 - - lsp-types-1.1.0.0 - - lsp-test-0.13.0.0 + - lsp-1.2.0.0 + - lsp-types-1.2.0.0 + - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index d489454027..d8cb1cc319 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -41,9 +41,9 @@ extra-deps: - temporary-1.2.1.1 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - - lsp-1.1.1.0 - - lsp-types-1.1.0.0 - - lsp-test-0.13.0.0 + - lsp-1.2.0.0 + - lsp-types-1.2.0.0 + - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 834f650d24..6ee16c62b9 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -82,9 +82,9 @@ extra-deps: - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 - - lsp-1.1.1.0 - - lsp-types-1.1.0.0 - - lsp-test-0.13.0.0 + - lsp-1.2.0.0 + - lsp-types-1.2.0.0 + - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 7e339016d0..8ba6ff4853 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -81,9 +81,9 @@ extra-deps: - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 - - lsp-1.1.1.0 - - lsp-types-1.1.0.0 - - lsp-test-0.13.0.0 + - lsp-1.2.0.0 + - lsp-types-1.2.0.0 + - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index 0f63af7611..665746a4bd 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -68,9 +68,9 @@ extra-deps: - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 - - lsp-1.1.1.0 - - lsp-types-1.1.0.0 - - lsp-test-0.13.0.0 + - lsp-1.2.0.0 + - lsp-types-1.2.0.0 + - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 7c904bc293..9decdcf0ea 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -62,9 +62,9 @@ extra-deps: - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 - - lsp-1.1.1.0 - - lsp-types-1.1.0.0 - - lsp-test-0.13.0.0 + - lsp-1.2.0.0 + - lsp-types-1.2.0.0 + - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 1cea93da82..b355ef7781 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -59,9 +59,9 @@ extra-deps: - hiedb-0.3.0.1 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 - - lsp-1.1.1.0 - - lsp-types-1.1.0.0 - - lsp-test-0.13.0.0 + - lsp-1.2.0.0 + - lsp-types-1.2.0.0 + - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 diff --git a/stack.yaml b/stack.yaml index d8a8f52f68..3e681a6bcc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -83,9 +83,9 @@ extra-deps: - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 - - lsp-1.1.1.0 - - lsp-types-1.1.0.0 - - lsp-test-0.13.0.0 + - lsp-1.2.0.0 + - lsp-types-1.2.0.0 + - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 00ccc42832..6e706973dd 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -624,7 +624,7 @@ disableWarningTests = <&> \(warning, initialContent, expectedContent) -> testSession (T.unpack warning) $ do doc <- createDoc "Module.hs" "haskell" initialContent _ <- waitForDiagnostics - codeActs <- mapMaybe caResultToCodeAct <$> getCodeActions doc (Range (Position 0 0) (Position 0 0)) + codeActs <- mapMaybe caResultToCodeAct <$> getAllCodeActions doc case find (\CodeAction{_title} -> _title == "Disable \"" <> warning <> "\" warnings") codeActs of Nothing -> liftIO $ assertFailure "No code action with expected title" Just action -> do @@ -691,7 +691,7 @@ noLiteralCaps :: C.ClientCapabilities noLiteralCaps = def { C._textDocument = Just textDocumentCaps } where textDocumentCaps = def { C._codeAction = Just codeActionCaps } - codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing + codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing Nothing Nothing Nothing Nothing testSession :: String -> Session () -> TestTree testSession name s = testCase name $ withTempDir $ \dir -> diff --git a/test/functional/Symbol.hs b/test/functional/Symbol.hs index 965d30d4c1..56a7142701 100644 --- a/test/functional/Symbol.hs +++ b/test/functional/Symbol.hs @@ -21,9 +21,9 @@ v310Tests = testGroup "3.10 hierarchical document symbols" [ doc <- openDoc "Symbols.hs" "haskell" Left symbs <- getDocumentSymbols doc - let myData = DocumentSymbol "MyData" Nothing SkStruct Nothing myDataR myDataSR (Just (List [a, b])) - a = DocumentSymbol "A" Nothing SkConstructor Nothing aR aSR Nothing - b = DocumentSymbol "B" Nothing SkConstructor Nothing bR bSR Nothing + let myData = DocumentSymbol "MyData" Nothing SkStruct Nothing Nothing myDataR myDataSR (Just (List [a, b])) + a = DocumentSymbol "A" Nothing SkConstructor Nothing Nothing aR aSR Nothing + b = DocumentSymbol "B" Nothing SkConstructor Nothing Nothing bR bSR Nothing let myData' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 2 liftIO $ Just myData == myData' @? "Contains symbol" @@ -32,10 +32,10 @@ v310Tests = testGroup "3.10 hierarchical document symbols" [ doc <- openDoc "Symbols.hs" "haskell" Left symbs <- getDocumentSymbols doc - let foo = DocumentSymbol "foo" Nothing SkFunction Nothing fooR fooSR (Just (List [bar])) - bar = DocumentSymbol "bar" Nothing SkFunction Nothing barR barSR (Just (List [dog, cat])) - dog = DocumentSymbol "dog" Nothing SkVariable Nothing dogR dogSR (Just mempty) - cat = DocumentSymbol "cat" Nothing SkVariable Nothing catR catSR (Just mempty) + let foo = DocumentSymbol "foo" Nothing SkFunction Nothing Nothing fooR fooSR (Just (List [bar])) + bar = DocumentSymbol "bar" Nothing SkFunction Nothing Nothing barR barSR (Just (List [dog, cat])) + dog = DocumentSymbol "dog" Nothing SkVariable Nothing Nothing dogR dogSR (Just mempty) + cat = DocumentSymbol "cat" Nothing SkVariable Nothing Nothing catR catSR (Just mempty) let foo' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 1 liftIO $ Just foo == foo' @? "Contains symbol" @@ -45,7 +45,7 @@ v310Tests = testGroup "3.10 hierarchical document symbols" [ Left symbs <- getDocumentSymbols doc let testPattern = DocumentSymbol "TestPattern" - Nothing SkFunction Nothing testPatternR testPatternSR (Just mempty) + Nothing SkFunction Nothing Nothing testPatternR testPatternSR (Just mempty) let testPattern' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 3 liftIO $ Just testPattern == testPattern' @? "Contains symbol" @@ -54,8 +54,8 @@ v310Tests = testGroup "3.10 hierarchical document symbols" [ doc <- openDoc "Symbols.hs" "haskell" Left symbs <- getDocumentSymbols doc - let imports = DocumentSymbol "imports" Nothing SkModule Nothing importsR importsSR (Just (List [importDataMaybe])) - importDataMaybe = DocumentSymbol "import Data.Maybe" Nothing SkModule Nothing importDataMaybeR importDataMaybeSR Nothing + let imports = DocumentSymbol "imports" Nothing SkModule Nothing Nothing importsR importsSR (Just (List [importDataMaybe])) + importDataMaybe = DocumentSymbol "import Data.Maybe" Nothing SkModule Nothing Nothing importDataMaybeR importDataMaybeSR Nothing let imports' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 0 liftIO $ Just imports == imports' @? "Contains symbol" @@ -67,9 +67,9 @@ pre310Tests = testGroup "pre 3.10 symbol information" [ doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" Right symbs <- getDocumentSymbols doc - let myData = SymbolInformation "MyData" SkStruct Nothing (Location testUri myDataR) (Just "Symbols") - a = SymbolInformation "A" SkConstructor Nothing (Location testUri aR) (Just "MyData") - b = SymbolInformation "B" SkConstructor Nothing (Location testUri bR) (Just "MyData") + let myData = SymbolInformation "MyData" SkStruct Nothing Nothing (Location testUri myDataR) (Just "Symbols") + a = SymbolInformation "A" SkConstructor Nothing Nothing (Location testUri aR) (Just "MyData") + b = SymbolInformation "B" SkConstructor Nothing Nothing (Location testUri bR) (Just "MyData") liftIO $ [myData, a, b] `isInfixOf` symbs @? "Contains symbols" @@ -77,10 +77,10 @@ pre310Tests = testGroup "pre 3.10 symbol information" [ doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" Right symbs <- getDocumentSymbols doc - let foo = SymbolInformation "foo" SkFunction Nothing (Location testUri fooR) (Just "Symbols") - bar = SymbolInformation "bar" SkFunction Nothing (Location testUri barR) (Just "foo") - dog = SymbolInformation "dog" SkVariable Nothing (Location testUri dogR) (Just "bar") - cat = SymbolInformation "cat" SkVariable Nothing (Location testUri catR) (Just "bar") + let foo = SymbolInformation "foo" SkFunction Nothing Nothing (Location testUri fooR) (Just "Symbols") + bar = SymbolInformation "bar" SkFunction Nothing Nothing (Location testUri barR) (Just "foo") + dog = SymbolInformation "dog" SkVariable Nothing Nothing (Location testUri dogR) (Just "bar") + cat = SymbolInformation "cat" SkVariable Nothing Nothing (Location testUri catR) (Just "bar") -- Order is important! liftIO $ [foo, bar, dog, cat] `isInfixOf` symbs @? "Contains symbols" @@ -90,7 +90,7 @@ pre310Tests = testGroup "pre 3.10 symbol information" [ Right symbs <- getDocumentSymbols doc let testPattern = SymbolInformation "TestPattern" - SkFunction Nothing (Location testUri testPatternR) (Just "Symbols") + SkFunction Nothing Nothing (Location testUri testPatternR) (Just "Symbols") liftIO $ testPattern `elem` symbs @? "Contains symbols" @@ -98,8 +98,8 @@ pre310Tests = testGroup "pre 3.10 symbol information" [ doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" Right symbs <- getDocumentSymbols doc - let imports = SymbolInformation "imports" SkModule Nothing (Location testUri importsR) (Just "Symbols") - importDataMaybe = SymbolInformation "import Data.Maybe" SkModule Nothing (Location testUri importDataMaybeR) (Just "imports") + let imports = SymbolInformation "imports" SkModule Nothing Nothing (Location testUri importsR) (Just "Symbols") + importDataMaybe = SymbolInformation "import Data.Maybe" SkModule Nothing Nothing (Location testUri importDataMaybeR) (Just "imports") liftIO $ [imports, importDataMaybe] `isInfixOf` symbs @? "Contains symbol" ] From d43a087a88a50038841f22a3d1a2121e46e28073 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Fri, 2 Apr 2021 08:32:30 +0100 Subject: [PATCH 09/21] Avoid reordering plugins (#1629) * Avoid reordering plugins Order of execution matters for notification plugins, so lets avoid unnecessary reorderings * remove duplicate plugins * fix tests --- ghcide/ghcide.cabal | 1 + ghcide/src/Development/IDE/Plugin/HLS.hs | 3 +- ghcide/test/exe/Main.hs | 63 +++++++++++++++++--- hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 5 +- hls-plugin-api/src/Ide/PluginUtils.hs | 8 +-- hls-plugin-api/src/Ide/Types.hs | 2 +- src/Ide/Main.hs | 3 +- test/functional/FunctionalCodeAction.hs | 10 ++-- 8 files changed, 70 insertions(+), 25 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index e61b07aa88..3086f0b422 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -315,6 +315,7 @@ test-suite ghcide-tests implicit-hie:gen-hie build-depends: aeson, + async, base, binary, bytestring, diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 66d611ea14..e17656203d 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -44,13 +44,12 @@ import UnliftIO.Exception (catchAny) -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config -asGhcIdePlugin mp = +asGhcIdePlugin (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> mkPlugin executeCommandPlugins HLS.pluginCommands <> mkPlugin extensiblePlugins HLS.pluginHandlers <> mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers where - ls = Map.toList (ipMap mp) mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config mkPlugin maker selector = diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 28081dbb65..7089247fd6 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -36,6 +36,7 @@ import Development.IDE.Core.PositionMapping (PositionResult (..), positionResultToMaybe, toCurrent) import Development.IDE.Core.Shake (Q (..)) +import Development.IDE.Main as IDE import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types (extendImportCommandId) import Development.IDE.Plugin.TypeLenses (typeLensCommandId) @@ -75,7 +76,7 @@ import qualified System.IO.Extra import System.Info.Extra (isWindows) import System.Process.Extra (CreateProcess (cwd), proc, - readCreateProcessWithExitCode) + readCreateProcessWithExitCode, createPipe) import Test.QuickCheck -- import Test.QuickCheck.Instances () import Control.Lens ((^.)) @@ -92,6 +93,14 @@ import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun import Test.Tasty.QuickCheck +import Data.IORef +import Ide.PluginUtils (pluginDescToIdePlugins) +import Control.Concurrent.Async +import Ide.Types +import Data.String (IsString(fromString)) +import qualified Language.LSP.Types as LSP +import Data.IORef.Extra (atomicModifyIORef_) +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case @@ -179,7 +188,7 @@ initializeResponseTests = withResource acquire release tests where , chk "NO doc link" _documentLinkProvider Nothing , chk "NO color" _colorProvider (Just $ InL False) , chk "NO folding range" _foldingRangeProvider (Just $ InL False) - , che " execute command" _executeCommandProvider [blockCommandId, extendImportCommandId, typeLensCommandId] + , che " execute command" _executeCommandProvider [extendImportCommandId, typeLensCommandId, blockCommandId] , chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) , chk "NO experimental" _experimental Nothing ] where @@ -5145,21 +5154,26 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do -- HIE calls getXgdDirectory which assumes that HOME is set. -- Only sets HOME if it wasn't already set. setEnv "HOME" "/homeless-shelter" False - let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } + conf <- getConfigFromEnv + runSessionWithConfig conf cmd lspTestCaps projDir s + +getConfigFromEnv :: IO SessionConfig +getConfigFromEnv = do logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" - let conf = defaultConfig{messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride} - -- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging - -- { logStdErr = True } - -- uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages - -- { logMessages = True } - runSessionWithConfig conf{logColor} cmd lspTestCaps projDir s + return defaultConfig + { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride + , logColor + } where checkEnv :: String -> IO (Maybe Bool) checkEnv s = fmap convertVal <$> getEnv s convertVal "0" = False convertVal _ = True +lspTestCaps :: ClientCapabilities +lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } + openTestDataDoc :: FilePath -> Session TextDocumentIdentifier openTestDataDoc path = do source <- liftIO $ readFileUtf8 $ "test/data" path @@ -5227,8 +5241,39 @@ unitTests = do let expected = "1:2-3:4" assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ expected `isInfixOf` shown + , testCase "notification handlers run sequentially" $ do + orderRef <- newIORef [] + let plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor $ fromString $ show i) + { pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ -> + liftIO $ atomicModifyIORef_ orderRef (i:) + ] + } + | i <- [(1::Int)..20] + ] ++ Ghcide.descriptors + + testIde def{argsHlsPlugins = plugins} $ do + _ <- createDoc "haskell" "A.hs" "module A where" + waitForProgressDone + actualOrder <- liftIO $ readIORef orderRef + + liftIO $ actualOrder @?= reverse [(1::Int)..20] ] +testIde :: Arguments -> Session () -> IO () +testIde arguments session = do + config <- getConfigFromEnv + (hInRead, hInWrite) <- createPipe + (hOutRead, hOutWrite) <- createPipe + let server = IDE.defaultMain arguments + { argsHandleIn = pure hInRead + , argsHandleOut = pure hOutWrite + } + + withAsync server $ \_ -> + runSessionWithHandles hInWrite hOutRead config lspTestCaps "." session + positionMappingTests :: TestTree positionMappingTests = testGroup "position mapping" diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index fad0fe7ed9..4badc44d43 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -11,7 +11,6 @@ import Data.Default (def) import qualified Data.Dependent.Map as DMap import qualified Data.Dependent.Sum as DSum import qualified Data.HashMap.Lazy as HMap -import qualified Data.Map as Map import Ide.Plugin.Config import Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema) import Ide.Types @@ -36,7 +35,7 @@ pluginsToDefaultConfig IdePlugins {..} = defaultConfig@Config {} = def unsafeValueToObject (A.Object o) = o unsafeValueToObject _ = error "impossible" - elems = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap + elems = A.object $ mconcat $ singlePlugin <$> map snd ipMap -- Splice genericDefaultConfig and dedicatedDefaultConfig -- Example: -- @@ -100,7 +99,7 @@ pluginsToDefaultConfig IdePlugins {..} = -- | Generates json schema used in haskell vscode extension -- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value -pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap +pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> map snd ipMap where singlePlugin PluginDescriptor {..} = genericSchema <> dedicatedSchema where diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 896256df40..384735e191 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -37,7 +37,7 @@ import Language.LSP.Types import qualified Language.LSP.Types as J import Language.LSP.Types.Capabilities -import qualified Data.Map.Strict as Map +import Data.Containers.ListUtils (nubOrdOn) import Ide.Plugin.Config import Ide.Plugin.Properties import Language.LSP.Server @@ -144,7 +144,8 @@ clientSupportsDocumentChanges caps = -- --------------------------------------------------------------------- pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState -pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins +pluginDescToIdePlugins plugins = + IdePlugins $ map (\p -> (pluginId p, p)) $ nubOrdOn pluginId plugins -- --------------------------------------------------------------------- @@ -214,12 +215,11 @@ positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) = -- --------------------------------------------------------------------- allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text] -allLspCmdIds' pid mp = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) +allLspCmdIds' pid (IdePlugins ls) = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) where justs (p, Just x) = [(p, x)] justs (_, Nothing) = [] - ls = Map.toList (ipMap mp) mkPlugin maker selector = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 1983b6025d..3ccc4145b7 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -54,7 +54,7 @@ import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- newtype IdePlugins ideState = IdePlugins - { ipMap :: Map.Map PluginId (PluginDescriptor ideState)} + { ipMap :: [(PluginId, PluginDescriptor ideState)]} -- --------------------------------------------------------------------- diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 3d496a1354..d662cced3b 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -13,7 +13,6 @@ import Control.Monad.Extra import qualified Data.Aeson.Encode.Pretty as A import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Default -import qualified Data.Map.Strict as Map import qualified Data.Text as T import Development.IDE.Core.Rules import qualified Development.IDE.Main as Main @@ -97,7 +96,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do when argLSP $ do hPutStrLn stderr "Starting (haskell-language-server)LSP server..." hPutStrLn stderr $ " with arguments: " <> show lspArgs - hPutStrLn stderr $ " with plugins: " <> show (Map.keys $ ipMap idePlugins) + hPutStrLn stderr $ " with plugins: " <> show (map fst $ ipMap idePlugins) hPutStrLn stderr $ " in directory: " <> dir hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 6e706973dd..6a531113f2 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -372,7 +372,8 @@ redundantImportTests = testGroup "redundant import code actions" [ , testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do doc <- openDoc "src/MultipleImports.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" - InL cmd : _ <- getAllCodeActions doc + cas <- getAllCodeActions doc + cmd <- liftIO $ inspectCommand cas ["redundant import"] executeCommand cmd _ <- anyRequest contents <- documentContents doc @@ -439,11 +440,12 @@ signatureTests = testGroup "missing top level signature code actions" [ doc <- openDoc "TopLevelSignature.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" - cas <- map fromAction <$> getAllCodeActions doc + cas <- getAllCodeActions doc - liftIO $ "add signature: main :: IO ()" `elem` map (^. L.title) cas @? "Contains code action" + liftIO $ expectCodeAction cas ["add signature: main :: IO ()"] - executeCodeAction $ head cas + replaceWithStuff <- liftIO $ inspectCodeAction cas ["add signature"] + executeCodeAction replaceWithStuff contents <- documentContents doc From f22718f9000402384d928c8d0b3fbc45b09b6a36 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Fri, 2 Apr 2021 14:28:18 +0100 Subject: [PATCH 10/21] Civilized indexing progress reporting (#1633) * Civilized indexing progress reporting * optProgressStyle * Consistency: Indexing references ==> Indexing * Fix progress tests --- ghcide/src/Development/IDE/Core/Compile.hs | 35 ++++++++++++++------- ghcide/src/Development/IDE/Core/Shake.hs | 34 ++++++++++++++------ ghcide/src/Development/IDE/Types/Options.hs | 9 ++++++ test/functional/Progress.hs | 9 +++--- 4 files changed, 61 insertions(+), 26 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 928e2f09cf..ff8f5f1c0c 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -507,7 +507,9 @@ spliceExpresions Splices{..} = -- can just increment the 'indexCompleted' TVar and exit. -- indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Fingerprint -> Compat.HieFile -> IO () -indexHieFile se mod_summary srcPath hash hf = atomically $ do +indexHieFile se mod_summary srcPath hash hf = do + IdeOptions{optProgressStyle} <- getIdeOptionsIO se + atomically $ do pending <- readTVar indexPending case HashMap.lookup srcPath pending of Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled @@ -523,7 +525,7 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do -- If the hash in the pending list doesn't match the current hash, then skip Just pendingHash -> pendingHash /= hash unless newerScheduled $ do - pre + pre optProgressStyle addRefsFromLoaded db targetPath (RealFile $ fromNormalizedFilePath srcPath) hash hf post where @@ -532,7 +534,7 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do HieDbWriter{..} = hiedbWriter se -- Get a progress token to report progress and update it for the current file - pre = do + pre style = do tok <- modifyVar indexProgressToken $ fmap dupe . \case x@(Just _) -> pure x -- Create a token if we don't already have one @@ -545,7 +547,7 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ()) LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $ LSP.Begin $ LSP.WorkDoneProgressBeginParams - { _title = "Indexing references from:" + { _title = "Indexing" , _cancellable = Nothing , _message = Nothing , _percentage = Nothing @@ -557,15 +559,26 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do remaining <- HashMap.size <$> readTVar indexPending pure (done, remaining) - let progress = " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..." - whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $ LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ - LSP.Report $ LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Just $ T.pack (fromNormalizedFilePath srcPath) <> progress - , _percentage = Nothing - } + LSP.Report $ + case style of + Percentage -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Nothing + , _percentage = Just (100 * fromIntegral done / fromIntegral (done + remaining) ) + } + Explicit -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Just $ + T.pack " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..." + , _percentage = Nothing + } + NoProgress -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing + } -- Report the progress once we are done indexing this file post = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f3d18eb40f..68cc99c553 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -499,7 +499,7 @@ shakeOpen lspEnv defaultConfig logger debouncer let hiedbWriter = HieDbWriter{..} progressAsync <- async $ when reportProgress $ - progressThread mostRecentProgressEvent inProgress + progressThread optProgressStyle mostRecentProgressEvent inProgress exportsMap <- newVar mempty actionQueue <- newQueue @@ -517,7 +517,10 @@ shakeOpen lspEnv defaultConfig logger debouncer shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir let ideState = IdeState{..} - IdeOptions{ optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled } <- getIdeOptionsIO shakeExtras + IdeOptions + { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled + , optProgressStyle + } <- getIdeOptionsIO shakeExtras startTelemetry otProfilingEnabled logger $ state shakeExtras return ideState @@ -528,7 +531,7 @@ shakeOpen lspEnv defaultConfig logger debouncer -- And two transitions, modelled by 'ProgressEvent': -- 1. KickCompleted - transitions from Reporting into Idle -- 2. KickStarted - transitions from Idle into Reporting - progressThread mostRecentProgressEvent inProgress = progressLoopIdle + progressThread style mostRecentProgressEvent inProgress = progressLoopIdle where progressLoopIdle = do atomically $ do @@ -560,7 +563,7 @@ shakeOpen lspEnv defaultConfig logger debouncer bracket_ (start u) (stop u) - (loop u Nothing) + (loop u 0) where start id = LSP.sendNotification LSP.SProgress $ LSP.ProgressParams @@ -585,16 +588,27 @@ shakeOpen lspEnv defaultConfig logger debouncer current <- liftIO $ readVar inProgress let done = length $ filter (== 0) $ HMap.elems current let todo = HMap.size current - let next = Just $ T.pack $ show done <> "/" <> show todo + let next = 100 * fromIntegral done / fromIntegral todo when (next /= prev) $ LSP.sendNotification LSP.SProgress $ LSP.ProgressParams { _token = id - , _value = LSP.Report $ LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = next - , _percentage = Nothing - } + , _value = LSP.Report $ case style of + Explicit -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Just $ T.pack $ show done <> "/" <> show todo + , _percentage = Nothing + } + Percentage -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Nothing + , _percentage = Just next + } + NoProgress -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing + } } loop id next diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index c09bd4a40b..612d2c743b 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -16,6 +16,7 @@ module Development.IDE.Types.Options , IdeResult , IdeGhcSession(..) , OptHaddockParse(..) + , ProgressReportingStyle(..) ,optShakeFiles) where import qualified Data.Text as T @@ -78,6 +79,7 @@ data IdeOptions = IdeOptions , optShakeOptions :: ShakeOptions , optSkipProgress :: forall a. Typeable a => a -> Bool -- ^ Predicate to select which rule keys to exclude from progress reporting. + , optProgressStyle :: ProgressReportingStyle } optShakeFiles :: IdeOptions -> Maybe FilePath @@ -104,6 +106,12 @@ newtype IdeDefer = IdeDefer Bool newtype IdeTesting = IdeTesting Bool newtype IdeOTMemoryProfiling = IdeOTMemoryProfiling Bool +data ProgressReportingStyle + = Percentage -- ^ Report using the LSP @_percentage@ field + | Explicit -- ^ Report using explicit 123/456 text + | NoProgress -- ^ Do not report any percentage + + clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ Just True == (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)) @@ -131,6 +139,7 @@ defaultIdeOptions session = IdeOptions ,optHaddockParse = HaddockParse ,optCustomDynFlags = id ,optSkipProgress = defaultSkipProgress + ,optProgressStyle = Explicit } defaultSkipProgress :: Typeable a => a -> Bool diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 58e0e8bbe8..e35e83da41 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -28,11 +28,11 @@ tests = runSession hlsCommand progressCaps "test/testdata" $ do let path = "hlint" "ApplyRefact2.hs" _ <- openDoc path "haskell" - expectProgressReports [pack ("Setting up hlint (for " ++ path ++ ")"), "Processing"] + expectProgressReports [pack ("Setting up hlint (for " ++ path ++ ")"), "Processing", "Indexing"] , testCase "eval plugin sends progress reports" $ runSession hlsCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do doc <- openDoc "T1.hs" "haskell" - expectProgressReports ["Setting up testdata (for T1.hs)", "Processing"] + expectProgressReports ["Setting up testdata (for T1.hs)", "Processing", "Indexing"] [evalLens] <- getCodeLenses doc let cmd = evalLens ^?! L.command . _Just _ <- sendRequest SWorkspaceExecuteCommand $ ExecuteCommandParams Nothing (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) @@ -41,14 +41,14 @@ tests = runSession hlsCommand progressCaps "test/testdata/format" $ do sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) doc <- openDoc "Format.hs" "haskell" - expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"] + expectProgressReports ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressReports ["Formatting Format.hs"] , testCase "fourmolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) doc <- openDoc "Format.hs" "haskell" - expectProgressReports ["Setting up testdata (for Format.hs)", "Processing"] + expectProgressReports ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressReports ["Formatting Format.hs"] , ignoreTestBecause "no liquid Haskell support" $ @@ -90,7 +90,6 @@ expectProgressReports xs = expectProgressReports' [] xs CreateM msg -> expectProgressReports' (token msg : tokens) expectedTitles BeginM msg -> do - liftIO $ title msg `expectElem` ("Indexing references from:":xs) liftIO $ token msg `expectElem` tokens expectProgressReports' tokens (delete (title msg) expectedTitles) ProgressM msg -> do From 00240faad9e1f0d2416afb3aaba8cd0bb5061fc5 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 3 Apr 2021 02:28:11 +0100 Subject: [PATCH 11/21] Do not override custom user commands (#1650) Co-authored-by: Potato Hatsue <1793913507@qq.com> --- ghcide/src/Development/IDE/Main.hs | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 778f4536bd..91da4a09d0 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -81,20 +81,20 @@ import System.Time.Extra (offsetTime, import Text.Printf (printf) data Arguments = Arguments - { argsOTMemoryProfiling :: Bool - , argFiles :: Maybe [FilePath] -- ^ Nothing: lsp server ; Just: typecheck and exit - , argsLogger :: IO Logger - , argsRules :: Rules () - , argsHlsPlugins :: IdePlugins IdeState - , argsGhcidePlugin :: Plugin Config -- ^ Deprecated + { argsOTMemoryProfiling :: Bool + , argFiles :: Maybe [FilePath] -- ^ Nothing: lsp server ; Just: typecheck and exit + , argsLogger :: IO Logger + , argsRules :: Rules () + , argsHlsPlugins :: IdePlugins IdeState + , argsGhcidePlugin :: Plugin Config -- ^ Deprecated , argsSessionLoadingOptions :: SessionLoadingOptions - , argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions - , argsLspOptions :: LSP.Options - , argsDefaultHlsConfig :: Config - , argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project - , argsDebouncer :: IO (Debouncer NormalizedUri) -- ^ Debouncer used for diagnostics - , argsHandleIn :: IO Handle - , argsHandleOut :: IO Handle + , argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions + , argsLspOptions :: LSP.Options + , argsDefaultHlsConfig :: Config + , argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project + , argsDebouncer :: IO (Debouncer NormalizedUri) -- ^ Debouncer used for diagnostics + , argsHandleIn :: IO Handle + , argsHandleOut :: IO Handle } instance Default Arguments where @@ -145,7 +145,7 @@ defaultMain Arguments{..} = do let hlsPlugin = asGhcIdePlugin argsHlsPlugins hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin - options = argsLspOptions { LSP.executeCommandCommands = Just hlsCommands } + options = argsLspOptions { LSP.executeCommandCommands = LSP.executeCommandCommands argsLspOptions <> Just hlsCommands } argsOnConfigChange = getConfigFromNotification rules = argsRules >> pluginRules plugins From f687a279e46705159b3c41db8b1d53cbf8811c98 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 3 Apr 2021 05:15:51 +0100 Subject: [PATCH 12/21] Shut the Shake session on exit, instead of restarting it (#1655) Restarting the session will result in progress reporting and other messages being sent to the client, which might have already closed the stream Co-authored-by: Potato Hatsue <1793913507@qq.com> --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 53a2aee1e0..06afd28245 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -188,7 +188,7 @@ exitHandler :: IO () -> LSP.Handlers (ServerM c) exitHandler exit = LSP.notificationHandler SExit $ const $ do (_, ide) <- ask -- flush out the Shake session to record a Shake profile if applicable - liftIO $ restartShakeSession (shakeExtras ide) [] + liftIO $ shakeShut ide liftIO exit modifyOptions :: LSP.Options -> LSP.Options From 80662f2a234b4184111da03859a5d457329dd98f Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Sat, 3 Apr 2021 15:50:33 +0800 Subject: [PATCH 13/21] Fix importing type operators (#1644) * Fix importing type operators * Update test * Add expected failure tests --- .../src/Development/IDE/Plugin/CodeAction.hs | 5 +- .../IDE/Plugin/CodeAction/ExactPrint.hs | 61 ++++++++++++------- ghcide/src/Development/IDE/Types/Exports.hs | 17 ++++-- ghcide/test/exe/Main.hs | 29 ++++++++- 4 files changed, 81 insertions(+), 31 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 857e686c7b..994e502d3e 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -1557,10 +1557,13 @@ importStyles IdentInfo {parent, rendered, isDatacon} | otherwise = ImportTopLevel rendered :| [] +-- | Used for adding new imports renderImportStyle :: ImportStyle -> T.Text -renderImportStyle (ImportTopLevel x) = x +renderImportStyle (ImportTopLevel x) = x +renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")" renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")" +-- | Used for extending import lists unImportStyle :: ImportStyle -> (Maybe String, String) unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x) unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index fcd8625d59..e5fa05ce8f 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -35,7 +35,7 @@ import Development.IDE.GHC.ExactPrint (ASTElement (parseAST), import Development.IDE.Spans.Common import FieldLabel (flLabel) import GHC.Exts (IsList (fromList)) -import GhcPlugins (sigPrec) +import GhcPlugins (mkRdrUnqual, sigPrec) import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) @@ -200,44 +200,48 @@ extendImport mparent identifier lDecl@(L l _) = Rewrite l $ \df -> do case mparent of Just parent -> extendImportViaParent df parent identifier lDecl - _ -> extendImportTopLevel df identifier lDecl + _ -> extendImportTopLevel identifier lDecl --- | Add an identifier to import list +-- | Add an identifier or a data type to import list -- -- extendImportTopLevel "foo" AST: -- -- import A --> Error -- import A (foo) --> Error -- import A (bar) --> import A (bar, foo) -extendImportTopLevel :: DynFlags -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs) -extendImportTopLevel df idnetifier (L l it@ImportDecl{..}) +extendImportTopLevel :: + -- | rendered + String -> + LImportDecl GhcPs -> + TransformT (Either String) (LImportDecl GhcPs) +extendImportTopLevel thing (L l it@ImportDecl{..}) | Just (hide, L l' lies) <- ideclHiding , hasSibling <- not $ null lies = do src <- uniqueSrcSpanT top <- uniqueSrcSpanT - rdr <- liftParseAST df idnetifier + let rdr = L src $ mkRdrUnqual $ mkVarOcc thing let alreadyImported = showNameWithoutUniques (occName (unLoc rdr)) `elem` map (showNameWithoutUniques @OccName) (listify (const True) lies) when alreadyImported $ - lift (Left $ idnetifier <> " already imported") + lift (Left $ thing <> " already imported") let lie = L src $ IEName rdr x = L top $ IEVar noExtField lie if x `elem` lies - then lift (Left $ idnetifier <> " already imported") + then lift (Left $ thing <> " already imported") else do when hasSibling $ addTrailingCommaT (last lies) addSimpleAnnT x (DP (0, if hasSibling then 1 else 0)) [] - addSimpleAnnT rdr dp00 $ unqalDP $ hasParen idnetifier + addSimpleAnnT rdr dp00 [(G AnnVal, dp00)] -- Parens are attachted to `lies`, so if `lies` was empty previously, -- we need change the ann key from `[]` to `:` to keep parens and other anns. unless hasSibling $ transferAnn (L l' lies) (L l' [x]) id return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])} -extendImportTopLevel _ _ _ = lift $ Left "Unable to extend the import list" +extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list" -- | Add an identifier with its parent to import list -- @@ -249,7 +253,14 @@ extendImportTopLevel _ _ _ = lift $ Left "Unable to extend the import list" -- import A () --> import A (Bar(Cons)) -- import A (Foo, Bar) --> import A (Foo, Bar(Cons)) -- import A (Foo, Bar()) --> import A (Foo, Bar(Cons)) -extendImportViaParent :: DynFlags -> String -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs) +extendImportViaParent :: + DynFlags -> + -- | parent (already parenthesized if needs) + String -> + -- | rendered child + String -> + LImportDecl GhcPs -> + TransformT (Either String) (LImportDecl GhcPs) extendImportViaParent df parent child (L l it@ImportDecl{..}) | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies where @@ -260,8 +271,8 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) -- ThingAbs ie => ThingWith ie child | parent == unIEWrappedName ie = do srcChild <- uniqueSrcSpanT - childRdr <- liftParseAST df child - let childLIE = L srcChild $ IEName childRdr + let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child + childLIE = L srcChild $ IEName childRdr x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] [] -- take anns from ThingAbs, and attatch parens to it transferAnn lAbs x $ \old -> old{annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]} @@ -273,7 +284,7 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) , hasSibling <- not $ null lies' = do srcChild <- uniqueSrcSpanT - childRdr <- liftParseAST df child + let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child let alreadyImported = showNameWithoutUniques (occName (unLoc childRdr)) @@ -284,7 +295,7 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) when hasSibling $ addTrailingCommaT (last lies') let childLIE = L srcChild $ IEName childRdr - addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen child + addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) [(G AnnVal, dp00)] return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)} go hide l' pre (x : xs) = go hide l' (x : pre) xs go hide l' pre [] @@ -294,14 +305,18 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) srcParent <- uniqueSrcSpanT srcChild <- uniqueSrcSpanT parentRdr <- liftParseAST df parent - childRdr <- liftParseAST df child + let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child + isParentOperator = hasParen parent when hasSibling $ addTrailingCommaT (head pre) - let parentLIE = L srcParent $ IEName parentRdr + let parentLIE = L srcParent $ (if isParentOperator then IEType else IEName) parentRdr childLIE = L srcChild $ IEName childRdr x :: LIE GhcPs = L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] [] - addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen parent - addSimpleAnnT childRdr (DP (0, 0)) $ unqalDP $ hasParen child + -- Add AnnType for the parent if it's parenthesized (type operator) + when isParentOperator $ + addSimpleAnnT parentLIE (DP (0, 0)) [(G AnnType, DP (0, 0))] + addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP 1 isParentOperator + addSimpleAnnT childRdr (DP (0, 0)) [(G AnnVal, dp00)] addSimpleAnnT x (DP (0, 0)) [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, DP (0, 0))] -- Parens are attachted to `pre`, so if `pre` was empty previously, -- we need change the ann key from `[]` to `:` to keep parens and other anns. @@ -317,10 +332,10 @@ hasParen :: String -> Bool hasParen ('(' : _) = True hasParen _ = False -unqalDP :: Bool -> [(KeywordId, DeltaPos)] -unqalDP paren = +unqalDP :: Int -> Bool -> [(KeywordId, DeltaPos)] +unqalDP c paren = ( if paren - then \x -> (G AnnOpenP, dp00) : x : [(G AnnCloseP, dp00)] + then \x -> (G AnnOpenP, DP (0, c)) : x : [(G AnnCloseP, dp00)] else pure ) (G AnnVal, dp00) @@ -364,7 +379,7 @@ extendHiding symbol (L l idecls) mlies df = do , (G AnnCloseP, DP (0, 0)) ] addSimpleAnnT x (DP (0, 0)) [] - addSimpleAnnT rdr dp00 $ unqalDP $ isOperator $ unLoc rdr + addSimpleAnnT rdr dp00 $ unqalDP 0 $ isOperator $ unLoc rdr if hasSibling then when hasSibling $ do addTrailingCommaT x diff --git a/ghcide/src/Development/IDE/Types/Exports.hs b/ghcide/src/Development/IDE/Types/Exports.hs index 28de5b6d58..a25d2faf0f 100644 --- a/ghcide/src/Development/IDE/Types/Exports.hs +++ b/ghcide/src/Development/IDE/Types/Exports.hs @@ -56,21 +56,30 @@ instance NFData IdentInfo where -- deliberately skip the rendered field rnf name `seq` rnf parent `seq` rnf isDatacon `seq` rnf moduleNameText +-- | Render an identifier as imported or exported style. +-- TODO: pattern synonym +renderIEWrapped :: Name -> Text +renderIEWrapped n + | isTcOcc occ && isSymOcc occ = "type " <> pack (printName n) + | otherwise = pack $ printName n + where + occ = occName n + mkIdentInfos :: Text -> AvailInfo -> [IdentInfo] mkIdentInfos mod (Avail n) = - [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod] + [IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod] mkIdentInfos mod (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent - = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) (isDataConName n) mod + = [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod | n <- nn ++ map flSelector flds ] ++ - [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod] + [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod] where parentP = pack $ printName parent mkIdentInfos mod (AvailTC _ nn flds) - = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod + = [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod | n <- nn ++ map flSelector flds ] diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 7089247fd6..f724374bde 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -1380,13 +1380,33 @@ extendImportTests = testGroup "extend import actions" , "x = Refl" ]) (Range (Position 3 17) (Position 3 18)) - ["Add (:~:)(Refl) to the import list of Data.Type.Equality"] + ["Add type (:~:)(Refl) to the import list of Data.Type.Equality"] (T.unlines [ "module ModuleA where" , "import Data.Type.Equality ((:~:) (Refl))" , "x :: (:~:) [] []" , "x = Refl" ]) + , expectFailBecause "importing pattern synonyms is unsupported" + $ testSession "extend import list with pattern synonym" $ template + [("ModuleA.hs", T.unlines + [ "{-# LANGUAGE PatternSynonyms #-}" + , "module ModuleA where" + , "pattern Some x = Just x" + ]) + ] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import A ()" + , "k (Some x) = x" + ]) + (Range (Position 2 3) (Position 2 7)) + ["Add pattern Some to the import list of A"] + (T.unlines + [ "module ModuleB where" + , "import A (pattern Some)" + , "k (Some x) = x" + ]) ] where codeActionTitle CodeAction{_title=x} = x @@ -1549,6 +1569,7 @@ suggestImportTests = testGroup "suggest import actions" , test True [] "f = (&) [] id" [] "import Data.Function ((&))" , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))" + , test True [] "f :: a ~~ b" [] "import Data.Type.Equality (type (~~))" , test True ["qualified Data.Text as T" ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" @@ -1563,6 +1584,7 @@ suggestImportTests = testGroup "suggest import actions" , "qualified Data.Data as T" ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" ] + , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)" ] where test = test' False @@ -1570,8 +1592,9 @@ suggestImportTests = testGroup "suggest import actions" test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other - cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo]}}" + cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}" liftIO $ writeFileUTF8 (dir "hie.yaml") cradle + liftIO $ writeFileUTF8 (dir "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"] doc <- createDoc "Test.hs" "haskell" before waitForProgressDone _diags <- waitForDiagnostics @@ -3987,7 +4010,7 @@ nonLocalCompletionTests = ["module A where", "import Data.Type.Equality ()", "f = Ref"] (Position 2 8) "Refl" - ["module A where", "import Data.Type.Equality ((:~:) (Refl))", "f = Ref"] + ["module A where", "import Data.Type.Equality (type (:~:) (Refl))", "f = Ref"] ] , testGroup "Record completion" [ completionCommandTest From 5217a040f49761bb3954c43f15f96e5312b7f77e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 3 Apr 2021 13:35:13 +0100 Subject: [PATCH 14/21] log exceptions before killing the server (#1651) * log hiedb exceptions before killing the server * This is not the hiedb thread - fix message * Fix handler - either an error or success --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 06afd28245..41e74e4025 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -141,7 +141,12 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig registerIdeConfiguration (shakeExtras ide) initConfig - _ <- flip forkFinally (const exitClientMsg) $ runWithDb dbLoc $ \hiedb hieChan -> do + let handleServerException (Left e) = do + logError (ideLogger ide) $ + T.pack $ "Fatal error in server thread: " <> show e + exitClientMsg + handleServerException _ = pure () + _ <- flip forkFinally handleServerException $ runWithDb dbLoc $ \hiedb hieChan -> do putMVar dbMVar (hiedb,hieChan) forever $ do msg <- readChan clientMsgChan From 594e31b0578845478aae4a9b9238fb3e2eca0511 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 3 Apr 2021 16:35:51 +0100 Subject: [PATCH 15/21] additional .gitignore entries (#1659) --- .gitignore | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/.gitignore b/.gitignore index 80d4fa3c76..1afc2c2943 100644 --- a/.gitignore +++ b/.gitignore @@ -33,3 +33,11 @@ test/testdata/**/hie.yaml # pre-commit-hook.nix .pre-commit-config.yaml + +# direnv +/.direnv/ +/.envrc + +# ghcide-bench +*.identifierPosition +/bench/example From de03ac2bf7d99a8329811b3002d191d8bca2b1f7 Mon Sep 17 00:00:00 2001 From: Javier Neira Date: Sun, 4 Apr 2021 08:51:04 +0200 Subject: [PATCH 16/21] Fix ignore paths (#1656) * Skip individual steps * Skip individual steps * And needs pre_job --- .github/workflows/bench.yml | 72 ++++++++++++++++++++--------------- .github/workflows/test.yml | 76 +++++++++++++++++++------------------ 2 files changed, 81 insertions(+), 67 deletions(-) diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index 3eb9c7afa8..41578e6d87 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -12,14 +12,13 @@ jobs: should_skip: ${{ steps.skip_check.outputs.should_skip }} steps: - id: skip_check - uses: fkirc/skip-duplicate-actions@master + uses: fkirc/skip-duplicate-actions@v3.4.0 with: cancel_others: true paths_ignore: '["**/docs/**", "**.md", "**/LICENSE", ".circleci/**", "install/**", "nix/**", "**/test/**"]' bench-init: needs: pre_job - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} runs-on: ${{ matrix.os }} strategy: @@ -29,18 +28,19 @@ jobs: os: [ubuntu-latest] steps: - # Cancel queued workflows from earlier commits in this branch - - uses: fkirc/skip-duplicate-actions@master - - - uses: actions/checkout@v2 - - run: git fetch origin master # check the master branch for benchmarking - - uses: haskell/actions/setup@v1 + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + uses: actions/checkout@v2 + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + run: git fetch origin master # check the master branch for benchmarking + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + uses: haskell/actions/setup@v1 with: ghc-version: ${{ matrix.ghc }} cabal-version: '3.2' enable-stack: false - - name: Cache Cabal + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Cache Cabal uses: actions/cache@v2 with: path: | @@ -52,37 +52,45 @@ jobs: v2-${{ runner.os }}-${{ matrix.ghc }}-bench- v2-${{ runner.os }}-${{ matrix.ghc }} - - run: cabal update + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + run: cabal update - - run: cabal configure --enable-benchmarks + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + run: cabal configure --enable-benchmarks - - name: Build + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Build shell: bash run: cabal build ghcide:benchHist - - name: Bench init + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Bench init shell: bash run: cabal bench ghcide:benchHist -j --benchmark-options="all-binaries" # tar is required to preserve file permissions # compression speeds up upload/download nicely - - name: tar workspace + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: tar workspace shell: bash run: tar -czf workspace.tar.gz * .git - - name: tar cabal + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: tar cabal run: | cd ~/.cabal tar -czf cabal.tar.gz * - - name: Upload workspace + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Upload workspace uses: actions/upload-artifact@v2 with: name: workspace retention-days: 1 path: workspace.tar.gz - - name: Upload .cabal + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Upload .cabal uses: actions/upload-artifact@v2 with: name: cabal-home @@ -90,8 +98,7 @@ jobs: path: ~/.cabal/cabal.tar.gz bench-example: - needs: [pre_job, bench-init] - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + needs: [bench-init, pre_job] runs-on: ${{ matrix.os }} strategy: @@ -102,42 +109,46 @@ jobs: example: ['Cabal-3.0.0.0', 'lsp-types-1.0.0.1'] steps: - # Cancel queued workflows from earlier commits in this branch - - uses: fkirc/skip-duplicate-actions@master - - - uses: haskell/actions/setup@v1 + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + uses: haskell/actions/setup@v1 with: ghc-version: ${{ matrix.ghc }} cabal-version: '3.2' enable-stack: false - - name: Download cabal home + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Download cabal home uses: actions/download-artifact@v2 with: name: cabal-home path: . - - name: Download workspace + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Download workspace uses: actions/download-artifact@v2 with: name: workspace path: . - - name: untar + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: untar run: | tar xzf workspace.tar.gz tar xzf cabal.tar.gz --directory ~/.cabal - - name: Bench + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Bench shell: bash run: cabal bench ghcide:benchHist -j --benchmark-options="${{ matrix.example }}" - - name: Display results + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Display results shell: bash run: | column -s, -t < ghcide/bench-results/unprofiled/${{ matrix.example }}/results.csv | tee ghcide/bench-results/unprofiled/${{ matrix.example }}/results.txt - - name: Archive benchmarking artifacts + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Archive benchmarking artifacts uses: actions/upload-artifact@v2 with: name: bench-results-${{ runner.os }}-${{ matrix.ghc }} @@ -147,7 +158,8 @@ jobs: ghcide/bench-results/**/*.svg ghcide/bench-results/**/*.eventlog.html - - name: Archive benchmark logs + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Archive benchmark logs uses: actions/upload-artifact@v2 with: name: bench-logs-${{ runner.os }}-${{ matrix.ghc }} diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index d2a563c5af..a11f0fdccc 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -16,15 +16,13 @@ jobs: should_skip: ${{ steps.skip_check.outputs.should_skip }} steps: - id: skip_check - uses: fkirc/skip-duplicate-actions@master + uses: fkirc/skip-duplicate-actions@v3.4.0 with: cancel_others: true paths_ignore: '["**/docs/**", "**.md", "**/LICENSE", ".circleci/**", "install/**", "nix/**"]' - test: needs: pre_job - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} runs-on: ${{ matrix.os }} strategy: fail-fast: true @@ -58,33 +56,34 @@ jobs: # ghc: '8.6.4' steps: - # Cancel queued workflows from earlier commits in this branch - - uses: fkirc/skip-duplicate-actions@master - - - uses: actions/checkout@v2 + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + uses: actions/checkout@v2 with: submodules: true - - uses: haskell/actions/setup@v1 + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + uses: haskell/actions/setup@v1 with: ghc-version: ${{ matrix.ghc }} cabal-version: "3.2" - - run: ./fmt.sh + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + run: ./fmt.sh name: "HLint via ./fmt.sh" - - name: Set some window specific things - if: matrix.os == 'windows-latest' + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.os == 'windows-latest'}} + name: Set some window specific things run: | echo "CABAL_STORE_DIR=$SYSTEMDRIVE\\SR" >> $GITHUB_ENV echo "CABAL_PKGS_DIR=~\\AppData\\cabal\\packages" >> $GITHUB_ENV - - name: Set some linux/macOS specific things - if: matrix.os != 'windows-latest' + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.os != 'windows-latest'}} + name: Set some linux/macOS specific things run: | echo "CABAL_STORE_DIR=~/.cabal/store" >> $GITHUB_ENV echo "CABAL_PKGS_DIR=~/.cabal/packages" >> $GITHUB_ENV - - name: Cache Cabal + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Cache Cabal uses: actions/cache@v2 env: cache-name: cache-cabal @@ -98,10 +97,12 @@ jobs: v2-${{ runner.os }}-${{ matrix.ghc }}-build- v2-${{ runner.os }}-${{ matrix.ghc }} - - run: cabal update + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + run: cabal update # Need this to work around filepath length limits in Windows - - name: Shorten binary names + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Shorten binary names run: | sed -i.bak -e 's/haskell-language-server/hls/g' \ -e 's/haskell_language_server/hls/g' \ @@ -109,17 +110,18 @@ jobs: sed -i.bak -e 's/Paths_haskell_language_server/Paths_hls/g' \ src/**/*.hs exe/*.hs - - name: Build + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} + name: Build # Retry it three times to workaround compiler segfaults in windows run: cabal build || cabal build || cabal build - - name: Test ghcide - if: ${{ matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + name: Test ghcide # run the tests without parallelism to avoid running out of memory run: cabal test ghcide --test-options="-j1 --rerun-update" || cabal test ghcide --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test ghcide --test-options="-j1 --rerun" - - name: Test func-test suite - if: ${{ matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + name: Test func-test suite env: HLS_TEST_EXE: hls HLS_WRAPPER_TEST_EXE: hls-wrapper @@ -128,8 +130,8 @@ jobs: # instances to be spun up for the poor github actions runner to handle run: cabal test func-test --test-options="-j1 --rerun --rerun-update" || cabal test func-test --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test func-test --test-options="-j1 --rerun" - - name: Test wrapper-test suite - if: ${{ matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + name: Test wrapper-test suite env: HLS_TEST_EXE: hls HLS_WRAPPER_TEST_EXE: hls-wrapper @@ -138,30 +140,30 @@ jobs: # instances to be spun up for the poor github actions runner to handle run: cabal test wrapper-test --test-options="-j1" || cabal test wrapper-test --test-options="-j1" || cabal test wrapper-test --test-options="-j1" - - name: Test hls-brittany-plugin - if: ${{ matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + name: Test hls-brittany-plugin run: cabal test hls-brittany-plugin || cabal test hls-brittany-plugin --test-options="-j1" - - name: Test hls-class-plugin - if: ${{ matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + name: Test hls-class-plugin run: cabal test hls-class-plugin || cabal test hls-class-plugin --test-options="-j1" - - name: Test hls-eval-plugin - if: ${{ matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + name: Test hls-eval-plugin run: cabal test hls-eval-plugin --test-options="-j1 --rerun" || cabal test hls-eval-plugin --test-options="-j1 --rerun" - - name: Test hls-haddock-comments-plugin - if: ${{ matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + name: Test hls-haddock-comments-plugin run: cabal test hls-haddock-comments-plugin || cabal test hls-haddock-comments-plugin --test-options="-j1" - - name: Test hls-splice-plugin - if: ${{ matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + name: Test hls-splice-plugin run: cabal test hls-splice-plugin || cabal test hls-splice-plugin --test-options="-j1" - - name: Test hls-stylish-haskell-plugin - if: ${{ matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + name: Test hls-stylish-haskell-plugin run: cabal test hls-stylish-haskell-plugin || cabal test hls-stylish-haskell-plugin --test-options="-j1" - - name: Test hls-tactics-plugin test suite - if: ${{ matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + name: Test hls-tactics-plugin test suite run: LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-tactics-plugin --test-options="-j1" From f6da6371d84fcba5813b53e00ef48e576c0cb8d0 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Sun, 4 Apr 2021 18:17:23 +0800 Subject: [PATCH 17/21] Add bounds for Diff (#1665) --- ghcide/ghcide.cabal | 2 +- hls-plugin-api/hls-plugin-api.cabal | 37 +++++++++------- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 9 ++-- .../hls-hlint-plugin/hls-hlint-plugin.cabal | 42 +++++++++++-------- 4 files changed, 51 insertions(+), 39 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 3086f0b422..4cfc57a1e4 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -84,7 +84,7 @@ library utf8-string, vector, hslogger, - Diff, + Diff ^>=0.4.0, vector, bytestring-encoding, opentelemetry >=0.6.1, diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index b3189b6f2a..5d65d5a7c6 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -4,7 +4,10 @@ version: 1.1.0.0 synopsis: Haskell Language Server API for plugin communication description: Please see the README on GitHub at -homepage: https://github.com/haskell/haskell-language-server/hls-plugin-api + +homepage: + https://github.com/haskell/haskell-language-server/hls-plugin-api + bug-reports: https://github.com/haskell/haskell-language-server/issues license: Apache-2.0 license-file: LICENSE @@ -32,38 +35,42 @@ library Ide.PluginUtils Ide.Types - hs-source-dirs: src + hs-source-dirs: src build-depends: , aeson , base >=4.12 && <5 , containers , data-default - , Diff - , lsp ^>=1.2.0 + , dependent-map + , dependent-sum + , Diff ^>=0.4.0 + , dlist , hashable , hslogger , lens + , lsp ^>=1.2.0 + , opentelemetry , process , regex-tdfa >=1.3.1.0 , shake >=0.17.5 , text , unordered-containers - , dependent-map - , dependent-sum - , dlist - , opentelemetry if os(windows) - build-depends: - Win32 + build-depends: Win32 + else - build-depends: - unix + build-depends: unix - ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors + ghc-options: + -Wall -Wredundant-constraints -Wno-name-shadowing + -Wno-unticked-promoted-constructors if flag(pedantic) ghc-options: -Werror - default-language: Haskell2010 - default-extensions: DataKinds, KindSignatures, TypeOperators + default-language: Haskell2010 + default-extensions: + DataKinds + KindSignatures + TypeOperators diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 7b2dcaf957..dc82d0a5de 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -19,11 +19,11 @@ build-type: Simple extra-source-files: LICENSE README.md - test/testdata/*.yaml - test/testdata/*.hs + test/testdata/*.cabal test/testdata/*.expected + test/testdata/*.hs test/testdata/*.lhs - test/testdata/*.cabal + test/testdata/*.yaml flag pedantic description: Enable -Werror @@ -53,7 +53,7 @@ library , base >=4.12 && <5 , containers , deepseq - , Diff + , Diff ^>=0.4.0 , directory , dlist , extra @@ -111,7 +111,6 @@ test-suite tests build-tool-depends: hls-eval-plugin:test-server -any hs-source-dirs: test main-is: Main.hs - build-depends: , aeson , base diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index b181bdc46c..0bed2ebb6f 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -2,7 +2,9 @@ cabal-version: 2.2 name: hls-hlint-plugin version: 1.0.0.1 synopsis: Hlint integration plugin with Haskell Language Server -description: Please see Haskell Language Server Readme (https://github.com/haskell/haskell-language-server#readme) +description: + Please see Haskell Language Server Readme (https://github.com/haskell/haskell-language-server#readme) + license: Apache-2.0 license-file: LICENSE author: The Haskell IDE Team @@ -23,29 +25,29 @@ flag ghc-lib Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported library - exposed-modules: Ide.Plugin.Hlint - hs-source-dirs: src + exposed-modules: Ide.Plugin.Hlint + hs-source-dirs: src build-depends: , aeson - , apply-refact >=0.9 - , base >=4.12 && <5 + , apply-refact >=0.9 + , base >=4.12 && <5 , binary , bytestring , containers , data-default , deepseq - , Diff + , Diff ^>=0.4.0 , directory , extra , filepath - , ghc-exactprint >=0.6.3.4 - , ghcide ^>= 1.1.0.0 + , ghc-exactprint >=0.6.3.4 + , ghcide ^>=1.1.0.0 , hashable - , lsp - , hlint >=3.2 - , hls-plugin-api >= 1.0 && < 1.2 + , hlint >=3.2 + , hls-plugin-api >=1.0 && <1.2 , hslogger , lens + , lsp , regex-tdfa , shake , temporary @@ -53,21 +55,25 @@ library , transformers , unordered-containers - if (!flag(ghc-lib) && impl(ghc >=8.10.1) && impl(ghc <9.0.0)) - build-depends: ghc ^>= 8.10 + if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <9.0.0)) + build-depends: ghc ^>=8.10 else build-depends: , ghc - , ghc-lib ^>= 8.10.4.20210206 - , ghc-lib-parser-ex ^>= 8.10 + , ghc-lib ^>=8.10.4.20210206 + , ghc-lib-parser-ex ^>=8.10 cpp-options: -DHLINT_ON_GHC_LIB - ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors + ghc-options: + -Wall -Wredundant-constraints -Wno-name-shadowing + -Wno-unticked-promoted-constructors if flag(pedantic) ghc-options: -Werror - default-language: Haskell2010 - default-extensions: DataKinds, TypeOperators + default-language: Haskell2010 + default-extensions: + DataKinds + TypeOperators From 80122ec35d9e13073b9cfc0ef6b2550d9062b32c Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Sun, 4 Apr 2021 23:00:01 +0800 Subject: [PATCH 18/21] Replace Barrier with MVar in lsp main (#1668) --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 41e74e4025..9fcc520db2 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -12,9 +12,6 @@ module Development.IDE.LSP.LanguageServer ( runLanguageServer ) where -import Control.Concurrent.Extra (newBarrier, - signalBarrier, - waitBarrier) import Control.Concurrent.STM import Control.Monad.Extra import Control.Monad.IO.Class @@ -56,12 +53,11 @@ runLanguageServer -> IO () runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do - -- These barriers are signaled when the threads reading from these chans exit. - -- This should not happen but if it does, we will make sure that the whole server - -- dies and can be restarted instead of losing threads silently. - clientMsgBarrier <- newBarrier + -- This MVar becomes full when the server thread exits or we receive exit message from client. + -- LSP loop will be canceled when it's full. + clientMsgVar <- newEmptyMVar -- Forcefully exit - let exit = signalBarrier clientMsgBarrier () + let exit = void $ tryPutMVar clientMsgVar () -- The set of requests ids that we have received but not finished processing pendingRequests <- newTVarIO Set.empty @@ -116,7 +112,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan inH outH serverDefinition - , void $ waitBarrier clientMsgBarrier + , void $ readMVar clientMsgVar ] where @@ -192,6 +188,7 @@ cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \Notifica exitHandler :: IO () -> LSP.Handlers (ServerM c) exitHandler exit = LSP.notificationHandler SExit $ const $ do (_, ide) <- ask + liftIO $ logDebug (ideLogger ide) "Received exit message" -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide liftIO exit From 30286922506c2c7e381a1a82dca36850fa6c9a29 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 5 Apr 2021 03:41:15 -0700 Subject: [PATCH 19/21] Port UseStale to ghcide --- ghcide/ghcide.cabal | 1 + ghcide/src/Development/IDE/Core/UseStale.hs | 156 ++++++++++++++++++++ 2 files changed, 157 insertions(+) create mode 100644 ghcide/src/Development/IDE/Core/UseStale.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 4cfc57a1e4..cc4be37321 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -148,6 +148,7 @@ library Development.IDE.Core.Service Development.IDE.Core.Shake Development.IDE.Core.Tracing + Development.IDE.Core.UseStale Development.IDE.GHC.Compat Development.IDE.Core.Compile Development.IDE.GHC.Error diff --git a/ghcide/src/Development/IDE/Core/UseStale.hs b/ghcide/src/Development/IDE/Core/UseStale.hs new file mode 100644 index 0000000000..e6b205fe60 --- /dev/null +++ b/ghcide/src/Development/IDE/Core/UseStale.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} + +module Development.IDE.Core.UseStale + ( Age(..) + , Tracked + , unTrack + , PositionMap + , TrackedStale (..) + , unsafeMkStale + , unsafeMkCurrent + , unsafeCopyAge + , MapAge (..) + , dualPositionMap + , useWithStale + , useWithStale_ + ) where + +import Control.Arrow +import Control.Category (Category) +import qualified Control.Category as C +import Control.DeepSeq (NFData) +import Data.Aeson +import Data.Coerce (coerce) +import Data.Functor ((<&>)) +import Data.Functor.Identity (Identity(Identity)) +import Data.Kind (Type) +import Data.String (fromString) +import Development.IDE (NormalizedFilePath, IdeRule, Action, Range, rangeToRealSrcSpan, realSrcSpanToRange) +import qualified Development.IDE.Core.PositionMapping as P +import qualified Development.IDE.Core.Shake as IDE +import qualified FastString as FS +import SrcLoc + + +------------------------------------------------------------------------------ +-- | A data kind for 'Tracked'. +data Age = Current | Stale Type + + +------------------------------------------------------------------------------ +-- | Some value, tagged with its age. All 'Current' ages are considered to be +-- the same thing, but 'Stale' values are protected by an untouchable variable +-- to ensure they can't be unified. +newtype Tracked (age :: Age) a = UnsafeTracked + { unTrack :: a + } + deriving stock (Functor, Foldable, Traversable) + deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData) + deriving (Applicative, Monad) via Identity + + +------------------------------------------------------------------------------ +-- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values +-- 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 + } + +instance Category PositionMap where + id = coerce P.zeroMapping + (.) = coerce P.composeDelta + + +------------------------------------------------------------------------------ +-- | Get a 'PositionMap' that runs in the opposite direction. +dualPositionMap :: PositionMap from to -> PositionMap to from +dualPositionMap (PositionMap (P.PositionMapping (P.PositionDelta from to))) = + PositionMap $ P.PositionMapping $ P.PositionDelta to from + + +------------------------------------------------------------------------------ +-- | A pair containing a @'Tracked' 'Stale'@ value, as well as +-- a 'PositionMapping' that will fast-forward values to the current age. +data TrackedStale a where + TrackedStale + :: Tracked (Stale s) a + -> PositionMap (Stale s) Current + -> TrackedStale a + +instance Functor TrackedStale where + fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm + + +------------------------------------------------------------------------------ +-- | A class for which 'Tracked' values can be run across a 'PositionMapping' +-- to change their ages. +class MapAge a where + {-# MINIMAL mapAgeFrom | mapAgeTo #-} + mapAgeFrom :: PositionMap from to -> Tracked to a -> Maybe (Tracked from a) + mapAgeFrom = mapAgeTo . dualPositionMap + + mapAgeTo :: PositionMap from to -> Tracked from a -> Maybe (Tracked to a) + mapAgeTo = mapAgeFrom . dualPositionMap + + +instance MapAge Range where + mapAgeFrom = coerce P.fromCurrentRange + mapAgeTo = coerce P.toCurrentRange + + +instance MapAge RealSrcSpan where + mapAgeFrom = + invMapAge (\fs -> rangeToRealSrcSpan (fromString $ FS.unpackFS fs)) + (srcSpanFile &&& realSrcSpanToRange) + . mapAgeFrom + + +------------------------------------------------------------------------------ +-- | Helper function for deriving 'MapAge' for values in terms of other +-- instances. +invMapAge + :: (c -> a -> b) + -> (b -> (c, a)) + -> (Tracked from a -> Maybe (Tracked to a)) + -> Tracked from b + -> Maybe (Tracked to b) +invMapAge to from f t = + let (c, t') = unTrack $ fmap from t + in fmap (fmap $ to c) $ f $ UnsafeTracked t' + + +unsafeMkCurrent :: age -> Tracked 'Current age +unsafeMkCurrent = coerce + + +unsafeMkStale :: age -> Tracked (Stale s) age +unsafeMkStale = coerce + + +unsafeCopyAge :: Tracked age a -> b -> Tracked age b +unsafeCopyAge _ = coerce + + +-- | Request a Rule result, it not available return the last computed result, if any, which may be stale +useWithStale :: IdeRule k v + => k -> NormalizedFilePath -> Action (Maybe (TrackedStale v)) +useWithStale key file = do + x <- IDE.useWithStale key file + pure $ x <&> \(v, pm) -> + TrackedStale (coerce v) (coerce pm) + +-- | Request a Rule result, it not available return the last computed result which may be stale. +-- Errors out if none available. +useWithStale_ :: IdeRule k v + => k -> NormalizedFilePath -> Action (TrackedStale v) +useWithStale_ key file = do + (v, pm) <- IDE.useWithStale_ key file + pure $ TrackedStale (coerce v) (coerce pm) + From 9a191f3c30c037d60eaf75f95dfc9842ef5f0dc4 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 5 Apr 2021 03:41:24 -0700 Subject: [PATCH 20/21] Use the new ghcide UseStale machinery --- .../src/Wingman/Judgements.hs | 2 +- .../src/Wingman/Judgements/Theta.hs | 2 +- .../src/Wingman/LanguageServer.hs | 22 ++-- .../Wingman/LanguageServer/TacticProviders.hs | 2 +- .../hls-tactics-plugin/src/Wingman/Plugin.hs | 3 +- .../hls-tactics-plugin/src/Wingman/Range.hs | 109 ------------------ 6 files changed, 16 insertions(+), 124 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs index 6c39966caf..37352c5380 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs @@ -12,12 +12,12 @@ import qualified Data.Map as M import Data.Maybe import Data.Set (Set) import qualified Data.Set as S +import Development.IDE.Core.UseStale (Tracked, unTrack) import Development.IDE.Spans.LocalBindings import OccName import SrcLoc import Type import Wingman.GHC (algebraicTyCon) -import Wingman.Range (Tracked(..)) import Wingman.Types diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs index e8ec4f36b5..40328c09cf 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs @@ -12,6 +12,7 @@ module Wingman.Judgements.Theta import Data.Maybe (fromMaybe, mapMaybe) import Data.Set (Set) import qualified Data.Set as S +import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat import Generics.SYB hiding (tyConName) import GhcPlugins (mkVarOcc, splitTyConApp_maybe, getTyVar_maybe) @@ -25,7 +26,6 @@ import TcEvidence import TcType (tcTyConAppTyCon_maybe) import TysPrim (eqPrimTyCon) import Wingman.Machinery -import Wingman.Range (Tracked(..)) import Wingman.Types diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index daaaaf2938..7f02483734 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -20,7 +20,9 @@ import qualified Data.Text as T import Data.Traversable import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake (IdeState (..), useWithStale, use) +import Development.IDE.Core.Shake (IdeState (..), use) +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.Spans.LocalBindings (Bindings, getDefiningBindings) @@ -28,10 +30,10 @@ import Development.Shake (Action, RuleResult) import Development.Shake.Classes (Typeable, Binary, Hashable, NFData) import qualified FastString import GhcPlugins (tupleDataCon, consDataCon, substTyAddInScope) -import Ide.Types (PluginId) import qualified Ide.Plugin.Config as Plugin -import Ide.PluginUtils (usePropertyLsp) import Ide.Plugin.Properties +import Ide.PluginUtils (usePropertyLsp) +import Ide.Types (PluginId) import Language.LSP.Server (MonadLsp, sendNotification) import Language.LSP.Types import OccName @@ -71,7 +73,7 @@ runCurrentIde -> NormalizedFilePath -> a -> MaybeT IO (Tracked 'Current r) -runCurrentIde state nfp a = MaybeT $ coerce $ runIde state $ use a nfp +runCurrentIde state nfp a = MaybeT $ fmap (fmap unsafeMkCurrent) $ runIde state $ use a nfp runStaleIde @@ -84,9 +86,7 @@ runStaleIde -> NormalizedFilePath -> a -> MaybeT IO (TrackedStale r) -runStaleIde state nfp a = do - (r, pm) <- MaybeT $ runIde state $ useWithStale a nfp - pure $ TrackedStale (coerce r) (coerce pm) +runStaleIde state nfp a = MaybeT $ runIde state $ useWithStale a nfp unsafeRunStaleIde @@ -100,7 +100,7 @@ unsafeRunStaleIde -> a -> MaybeT IO r unsafeRunStaleIde state nfp a = do - (r, _) <- MaybeT $ runIde state $ useWithStale a nfp + (r, _) <- MaybeT $ runIde state $ IDE.useWithStale a nfp pure r @@ -153,7 +153,7 @@ judgementForHole state nfp range features = do TrackedStale asts amapping <- runStaleIde state nfp GetHieAst case unTrack asts of HAR _ _ _ _ (HieFromDisk _) -> fail "Need a fresh hie file" - HAR _ (cautiousCopyAge asts -> hf) _ _ HieFresh -> do + HAR _ (unsafeCopyAge asts -> hf) _ _ HieFresh -> do range' <- liftMaybe $ mapAgeFrom amapping range binds <- runStaleIde state nfp GetBindings tcmod <- fmap (fmap tmrTypechecked) @@ -202,7 +202,7 @@ getSpanAndTypeAtHole :: Tracked age Range -> Tracked age (HieASTs b) -> Maybe (Tracked age RealSrcSpan, b) -getSpanAndTypeAtHole (unTrack -> range) (unTrack -> hf) = do +getSpanAndTypeAtHole r@(unTrack -> range) (unTrack -> hf) = do join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range) ast of Nothing -> Nothing @@ -213,7 +213,7 @@ getSpanAndTypeAtHole (unTrack -> range) (unTrack -> hf) = do -- Ensure we're actually looking at a hole here guard $ all (either (const False) $ isHole . occName) $ M.keysSet $ nodeIdentifiers info - pure (UnsafeTracked $ nodeSpan ast', ty) + pure (unsafeCopyAge r $ nodeSpan ast', ty) liftMaybe :: Monad m => Maybe a -> MaybeT m a diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs index b1e3869ae8..f8ef87eb18 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs @@ -20,6 +20,7 @@ import Data.Monoid import qualified Data.Text as T import Data.Traversable import DataCon (dataConName) +import Development.IDE.Core.UseStale (Tracked, Age(..)) import Development.IDE.GHC.Compat import GHC.Generics import GHC.LanguageExtensions.Type (Extension (LambdaCase)) @@ -33,7 +34,6 @@ import Wingman.Auto import Wingman.FeatureSet import Wingman.GHC import Wingman.Judgements -import Wingman.Range import Wingman.Tactics import Wingman.Types diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index fadf0c24db..b376176816 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -18,6 +18,7 @@ import Data.Foldable (for_) import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.Shake (IdeState (..)) +import Development.IDE.Core.UseStale (Tracked, TrackedStale(..), unTrack, mapAgeFrom, unsafeMkCurrent) import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint import Ide.Types @@ -54,7 +55,7 @@ descriptor plId = (defaultPluginDescriptor plId) codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction -codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) (cautiousToCurrent -> range) _ctx) +codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) (unsafeMkCurrent -> range) _ctx) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do cfg <- getTacticConfig plId liftIO $ fromMaybeT (Right $ List []) $ do diff --git a/plugins/hls-tactics-plugin/src/Wingman/Range.hs b/plugins/hls-tactics-plugin/src/Wingman/Range.hs index ede4b2fb67..fed5729996 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Range.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Range.hs @@ -3,21 +3,11 @@ module Wingman.Range where -import Control.Arrow -import Control.Category (Category) -import qualified Control.Category as C -import Control.DeepSeq (NFData) -import Data.Aeson -import Data.Coerce (coerce) -import Data.Functor.Identity (Identity(Identity)) -import Data.Kind (Type) import Development.IDE hiding (rangeToRealSrcSpan, rangeToSrcSpan) -import qualified Development.IDE.Core.PositionMapping as P import qualified FastString as FS import SrcLoc - ------------------------------------------------------------------------------ -- | Convert a DAML compiler Range to a GHC SrcSpan -- TODO(sandy): this doesn't belong here @@ -31,102 +21,3 @@ rangeToRealSrcSpan file (Range (Position startLn startCh) (Position endLn endCh) (mkRealSrcLoc (FS.fsLit file) (startLn + 1) (startCh + 1)) (mkRealSrcLoc (FS.fsLit file) (endLn + 1) (endCh + 1)) - ------------------------------------------------------------------------------- --- | A data kind for 'Tracked'. -data Age = Current | Stale Type - - ------------------------------------------------------------------------------- --- | Some value, tagged with its age. All 'Current' ages are considered to be --- the same thing, but 'Stale' values are protected by an untouchable variable --- to ensure they can't be unified. -newtype Tracked (age :: Age) a = UnsafeTracked - { unTrack :: a - } - deriving stock (Functor, Foldable, Traversable) - deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData) - deriving (Applicative, Monad) via Identity - - ------------------------------------------------------------------------------- --- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values --- change. Use the 'Category' instance to compose 'PositionMapping's in order --- to transform between values of different stale ages. -newtype PositionMapping (from :: Age) (to :: Age) = PositionMapping - { getPositionMapping :: P.PositionMapping - } - -instance Category PositionMapping where - id = coerce P.zeroMapping - (.) = coerce P.composeDelta - - ------------------------------------------------------------------------------- --- | Run a 'PositionMapping' backwards. -dual :: PositionMapping from to -> PositionMapping to from -dual (PositionMapping (P.PositionMapping (P.PositionDelta from to))) = - PositionMapping $ P.PositionMapping $ P.PositionDelta to from - - ------------------------------------------------------------------------------- --- | A pair containing a @'Tracked' 'Stale'@ value, as well as --- a 'PositionMapping' that will fast-forward values to the current age. -data TrackedStale a where - TrackedStale - :: Tracked (Stale s) a - -> PositionMapping (Stale s) Current - -> TrackedStale a - -instance Functor TrackedStale where - fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm - - ------------------------------------------------------------------------------- --- | A class for which 'Tracked' values can be run across a 'PositionMapping' --- to change their ages. -class MapAge a where - {-# MINIMAL mapAgeFrom | mapAgeTo #-} - mapAgeFrom :: PositionMapping from to -> Tracked to a -> Maybe (Tracked from a) - mapAgeFrom = mapAgeTo . dual - - mapAgeTo :: PositionMapping from to -> Tracked from a -> Maybe (Tracked to a) - mapAgeTo = mapAgeFrom . dual - - -instance MapAge Range where - mapAgeFrom = coerce P.fromCurrentRange - mapAgeTo = coerce P.toCurrentRange - - -instance MapAge RealSrcSpan where - mapAgeFrom = - invMapAge (\fs -> rangeToRealSrcSpan (FS.unpackFS fs)) - (srcSpanFile &&& realSrcSpanToRange) - . mapAgeFrom - - ------------------------------------------------------------------------------- --- | Helper function for deriving 'MapAge' for values in terms of other --- instances. -invMapAge - :: (c -> a -> b) - -> (b -> (c, a)) - -> (Tracked from a -> Maybe (Tracked to a)) - -> Tracked from b - -> Maybe (Tracked to b) -invMapAge to from f t = - let (c, t') = unTrack $ fmap from t - in fmap (fmap $ to c) $ f $ UnsafeTracked t' - - -cautiousToCurrent :: age -> Tracked 'Current age -cautiousToCurrent = coerce - - -cautiousToStale :: age -> Tracked (Stale s) age -cautiousToStale = coerce - -cautiousCopyAge :: Tracked age a -> b -> Tracked age b -cautiousCopyAge _ = coerce - From d54cccfddcc2eca2d567073a243d16c56c9b70b9 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 5 Apr 2021 09:48:47 -0700 Subject: [PATCH 21/21] Fix hlint complaints --- ghcide/ghcide.cabal | 2 ++ ghcide/src/Development/IDE/Core/UseStale.hs | 11 ++++------- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index d67fc20c01..7f521965cd 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -113,6 +113,8 @@ library BangPatterns DeriveFunctor DeriveGeneric + DeriveFoldable + DeriveTraversable FlexibleContexts GeneralizedNewtypeDeriving LambdaCase diff --git a/ghcide/src/Development/IDE/Core/UseStale.hs b/ghcide/src/Development/IDE/Core/UseStale.hs index e6b205fe60..04c1755817 100644 --- a/ghcide/src/Development/IDE/Core/UseStale.hs +++ b/ghcide/src/Development/IDE/Core/UseStale.hs @@ -1,10 +1,7 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} module Development.IDE.Core.UseStale ( Age(..)