hls-tactics-plugin 1.4.0.0 → 1.5.0.0
raw patch · 28 files changed
+191/−250 lines, 28 filesdep ~ghcide
Dependency ranges changed: ghcide
Files
- hls-tactics-plugin.cabal +2/−2
- src/Wingman/AbstractLSP/TacticActions.hs +9/−5
- src/Wingman/CaseSplit.hs +0/−1
- src/Wingman/CodeGen.hs +1/−8
- src/Wingman/CodeGen/Utils.hs +3/−7
- src/Wingman/Context.hs +1/−7
- src/Wingman/Debug.hs +18/−15
- src/Wingman/EmptyCase.hs +3/−6
- src/Wingman/GHC.hs +7/−44
- src/Wingman/Judgements.hs +1/−4
- src/Wingman/Judgements/SYB.hs +9/−3
- src/Wingman/Judgements/Theta.hs +1/−13
- src/Wingman/KnownStrategies.hs +1/−1
- src/Wingman/KnownStrategies/QuickCheck.hs +1/−6
- src/Wingman/LanguageServer.hs +59/−25
- src/Wingman/LanguageServer/Metaprogram.hs +4/−32
- src/Wingman/LanguageServer/TacticProviders.hs +0/−2
- src/Wingman/Machinery.hs +2/−6
- src/Wingman/Metaprogramming/Lexer.hs +1/−1
- src/Wingman/Metaprogramming/Parser.hs +1/−1
- src/Wingman/Metaprogramming/Parser/Documentation.hs +3/−3
- src/Wingman/Metaprogramming/ProofState.hs +2/−2
- src/Wingman/Naming.hs +1/−6
- src/Wingman/Range.hs +4/−3
- src/Wingman/StaticPlugin.hs +20/−6
- src/Wingman/Tactics.hs +5/−10
- src/Wingman/Types.hs +8/−15
- test/Utils.hs +24/−16
hls-tactics-plugin.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 category: Development name: hls-tactics-plugin-version: 1.4.0.0+version: 1.5.0.0 synopsis: Wingman plugin for Haskell Language Server description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -82,7 +82,7 @@ , ghc-boot-th , ghc-exactprint , ghc-source-gen ^>=0.4.1- , ghcide ^>=1.4.1+ , ghcide ^>=1.4.1 || ^>=1.5 , hls-graph , hls-plugin-api >=1.1 && <1.3 , hyphenation
src/Wingman/AbstractLSP/TacticActions.hs view
@@ -16,8 +16,6 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint import Generics.SYB.GHC (mkBindListT, everywhereM')-import GhcPlugins (occName)-import System.Timeout (timeout) import Wingman.AbstractLSP.Types import Wingman.CaseSplit import Wingman.GHC (liftMaybe, isHole, pattern AMatch, unXPat)@@ -27,6 +25,8 @@ import Wingman.Machinery (runTactic, scoreSolution) import Wingman.Range import Wingman.Types+import Development.IDE.Core.Service (getIdeOptionsIO)+import Development.IDE.Types.Options (IdeTesting(IdeTesting), IdeOptions (IdeOptions, optTesting)) ------------------------------------------------------------------------------@@ -36,7 +36,7 @@ -> Interaction makeTacticInteraction cmd = Interaction $ Continuation @_ @HoleTarget cmd- (SynthesizeCodeAction $ \env@LspEnv{..} hj -> do+ (SynthesizeCodeAction $ \env hj -> do pure $ commandProvider cmd $ TacticProviderData { tpd_lspEnv = env@@ -50,9 +50,13 @@ let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath fc_nfp)) hj_range TrackedStale _ pmmap <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource pm_span <- liftMaybe $ mapAgeFrom pmmap span+ IdeOptions{optTesting = IdeTesting isTesting} <-+ liftIO $ getIdeOptionsIO (shakeExtras le_ideState)+ let t = commandTactic cmd var_name+ timeout = if isTesting then maxBound else cfg_timeout_seconds le_config * seconds - liftIO $ runTactic (cfg_timeout_seconds le_config * seconds) hj_ctx hj_jdg t >>= \case+ liftIO $ runTactic timeout hj_ctx hj_jdg t >>= \case Left err -> pure $ pure@@ -76,7 +80,7 @@ $ addTimeoutMessage rtr $ pure $ GraftEdit- $ graftHole (RealSrcSpan $ unTrack pm_span) rtr+ $ graftHole (RealSrcSpan (unTrack pm_span) Nothing) rtr addTimeoutMessage :: RunTacticResults -> [ContinuationResult] -> [ContinuationResult]
src/Wingman/CaseSplit.hs view
@@ -12,7 +12,6 @@ import Development.IDE.GHC.Compat import GHC.Exts (IsString (fromString)) import GHC.SourceGen (funBindsWithFixity, match, wildP)-import OccName import Wingman.GHC import Wingman.Types
src/Wingman/CodeGen.hs view
@@ -10,7 +10,6 @@ ) where -import ConLike import Control.Lens ((%~), (<>~), (&)) import Control.Monad.Except import Control.Monad.Reader (ask)@@ -22,7 +21,6 @@ import Data.List import qualified Data.Set as S import Data.Traversable-import DataCon import Development.IDE.GHC.Compat import GHC.Exts import GHC.SourceGen (occNameToStr)@@ -30,11 +28,6 @@ import GHC.SourceGen.Expr import GHC.SourceGen.Overloaded import GHC.SourceGen.Pat-import GhcPlugins (isSymOcc, mkVarOccFS)-import OccName (occName)-import PatSyn-import Type hiding (Var)-import TysPrim (alphaTy) import Wingman.CodeGen.Utils import Wingman.GHC import Wingman.Judgements@@ -202,7 +195,7 @@ conLikeExTys :: ConLike -> [TyCoVar]-conLikeExTys (RealDataCon d) = dataConExTys d+conLikeExTys (RealDataCon d) = dataConExTyCoVars d conLikeExTys (PatSynCon p) = patSynExTys p patSynExTys :: PatSyn -> [TyCoVar]
src/Wingman/CodeGen/Utils.hs view
@@ -1,14 +1,10 @@ module Wingman.CodeGen.Utils where -import ConLike (ConLike(RealDataCon), conLikeName)+import Data.String import Data.List-import DataCon import Development.IDE.GHC.Compat-import GHC.Exts import GHC.SourceGen (RdrNameStr (UnqualStr), recordConE, string)-import GHC.SourceGen.Overloaded-import GhcPlugins (nilDataCon, charTy, eqType)-import Name+import GHC.SourceGen.Overloaded as SourceGen import Wingman.GHC (getRecordFields) @@ -48,7 +44,7 @@ ------------------------------------------------------------------------------ -- | Like 'var', but works over standard GHC 'OccName's.-var' :: Var a => OccName -> a+var' :: SourceGen.Var a => OccName -> a var' = var . fromString . occNameString
src/Wingman/Context.hs view
@@ -1,6 +1,5 @@ module Wingman.Context where -import Bag import Control.Arrow import Control.Monad.Reader import Data.Coerce (coerce)@@ -8,12 +7,7 @@ import Data.Maybe (fromMaybe, isJust, mapMaybe) import qualified Data.Set as S import Development.IDE.GHC.Compat-import GhcPlugins (ExternalPackageState (eps_inst_env), piResultTys, eps_fam_inst_env, extractModule)-import InstEnv (lookupInstEnv, InstEnvs(..), is_dfun)-import OccName-import TcRnTypes-import TcType (tcSplitTyConApp, tcSplitPhiTy)-import TysPrim (alphaTys)+import Development.IDE.GHC.Compat.Util import Wingman.GHC (normalizeType) import Wingman.Judgements.Theta import Wingman.Types
src/Wingman/Debug.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-}-+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_GHC -Wno-unused-imports #-} module Wingman.Debug ( unsafeRender , unsafeRender'@@ -16,20 +17,10 @@ import Control.DeepSeq import Control.Exception-import Debug.Trace-import DynFlags (unsafeGlobalDynFlags)-import Outputable hiding ((<>))+import qualified Debug.Trace+import Development.IDE.GHC.Compat (PlainGhcException, Outputable(..), SDoc, showSDocUnsafe) import System.IO.Unsafe (unsafePerformIO) -#if __GLASGOW_HASKELL__ >= 808-import PlainPanic (PlainGhcException)-type GHC_EXCEPTION = PlainGhcException-#else-import Panic (GhcException)-type GHC_EXCEPTION = GhcException-#endif-- ------------------------------------------------------------------------------ -- | Print something unsafeRender :: Outputable a => a -> String@@ -38,10 +29,10 @@ unsafeRender' :: SDoc -> String unsafeRender' sdoc = unsafePerformIO $ do- let z = showSDoc unsafeGlobalDynFlags sdoc+ let z = showSDocUnsafe sdoc -- We might not have unsafeGlobalDynFlags (like during testing), in which -- case GHC panics. Instead of crashing, let's just fail to print.- !res <- try @GHC_EXCEPTION $ evaluate $ deepseq z z+ !res <- try @PlainGhcException $ evaluate $ deepseq z z pure $ either (const "<unsafeRender'>") id res {-# NOINLINE unsafeRender' #-} @@ -57,3 +48,15 @@ traceFX :: String -> (a -> String) -> a -> a traceFX str f a = trace (mappend ("!!!" <> str <> ": ") $ f a) a +traceM :: Applicative f => String -> f ()+trace :: String -> a -> a+traceShowId :: Show a => a -> a+#ifdef DEBUG+traceM = Debug.Trace.traceM+trace = Debug.Trace.trace+traceShowId = Debug.Trace.traceShowId+#else+traceM _ = pure ()+trace _ = id+traceShowId = id+#endif
src/Wingman/EmptyCase.hs view
@@ -22,16 +22,13 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.Core.UseStale-import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat hiding (empty) import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.LocalBindings (getLocalScope) import Ide.Types import Language.LSP.Server import Language.LSP.Types-import OccName import Prelude hiding (span)-import Prelude hiding (span)-import TcRnTypes (tcg_binds) import Wingman.AbstractLSP.Types import Wingman.CodeGen (destructionFor) import Wingman.GHC@@ -73,7 +70,7 @@ ty edits <- liftMaybe $ hush $ mkWorkspaceEdits le_dflags ccs fc_uri (unTrack pm) $- graftMatchGroup (RealSrcSpan $ unTrack ss) $+ graftMatchGroup (RealSrcSpan (unTrack ss) Nothing) $ noLoc matches pure ( range@@ -153,7 +150,7 @@ True -> pure empty False -> case ss of- RealSrcSpan r -> do+ RealSrcSpan r _ -> do rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r pure $ Just (rss', ty) UnhelpfulSpan _ -> empty
src/Wingman/GHC.hs view
@@ -3,12 +3,8 @@ module Wingman.GHC where -import Bag (bagToList)-import Class (classTyVars)-import ConLike import Control.Monad.State import Control.Monad.Trans.Maybe (MaybeT(..))-import CoreUtils (exprType) import Data.Bool (bool) import Data.Function (on) import Data.Functor ((<&>))@@ -18,24 +14,10 @@ import Data.Set (Set) import qualified Data.Set as S import Data.Traversable-import DataCon-import Development.IDE.GHC.Compat hiding (exprType)-import DsExpr (dsExpr)-import DsMonad (initDs)-import FamInst (tcLookupDataFamInst_maybe)-import FamInstEnv (normaliseType)+import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat.Util import GHC.SourceGen (lambda) import Generics.SYB (Data, everything, everywhere, listify, mkQ, mkT)-import GhcPlugins (Role (Nominal))-import OccName-import TcRnMonad-import TcType-import TyCoRep-import Type-import TysWiredIn (charTyCon, doubleTyCon, floatTyCon, intTyCon)-import Unify-import Unique-import Var import Wingman.StaticPlugin (pattern MetaprogramSyntax) import Wingman.Types @@ -61,8 +43,8 @@ cloneTyVar :: TyVar -> TyVar cloneTyVar t = let uniq = getUnique t- some_magic_number = 49- in setVarUnique t $ deriveUnique uniq some_magic_number+ some_magic_char = 'w' -- 'w' for wingman ;D+ in setVarUnique t $ newTagUnique uniq some_magic_char ------------------------------------------------------------------------------@@ -92,7 +74,7 @@ -- | Get the data cons of a type, if it has any. tacticsGetDataCons :: Type -> Maybe ([DataCon], [Type]) tacticsGetDataCons ty- | Just (_, ty') <- tcSplitForAllTy_maybe ty+ | Just (_, ty') <- tcSplitForAllTyVarBinder_maybe ty = tacticsGetDataCons ty' tacticsGetDataCons ty | Just _ <- algebraicTyCon ty@@ -118,7 +100,7 @@ case M.lookup tv reps of Just tv' -> tv' Nothing -> tv- ) $ snd $ tcSplitForAllTys t+ ) $ snd $ tcSplitForAllTyVars t ------------------------------------------------------------------------------@@ -137,7 +119,7 @@ -- | Is this an algebraic type? algebraicTyCon :: Type -> Maybe TyCon algebraicTyCon ty- | Just (_, ty') <- tcSplitForAllTy_maybe ty+ | Just (_, ty') <- tcSplitForAllTyVarBinder_maybe ty = algebraicTyCon ty' algebraicTyCon (splitTyConApp_maybe -> Just (tycon, _)) | tycon == intTyCon = Nothing@@ -322,15 +304,6 @@ (GRHSs _ [L _ (GRHS _ [] body)] (L _ where_binds)) --dataConExTys :: DataCon -> [TyCoVar]-#if __GLASGOW_HASKELL__ >= 808-dataConExTys = DataCon.dataConExTyCoVars-#else-dataConExTys = DataCon.dataConExTyVars-#endif-- ------------------------------------------------------------------------------ -- | In GHC 8.8, sometimes patterns are wrapped in 'XPat'. -- The nitty gritty details are explained at@@ -353,16 +326,6 @@ -- not use it, but sometimes it can't be helped. typeCheck :: HscEnv -> TcGblEnv -> HsExpr GhcTc -> IO (Maybe Type) typeCheck hscenv tcg = fmap snd . initDs hscenv tcg . fmap exprType . dsExpr---mkFunTys' :: [Type] -> Type -> Type-mkFunTys' =-#if __GLASGOW_HASKELL__ <= 808- mkFunTys-#else- mkVisFunTys-#endif- ------------------------------------------------------------------------------ -- | Expand type and data families
src/Wingman/Judgements.hs view
@@ -1,6 +1,5 @@ module Wingman.Judgements where -import ConLike (ConLike) import Control.Arrow import Control.Lens hiding (Context) import Data.Bool@@ -13,10 +12,8 @@ import Data.Set (Set) import qualified Data.Set as S import Development.IDE.Core.UseStale (Tracked, unTrack)+import Development.IDE.GHC.Compat hiding (isTopLevel) import Development.IDE.Spans.LocalBindings-import OccName-import SrcLoc-import Type import Wingman.GHC (algebraicTyCon, normalizeType) import Wingman.Judgements.Theta import Wingman.Types
src/Wingman/Judgements/SYB.hs view
@@ -8,8 +8,8 @@ import Data.Generics hiding (typeRep) import qualified Data.Text as T import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat.Util (unpackFS) import GHC.Exts (Any)-import GhcPlugins (unpackFS) import Type.Reflection import Unsafe.Coerce (unsafeCoerce) import Wingman.StaticPlugin (pattern WingmanMetaprogram)@@ -85,8 +85,14 @@ _ -> False -metaprogramQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)]-metaprogramQ ss = everythingContaining ss $ mkQ mempty $ \case+metaprogramAtQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)]+metaprogramAtQ ss = everythingContaining ss $ mkQ mempty $ \case+ L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS $ program)+ (_ :: LHsExpr GhcTc) -> mempty+++metaprogramQ :: GenericQ [(SrcSpan, T.Text)]+metaprogramQ = everything (<>) $ mkQ mempty $ \case L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS $ program) (_ :: LHsExpr GhcTc) -> mempty
src/Wingman/Judgements/Theta.hs view
@@ -12,7 +12,6 @@ , allEvidenceToSubst ) where -import Class (classTyVars) import Control.Applicative (empty) import Control.Lens (preview) import Data.Coerce (coerce)@@ -21,20 +20,9 @@ import Data.Set (Set) import qualified Data.Set as S import Development.IDE.Core.UseStale-import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat hiding (empty) import Generics.SYB hiding (tyConName, empty, Generic) import GHC.Generics-import GhcPlugins (mkVarOcc, splitTyConApp_maybe, getTyVar_maybe, zipTvSubst, unionTCvSubst, emptyTCvSubst, TCvSubst)-#if __GLASGOW_HASKELL__ > 806-import GhcPlugins (eqTyCon)-#else-import GhcPlugins (nameRdrName, tyConName)-import PrelNames (eqTyCon_RDR)-#endif-import TcEvidence-import TcType (substTy)-import TcType (tcTyConAppTyCon_maybe)-import TysPrim (eqPrimTyCon) import Wingman.GHC import Wingman.Types
src/Wingman/KnownStrategies.hs view
@@ -1,7 +1,7 @@ module Wingman.KnownStrategies where import Data.Foldable (for_)-import OccName (mkVarOcc, mkClsOcc)+import Development.IDE.GHC.Compat.Core import Refinery.Tactic import Wingman.Judgements (jGoal) import Wingman.KnownStrategies.QuickCheck (deriveArbitrary)
src/Wingman/KnownStrategies/QuickCheck.hs view
@@ -1,11 +1,9 @@ module Wingman.KnownStrategies.QuickCheck where -import ConLike (ConLike(RealDataCon)) import Data.Bool (bool) import Data.Generics (everything, mkQ) import Data.List (partition)-import DataCon (DataCon, dataConName)-import Development.IDE.GHC.Compat (GhcPs, HsExpr, noLoc)+import Development.IDE.GHC.Compat import GHC.Exts (IsString (fromString)) import GHC.List (foldl') import GHC.SourceGen (int)@@ -13,10 +11,7 @@ import GHC.SourceGen.Expr (case', lambda, let') import GHC.SourceGen.Overloaded (App ((@@)), HasList (list)) import GHC.SourceGen.Pat (conP)-import OccName (HasOccName (occName), mkVarOcc, occNameString) import Refinery.Tactic (goal, rule, failure)-import TyCon (TyCon, tyConDataCons, tyConName)-import Type (splitTyConApp_maybe) import Wingman.CodeGen import Wingman.Judgements (jGoal) import Wingman.Machinery (tracePrim)
src/Wingman/LanguageServer.hs view
@@ -8,7 +8,6 @@ module Wingman.LanguageServer where -import ConLike import Control.Arrow ((***)) import Control.Monad import Control.Monad.IO.Class@@ -27,45 +26,40 @@ import qualified Data.Set as S import qualified Data.Text as T import Data.Traversable-import Development.IDE (getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange)-import Development.IDE (hscEnv)+import Development.IDE (hscEnv, getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange, defineNoDiagnostics, IdeAction)+import Development.IDE.Core.PositionMapping (idDelta) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Rules (usePropertyAction) import Development.IDE.Core.Service (runAction)-import Development.IDE.Core.Shake (IdeState (..), uses, define, use)+import Development.IDE.Core.Shake (IdeState (..), uses, define, use, addPersistentRule) import qualified Development.IDE.Core.Shake as IDE import Development.IDE.Core.UseStale-import Development.IDE.GHC.Compat hiding (parseExpr)+import Development.IDE.GHC.Compat hiding (empty)+import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.GHC.Error (realSrcSpanToRange) import Development.IDE.GHC.ExactPrint import Development.IDE.Graph (Action, RuleResult, Rules, action)-import Development.IDE.Graph.Classes (Binary, Hashable, NFData)+import Development.IDE.Graph.Classes (Hashable, NFData) import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings)-import qualified FastString import GHC.Generics (Generic) import Generics.SYB hiding (Generic)-import GhcPlugins (tupleDataCon, consDataCon, substTyAddInScope, ExternalPackageState, HscEnv (hsc_EPS), unpackFS) import qualified Ide.Plugin.Config as Plugin import Ide.Plugin.Properties import Ide.PluginUtils (usePropertyLsp) import Ide.Types (PluginId)-import Language.Haskell.GHC.ExactPrint (Transform)-import Language.Haskell.GHC.ExactPrint (modifyAnnsT, addAnnotationsForPretty)+import Language.Haskell.GHC.ExactPrint (Transform, modifyAnnsT, addAnnotationsForPretty) import Language.LSP.Server (MonadLsp, sendNotification) import Language.LSP.Types hiding (SemanticTokenAbsolute (length, line), SemanticTokenRelative (length), SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities-import OccName import Prelude hiding (span) import Retrie (transformA)-import SrcLoc (containsSpan)-import TcRnTypes (tcg_binds, TcGblEnv) import Wingman.Context import Wingman.GHC import Wingman.Judgements-import Wingman.Judgements.SYB (everythingContaining, metaprogramQ)+import Wingman.Judgements.SYB (everythingContaining, metaprogramQ, metaprogramAtQ) import Wingman.Judgements.Theta import Wingman.Range import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax)@@ -85,11 +79,14 @@ runIde :: String -> String -> IdeState -> Action a -> IO a runIde herald action state = runAction ("Wingman." <> herald <> "." <> action) state +runIdeAction :: String -> String -> IdeState -> IdeAction a -> IO a+runIdeAction herald action state = IDE.runIdeAction ("Wingman." <> herald <> "." <> action) (shakeExtras state) + runCurrentIde :: forall a r . ( r ~ RuleResult a- , Eq a , Hashable a , Binary a , Show a , Typeable a , NFData a+ , Eq a , Hashable a , Show a , Typeable a , NFData a , Show r, Typeable r, NFData r ) => String@@ -104,7 +101,7 @@ runStaleIde :: forall a r . ( r ~ RuleResult a- , Eq a , Hashable a , Binary a , Show a , Typeable a , NFData a+ , Eq a , Hashable a , Show a , Typeable a , NFData a , Show r, Typeable r, NFData r ) => String@@ -119,7 +116,7 @@ unsafeRunStaleIde :: forall a r . ( r ~ RuleResult a- , Eq a , Hashable a , Binary a , Show a , Typeable a , NFData a+ , Eq a , Hashable a , Show a , Typeable a , NFData a , Show r, Typeable r, NFData r ) => String@@ -131,7 +128,22 @@ (r, _) <- MaybeT $ runIde herald (show a) state $ IDE.useWithStale a nfp pure r +unsafeRunStaleIdeFast+ :: forall a r+ . ( r ~ RuleResult a+ , Eq a , Hashable a , Show a , Typeable a , NFData a+ , Show r, Typeable r, NFData r+ )+ => String+ -> IdeState+ -> NormalizedFilePath+ -> a+ -> MaybeT IO r+unsafeRunStaleIdeFast herald state nfp a = do+ (r, _) <- MaybeT $ runIdeAction herald (show a) state $ IDE.useWithStaleFast a nfp+ pure r + ------------------------------------------------------------------------------ properties :: Properties@@ -183,7 +195,7 @@ getAllMetaprograms :: Data a => a -> [String] getAllMetaprograms = everything (<>) $ mkQ mempty $ \case- WingmanMetaprogram fs -> [ unpackFS fs ]+ WingmanMetaprogram fs -> [ FastString.unpackFS fs ] (_ :: HsExpr GhcTc) -> mempty @@ -222,7 +234,7 @@ eps <- liftIO $ readIORef $ hsc_EPS $ hscEnv henv (jdg, ctx) <- liftMaybe $ mkJudgementAndContext cfg g binds new_rss tcg (hscEnv henv) eps- let mp = getMetaprogramAtSpan (fmap RealSrcSpan tcg_rss) tcg_t+ let mp = getMetaprogramAtSpan (fmap (`RealSrcSpan` Nothing) tcg_rss) tcg_t dflags <- getIdeDynflags state nfp pure $ HoleJudgment@@ -261,10 +273,10 @@ eps evidence top_provs = getRhsPosVals tcg_rss tcs- already_destructed = getAlreadyDestructed (fmap RealSrcSpan tcg_rss) tcs+ already_destructed = getAlreadyDestructed (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs local_hy = spliceProvenance top_provs $ hypothesisFromBindings binds_rss binds- evidence = getEvidenceAtHole (fmap RealSrcSpan tcg_rss) tcs+ evidence = getEvidenceAtHole (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs cls_hy = foldMap evidenceToHypothesis evidence subst = ts_unifier $ evidenceToSubst evidence defaultTacticState pure $@@ -339,7 +351,7 @@ getRhsPosVals (unTrack -> rss) (unTrack -> tcs) = everything (<>) (mkQ mempty $ \case TopLevelRHS name ps- (L (RealSrcSpan span) -- body with no guards and a single defn+ (L (RealSrcSpan span _) -- body with no guards and a single defn (HsVar _ (L _ hole))) _ | containsSpan rss span -- which contains our span@@ -495,7 +507,7 @@ isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) = everything (||) (mkQ False $ \case TopLevelRHS _ _- (L (RealSrcSpan span) _)+ (L (RealSrcSpan span _) _) (EmptyLocalBinds _) -> containsSpan rss span _ -> False ) tcs@@ -524,10 +536,17 @@ instance Hashable WriteDiagnostics instance NFData WriteDiagnostics-instance Binary WriteDiagnostics type instance RuleResult WriteDiagnostics = () +data GetMetaprograms = GetMetaprograms+ deriving (Eq, Show, Typeable, Generic)++instance Hashable GetMetaprograms+instance NFData GetMetaprograms++type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)]+ wingmanRules :: PluginId -> Rules () wingmanRules plId = do define $ \WriteDiagnostics nfp ->@@ -559,6 +578,21 @@ , Just () ) + defineNoDiagnostics $ \GetMetaprograms nfp -> do+ TrackedStale tcg tcg_map <- fmap tmrTypechecked <$> useWithStale_ TypeCheck nfp+ let scrutinees = traverse (metaprogramQ . tcg_binds) tcg+ return $ Just $ flip mapMaybe scrutinees $ \aged@(unTrack -> (ss, program)) -> do+ case ss of+ RealSrcSpan r _ -> do+ rss' <- mapAgeTo tcg_map $ unsafeCopyAge aged r+ pure (rss', program)+ UnhelpfulSpan _ -> Nothing++ -- This persistent rule helps to avoid blocking HLS hover providers at startup+ -- Without it, the GetMetaprograms rule blocks on typecheck and prevents other+ -- hover providers from being used to produce a response+ addPersistentRule GetMetaprograms $ \_ -> return $ Just ([], idDelta, Nothing)+ action $ do files <- getFilesOfInterestUntracked void $ uses WriteDiagnostics $ Map.keys files@@ -613,7 +647,7 @@ getMetaprogramAtSpan (unTrack -> ss) = fmap snd . listToMaybe- . metaprogramQ ss+ . metaprogramAtQ ss . tcg_binds . unTrack
src/Wingman/LanguageServer/Metaprogram.hs view
@@ -15,21 +15,14 @@ import Data.List (find) import Data.Maybe import qualified Data.Text as T-import Data.Traversable import Development.IDE (positionToRealSrcLoc) import Development.IDE (realSrcSpanToRange)-import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.Core.UseStale-import Development.IDE.GHC.Compat-import GhcPlugins (containsSpan, realSrcLocSpan, realSrcSpanStart)+import Development.IDE.GHC.Compat hiding (empty) import Ide.Types import Language.LSP.Types import Prelude hiding (span)-import Prelude hiding (span)-import TcRnTypes (tcg_binds)-import Wingman.GHC-import Wingman.Judgements.SYB (metaprogramQ) import Wingman.LanguageServer import Wingman.Metaprogramming.Parser (attempt_it) import Wingman.Types@@ -41,13 +34,14 @@ hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do let loc = fmap (realSrcLocSpan . positionToRealSrcLoc nfp) pos+ stale = unsafeRunStaleIdeFast "hoverProvider" state nfp cfg <- getTacticConfig plId liftIO $ fromMaybeT (Right Nothing) $ do- holes <- getMetaprogramsAtSpan state nfp $ RealSrcSpan $ unTrack loc+ holes <- stale GetMetaprograms fmap (Right . Just) $- case (find (flip containsSpan (unTrack loc) . unTrack . fst) holes) of+ case find (flip containsSpan (unTrack loc) . unTrack . fst) holes of Just (trss, program) -> do let tr_range = fmap realSrcSpanToRange trss rsl = realSrcSpanStart $ unTrack trss@@ -62,27 +56,5 @@ Nothing -> empty hoverProvider _ _ _ = pure $ Right Nothing - fromMaybeT :: Functor m => a -> MaybeT m a -> m a fromMaybeT def = fmap (fromMaybe def) . runMaybeT---getMetaprogramsAtSpan- :: IdeState- -> NormalizedFilePath- -> SrcSpan- -> MaybeT IO [(Tracked 'Current RealSrcSpan, T.Text)]-getMetaprogramsAtSpan state nfp ss = do- let stale a = runStaleIde "getMetaprogramsAtSpan" state nfp a-- TrackedStale tcg tcg_map <- fmap (fmap tmrTypechecked) $ stale TypeCheck-- let scrutinees = traverse (metaprogramQ ss . tcg_binds) tcg- for scrutinees $ \aged@(unTrack -> (ss, program)) -> do- case ss of- RealSrcSpan r -> do- rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r- pure (rss', program)- UnhelpfulSpan _ -> empty--
src/Wingman/LanguageServer/TacticProviders.hs view
@@ -16,12 +16,10 @@ import Data.Monoid import qualified Data.Set as S import qualified Data.Text as T-import DataCon (dataConName) import Development.IDE.GHC.Compat import GHC.LanguageExtensions.Type (Extension (LambdaCase)) import Ide.Types import Language.LSP.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..))-import OccName import Prelude hiding (span) import Wingman.AbstractLSP.Types import Wingman.Auto
src/Wingman/Machinery.hs view
@@ -24,16 +24,12 @@ import qualified Data.Set as S import Data.Traversable (for) import Development.IDE.Core.Compile (lookupName)-import Development.IDE.GHC.Compat-import GhcPlugins (GlobalRdrElt (gre_name), lookupOccEnv, varType)+import Development.IDE.GHC.Compat hiding (isTopLevel, empty) import Refinery.Future import Refinery.ProofState import Refinery.Tactic import Refinery.Tactic.Internal import System.Timeout (timeout)-import TcType-import Type (tyCoVarsOfTypeWellScoped)-import TysPrim (alphaTyVar, alphaTy) import Wingman.Context (getInstance) import Wingman.GHC (tryUnifyUnivarsButNotSkolems, updateSubst, tacticsGetDataCons, freshTyvars) import Wingman.Judgements@@ -235,7 +231,7 @@ newUnivar :: MonadState TacticState m => m Type newUnivar = do freshTyvars $- mkInvForAllTys [alphaTyVar] alphaTy+ mkInfForAllTys [alphaTyVar] alphaTy ------------------------------------------------------------------------------
src/Wingman/Metaprogramming/Lexer.hs view
@@ -11,7 +11,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Void-import Name+import Development.IDE.GHC.Compat.Core (OccName, mkVarOcc) import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import qualified Text.Megaparsec.Char.Lexer as L
src/Wingman/Metaprogramming/Parser.hs view
@@ -11,7 +11,7 @@ import Data.Maybe (listToMaybe) import qualified Data.Text as T import Development.IDE.GHC.Compat (RealSrcLoc, srcLocLine, srcLocCol, srcLocFile)-import FastString (unpackFS)+import Development.IDE.GHC.Compat.Util (unpackFS) import Refinery.Tactic (failure) import qualified Refinery.Tactic as R import qualified Text.Megaparsec as P
src/Wingman/Metaprogramming/Parser/Documentation.hs view
@@ -6,9 +6,9 @@ import Data.List (sortOn) import Data.String (IsString) import Data.Text (Text)-import Data.Text.Prettyprint.Doc hiding (parens)-import Data.Text.Prettyprint.Doc.Render.String (renderString)-import GhcPlugins (OccName)+import Prettyprinter hiding (parens)+import Prettyprinter.Render.String (renderString)+import Development.IDE.GHC.Compat (OccName) import qualified Text.Megaparsec as P import Wingman.Metaprogramming.Lexer (Parser, identifier, variable, parens) import Wingman.Types (TacticsM)
src/Wingman/Metaprogramming/ProofState.hs view
@@ -6,8 +6,8 @@ import Data.Bool (bool) import Data.Functor ((<&>)) import qualified Data.Text as T-import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Util.Panic+import Prettyprinter+import Prettyprinter.Render.Util.Panic import Language.LSP.Types (sectionSeparator) import Wingman.Judgements (jHypothesis) import Wingman.Types
src/Wingman/Naming.hs view
@@ -14,13 +14,8 @@ import Data.Set (Set) import qualified Data.Set as S import Data.Traversable-import GhcPlugins (charTy, maybeTyCon)-import Name-import TcType+import Development.IDE.GHC.Compat.Core hiding (IsFunction) import Text.Hyphenation (hyphenate, english_US)-import TyCon-import Type-import TysWiredIn (listTyCon, unitTyCon) import Wingman.GHC (tcTyVar_maybe)
src/Wingman/Range.hs view
@@ -4,15 +4,16 @@ module Wingman.Range where import Development.IDE hiding (rangeToRealSrcSpan, rangeToSrcSpan)-import qualified FastString as FS-import SrcLoc+import Development.IDE.GHC.Compat.Core+import Development.IDE.GHC.Compat.Util as FS + ------------------------------------------------------------------------------ -- | 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+rangeToSrcSpan file range = RealSrcSpan (rangeToRealSrcSpan file range) Nothing rangeToRealSrcSpan :: String -> Range -> RealSrcSpan
src/Wingman/StaticPlugin.hs view
@@ -9,11 +9,11 @@ import Data.Data import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat.Util import GHC.LanguageExtensions.Type (Extension(EmptyCase, QuasiQuotes)) import Generics.SYB-import GhcPlugins hiding ((<>)) import Ide.Types-+import Plugins (purePlugin) staticPlugin :: DynFlagsModifications staticPlugin = mempty@@ -41,11 +41,17 @@ pattern WingmanMetaprogram :: FastString -> HsExpr p-pattern WingmanMetaprogram mp- <- HsSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp)+pattern WingmanMetaprogram mp <-+#if __GLASGOW_HASKELL__ >= 900+ HsPragE _ (HsPragSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp)) (L _ ( HsVar _ _))+#else+ HsSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp)+ (L _ ( HsVar _ _))+#endif + enableQuasiQuotes :: DynFlags -> DynFlags enableQuasiQuotes = flip xopt_set QuasiQuotes @@ -61,9 +67,13 @@ #if __GLASGOW_HASKELL__ >= 808 metaprogrammingPlugin :: StaticPlugin metaprogrammingPlugin =- StaticPlugin $ PluginWithArgs (defaultPlugin { parsedResultAction = worker }) []+ StaticPlugin $ PluginWithArgs pluginDefinition [] where- worker :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule+ pluginDefinition = defaultPlugin+ { parsedResultAction = worker+ , pluginRecompile = purePlugin+ }+ worker :: Monad m => [CommandLineOption] -> ModSummary -> HsParsedModule -> m HsParsedModule worker _ _ pm = pure $ pm { hpm_module = addMetaprogrammingSyntax $ hpm_module pm } #endif @@ -73,7 +83,11 @@ mkMetaprogram :: SrcSpan -> FastString -> HsExpr GhcPs mkMetaprogram ss mp =+#if __GLASGOW_HASKELL__ >= 900+ HsPragE noExtField (HsPragSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp))+#else HsSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp)+#endif $ L ss $ HsVar noExtField $ L ss
src/Wingman/Tactics.hs view
@@ -6,7 +6,6 @@ , runTactic ) where -import ConLike (ConLike(RealDataCon)) import Control.Applicative (Alternative(empty), (<|>)) import Control.Lens ((&), (%~), (<>~)) import Control.Monad (filterM)@@ -26,16 +25,12 @@ import qualified Data.Set as S import Data.Traversable (for) import DataCon-import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat hiding (empty) import GHC.Exts import GHC.SourceGen ((@@)) import GHC.SourceGen.Expr-import Name (occNameString, occName)-import OccName (mkVarOcc) import Refinery.Tactic import Refinery.Tactic.Internal-import TcType-import Type hiding (Var) import Wingman.CodeGen import Wingman.GHC import Wingman.Judgements@@ -150,7 +145,7 @@ bound_occs = fmap fst bindings hy' = lambdaHypothesis top_hole bindings jdg' = introduce ctx hy'- $ withNewGoal (CType $ mkFunTys' (drop num_occs args) res) jdg+ $ withNewGoal (CType $ mkVisFunTys (drop num_occs args) res) jdg ext <- newSubgoal jdg' pure $ ext@@ -289,7 +284,7 @@ saturated_args = dropEnd n all_args unsaturated_args = takeEnd n all_args rule $ \jdg -> do- unify g (CType $ mkFunTys' unsaturated_args ret)+ unify g (CType $ mkVisFunTys unsaturated_args ret) ext <- fmap unzipTrace $ traverse ( newSubgoal@@ -545,7 +540,7 @@ nary n = do a <- newUnivar b <- newUnivar- applyByType $ mkFunTys' (replicate n a) b+ applyByType $ mkVisFunTys (replicate n a) b self :: TacticsM ()@@ -630,7 +625,7 @@ let g = jGoal jdg fresh_ty <- newUnivar a <- newSubgoal $ withNewGoal (CType fresh_ty) jdg- f <- newSubgoal $ withNewGoal (coerce mkFunTys' [fresh_ty] g) jdg+ f <- newSubgoal $ withNewGoal (coerce mkVisFunTys [fresh_ty] g) jdg pure $ fmap noLoc $ (@@) <$> fmap unLoc f <*> fmap unLoc a
src/Wingman/Types.hs view
@@ -14,7 +14,6 @@ , Span ) where -import ConLike (ConLike) import Control.Lens hiding (Context) import Control.Monad.Reader import Control.Monad.State@@ -33,23 +32,17 @@ import Development.IDE (Range) import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat hiding (Node)+import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Orphans ()-import FamInstEnv (FamInstEnvs) import GHC.Exts (fromString) import GHC.Generics import GHC.SourceGen (var)-import GhcPlugins (GlobalRdrElt, mkRdrUnqual)-import InstEnv (InstEnvs(..))-import OccName import Refinery.ProofState import Refinery.Tactic import Refinery.Tactic.Internal (TacticT(TacticT), RuleT (RuleT)) import System.IO.Unsafe (unsafePerformIO)-import Type (TCvSubst, Var, eqType, nonDetCmpType, emptyTCvSubst)-import UniqSupply (takeUniqFromSupply, mkSplitUniqSupply, UniqSupply)-import Unique (nonDetCmpUnique, Uniquable, getUnique, Unique, mkUnique) import Wingman.Debug-import Data.IORef+import Data.IORef ------------------------------------------------------------------------------@@ -199,7 +192,7 @@ ------------------------------------------------------------------------------ -- | Generate a new 'Unique'-freshUnique :: MonadState TacticState m => m Unique+freshUnique :: MonadState TacticState m => m Util.Unique freshUnique = do (uniq, supply) <- gets $ takeUniqFromSupply . ts_unique_gen modify' $! field @"ts_unique_gen" .~ supply@@ -269,11 +262,11 @@ deriving Show via a deriving stock (Data, Typeable) -instance Uniquable a => Eq (Uniquely a) where- (==) = (==) `on` getUnique . getViaUnique+instance Util.Uniquable a => Eq (Uniquely a) where+ (==) = (==) `on` Util.getUnique . getViaUnique -instance Uniquable a => Ord (Uniquely a) where- compare = nonDetCmpUnique `on` getUnique . getViaUnique+instance Util.Uniquable a => Ord (Uniquely a) where+ compare = Util.nonDetCmpUnique `on` Util.getUnique . getViaUnique -- NOTE(sandy): The usage of list here is mostly for convenience, but if it's@@ -349,7 +342,7 @@ local f (RuleT m) = RuleT $ Effect $ local f $ pure m mkMetaHoleName :: Int -> RdrName-mkMetaHoleName u = mkRdrUnqual $ mkVarOcc $ "_" <> show (mkUnique 'w' u)+mkMetaHoleName u = mkRdrUnqual $ mkVarOcc $ "_" <> show (Util.mkUnique 'w' u) instance MetaSubst Int (Synthesized (LHsExpr GhcPs)) where -- TODO(sandy): This join is to combine the synthesizeds
test/Utils.hs view
@@ -10,7 +10,7 @@ import Control.DeepSeq (deepseq) import qualified Control.Exception as E import Control.Lens hiding (List, failing, (<.>), (.=))-import Control.Monad (unless)+import Control.Monad (unless, void) import Control.Monad.IO.Class import Data.Aeson import Data.Foldable@@ -84,7 +84,11 @@ resetGlobalHoleRef runSessionForTactics $ do doc <- openDoc (fp <.> "hs") "haskell"- _ <- waitForDiagnostics+ -- wait for diagnostics to start coming+ void waitForDiagnostics+ -- wait for the entire build to finish, so that Tactics code actions that+ -- use stale data will get uptodate stuff+ void $ waitForTypecheck doc actions <- getCodeActions doc $ pointRange line col let titles = mapMaybe codeActionTitle actions for_ ts $ \(f, tc, var) -> do@@ -107,20 +111,24 @@ resetGlobalHoleRef runSessionForTactics $ do doc <- openDoc (input <.> "hs") "haskell"- _ <- waitForDiagnostics+ -- wait for diagnostics to start coming+ void waitForDiagnostics+ -- wait for the entire build to finish, so that Tactics code actions that+ -- use stale data will get uptodate stuff+ void $ waitForTypecheck doc actions <- getCodeActions doc $ pointRange line col- Just (InR CodeAction {_command = Just c})- <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions- executeCommand c- _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit)- edited <- documentContents doc- let expected_name = input <.> "expected" <.> "hs"- -- Write golden tests if they don't already exist- liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do- T.writeFile expected_name edited- expected <- liftIO $ T.readFile expected_name- liftIO $ edited `eq` expected-+ case find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions of+ Just (InR CodeAction {_command = Just c}) -> do+ executeCommand c+ _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit)+ edited <- documentContents doc+ let expected_name = input <.> "expected" <.> "hs"+ -- Write golden tests if they don't already exist+ liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do+ T.writeFile expected_name edited+ expected <- liftIO $ T.readFile expected_name+ liftIO $ edited `eq` expected+ _ -> error $ show actions mkCodeLensTest :: FilePath@@ -154,7 +162,7 @@ resetGlobalHoleRef runSessionForTactics $ do doc <- openDoc (input <.> "hs") "haskell"- _ <- waitForDiagnostics+ _ <- waitForBuildQueue lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc liftIO $ lenses `shouldBe` []