diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index 0643624a53..3ff75ba36c 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal @@ -25,29 +25,30 @@ library hs-source-dirs: src exposed-modules: Ide.Plugin.Tactic - Ide.Plugin.Tactic.Auto - Ide.Plugin.Tactic.CaseSplit - Ide.Plugin.Tactic.CodeGen - Ide.Plugin.Tactic.CodeGen.Utils - Ide.Plugin.Tactic.Context - Ide.Plugin.Tactic.Debug - Ide.Plugin.Tactic.FeatureSet - Ide.Plugin.Tactic.GHC - Ide.Plugin.Tactic.Judgements - Ide.Plugin.Tactic.Judgements.Theta - Ide.Plugin.Tactic.KnownStrategies - Ide.Plugin.Tactic.KnownStrategies.QuickCheck - Ide.Plugin.Tactic.LanguageServer - Ide.Plugin.Tactic.LanguageServer.TacticProviders - Ide.Plugin.Tactic.Machinery - Ide.Plugin.Tactic.Naming - Ide.Plugin.Tactic.Range - Ide.Plugin.Tactic.Simplify - Ide.Plugin.Tactic.Tactics - Ide.Plugin.Tactic.Types + Wingman.Auto + Wingman.CaseSplit + Wingman.CodeGen + Wingman.CodeGen.Utils + Wingman.Context + Wingman.Debug + Wingman.FeatureSet + Wingman.GHC + Wingman.Judgements + Wingman.Judgements.Theta + Wingman.KnownStrategies + Wingman.KnownStrategies.QuickCheck + Wingman.LanguageServer + Wingman.LanguageServer.TacticProviders + Wingman.Machinery + Wingman.Naming + Wingman.Plugin + Wingman.Range + Wingman.Simplify + Wingman.Tactics + Wingman.Types ghc-options: - -Wno-name-shadowing -Wredundant-constraints -Wno-unticked-promoted-constructors + -Wall -Wno-name-shadowing -Wredundant-constraints -Wno-unticked-promoted-constructors if flag(pedantic) ghc-options: -Werror @@ -78,7 +79,29 @@ library , deepseq default-language: Haskell2010 - default-extensions: DataKinds, TypeOperators + default-extensions: + DataKinds, + DeriveAnyClass, + DeriveFunctor, + DeriveGeneric, + DeriveDataTypeable, + DeriveFoldable, + DeriveTraversable, + DerivingStrategies, + DerivingVia, + FlexibleContexts, + FlexibleInstances, + GADTs, + GeneralizedNewtypeDeriving, + LambdaCase, + MultiParamTypeClasses, + NumDecimals, + OverloadedLabels, + PatternSynonyms, + ScopedTypeVariables, + TypeApplications, + TypeOperators, + ViewPatterns executable test-server diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index 5aae79cf97..35ecf0dcfe 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumDecimals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -- | A plugin that uses tactics to synthesize code module Ide.Plugin.Tactic ( descriptor @@ -13,265 +5,5 @@ module Ide.Plugin.Tactic , TacticCommand (..) ) where -import Bag (bagToList, listToBag) -import Control.Exception (evaluate) -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Trans.Maybe -import Data.Aeson -import Data.Bifunctor (first) -import Data.Data (Data) -import Data.Foldable (for_) -import Data.Generics.Aliases (mkQ) -import Data.Generics.Schemes (everything) -import Data.Maybe -import Data.Monoid -import qualified Data.Text as T -import Data.Traversable -import Development.IDE.Core.Shake (IdeState (..)) -import Development.IDE.GHC.Compat -import Development.IDE.GHC.ExactPrint -import Ide.Plugin.Tactic.CaseSplit -import Ide.Plugin.Tactic.GHC -import Ide.Plugin.Tactic.LanguageServer -import Ide.Plugin.Tactic.LanguageServer.TacticProviders -import Ide.Plugin.Tactic.Range -import Ide.Plugin.Tactic.Tactics -import Ide.Plugin.Tactic.Types -import Ide.Types -import Language.LSP.Server -import Language.LSP.Types -import Language.LSP.Types.Capabilities -import OccName -import Prelude hiding (span) -import System.Timeout - - -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginCommands - = fmap (\tc -> - PluginCommand - (tcCommandId tc) - (tacticDesc $ tcCommandName tc) - (tacticCmd $ commandTactic tc)) - [minBound .. maxBound] - , pluginHandlers = - mkPluginHandler STextDocumentCodeAction codeActionProvider - } - - - -codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction -codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range _ctx) - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do - cfg <- getTacticConfig $ shakeExtras state - liftIO $ fromMaybeT (Right $ List []) $ do - (_, jdg, _, dflags) <- judgementForHole state nfp range $ cfg_feature_set cfg - actions <- lift $ - -- This foldMap is over the function monoid. - foldMap commandProvider [minBound .. maxBound] - dflags - cfg - plId - uri - range - jdg - pure $ Right $ List actions -codeActionProvider _ _ _ = pure $ Right $ List [] - - -showUserFacingMessage - :: MonadLsp cfg m - => UserFacingMessage - -> m (Either ResponseError a) -showUserFacingMessage ufm = do - showLspMessage $ mkShowMessageParams ufm - pure $ Left $ mkErr InternalError $ T.pack $ show ufm - - -tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams -tacticCmd tac state (TacticParams uri range var_name) - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do - features <- getFeatureSet $ shakeExtras state - 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 - - timingOut 2e8 $ join $ - case runTactic ctx jdg $ tac $ mkVarOcc $ T.unpack var_name of - Left _ -> Left TacticErrors - Right rtr -> - case rtr_extract rtr of - L _ (HsVar _ (L _ rdr)) | isHole (occName rdr) -> - Left NothingToDo - _ -> pure $ mkWorkspaceEdits span dflags ccs uri pm rtr - - case res of - Nothing -> do - showUserFacingMessage TimedOut - Just (Left ufm) -> do - showUserFacingMessage ufm - Just (Right edit) -> do - sendRequest - SWorkspaceApplyEdit - (ApplyWorkspaceEditParams Nothing edit) - (const $ pure ()) - pure $ Right Null -tacticCmd _ _ _ = - pure $ Left $ mkErr InvalidRequest "Bad URI" - - -timingOut - :: Int -- ^ Time in microseconds - -> a -- ^ Computation to run - -> MaybeT IO a -timingOut t m = MaybeT $ timeout t $ evaluate m - - -mkErr :: ErrorCode -> T.Text -> ResponseError -mkErr code err = ResponseError code err Nothing - - -joinNote :: e -> Maybe (Either e a) -> Either e a -joinNote e Nothing = Left e -joinNote _ (Just a) = a - - ------------------------------------------------------------------------------- --- | Turn a 'RunTacticResults' into concrete edits to make in the source --- document. -mkWorkspaceEdits - :: RealSrcSpan - -> DynFlags - -> ClientCapabilities - -> Uri - -> Annotated ParsedSource - -> RunTacticResults - -> Either UserFacingMessage WorkspaceEdit -mkWorkspaceEdits span dflags ccs uri pm rtr = do - for_ (rtr_other_solns rtr) $ traceMX "other solution" - traceMX "solution" $ rtr_extract rtr - let g = graftHole (RealSrcSpan span) rtr - response = transform dflags ccs uri g pm - in first (InfrastructureError . T.pack) response - - ------------------------------------------------------------------------------- --- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly --- deals with top-level holes, in which we might need to fiddle with the --- 'Match's that bind variables. -graftHole - :: SrcSpan - -> RunTacticResults - -> Graft (Either String) ParsedSource -graftHole span rtr - | _jIsTopHole (rtr_jdg rtr) - = graftSmallestDeclsWithM span - $ graftDecl span $ \pats -> - splitToDecl (fst $ last $ ctxDefiningFuncs $ rtr_ctx rtr) - $ iterateSplit - $ mkFirstAgda (fmap unXPat pats) - $ unLoc - $ rtr_extract rtr -graftHole span rtr - = graft span - $ rtr_extract rtr - - ------------------------------------------------------------------------------- --- | Merge in the 'Match'es of a 'FunBind' into a 'HsDecl'. Used to perform --- agda-style case splitting in which we need to separate one 'Match' into --- many, without affecting any matches which might exist but don't need to be --- split. -mergeFunBindMatches - :: ([Pat GhcPs] -> LHsDecl GhcPs) - -> SrcSpan - -> HsBind GhcPs - -> Either String (HsBind GhcPs) -mergeFunBindMatches make_decl span - (fb@FunBind {fun_matches = mg@MG {mg_alts = L alts_src alts}}) = - pure $ fb - { fun_matches = mg - { mg_alts = L alts_src $ do - alt@(L alt_src match) <- alts - case span `isSubspanOf` alt_src of - True -> do - let pats = fmap fromPatCompatPs $ m_pats match - L _ (ValD _ (FunBind {fun_matches = MG - {mg_alts = L _ to_add}})) = make_decl pats - to_add - False -> pure alt - } - } -mergeFunBindMatches _ _ _ = - Left "mergeFunBindMatches: called on something that isnt a funbind" - - -throwError :: String -> TransformT (Either String) a -throwError = lift . Left - - ------------------------------------------------------------------------------- --- | Helper function to route 'mergeFunBindMatches' into the right place in an --- AST --- correctly dealing with inserting into instance declarations. -graftDecl - :: SrcSpan - -> ([Pat GhcPs] -> LHsDecl GhcPs) - -> LHsDecl GhcPs - -> TransformT (Either String) (Maybe [LHsDecl GhcPs]) -graftDecl span - make_decl - (L src (ValD ext fb)) - = either throwError (pure . Just . pure . L src . ValD ext) $ - mergeFunBindMatches make_decl span fb --- TODO(sandy): add another case for default methods in class definitions -graftDecl span - make_decl - (L src (InstD ext - cid@ClsInstD{cid_inst = - cidi@ClsInstDecl{cid_sigs = _sigs, cid_binds = binds}})) - = do - binds' <- - for (bagToList binds) $ \b@(L bsrc bind) -> do - case bind of - fb@FunBind{} | span `isSubspanOf` bsrc -> - either throwError (pure . L bsrc) $ - mergeFunBindMatches make_decl span fb - _ -> pure b - - pure $ Just $ pure $ L src $ InstD ext $ cid - { cid_inst = cidi - { cid_binds = listToBag binds' - } - } -graftDecl span _ x = do - traceMX "biggest" $ - unsafeRender $ - locateBiggest @(Match GhcPs (LHsExpr GhcPs)) span x - traceMX "first" $ - unsafeRender $ - locateFirst @(Match GhcPs (LHsExpr GhcPs)) x - throwError "graftDecl: don't know about this AST form" - - -fromMaybeT :: Functor m => a -> MaybeT m a -> m a -fromMaybeT def = fmap (fromMaybe def) . runMaybeT - - -locateBiggest :: (Data r, Data a) => SrcSpan -> a -> Maybe r -locateBiggest ss x = getFirst $ everything (<>) - ( mkQ mempty $ \case - L span r | ss `isSubspanOf` span -> pure r - _ -> mempty - ) x - - -locateFirst :: (Data r, Data a) => a -> Maybe r -locateFirst x = getFirst $ everything (<>) - ( mkQ mempty $ \case - r -> pure r - ) x +import Wingman.Plugin diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Auto.hs b/plugins/hls-tactics-plugin/src/Wingman/Auto.hs similarity index 54% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Auto.hs rename to plugins/hls-tactics-plugin/src/Wingman/Auto.hs index 05bdb5c862..7c42ffd430 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Auto.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Auto.hs @@ -1,13 +1,13 @@ -module Ide.Plugin.Tactic.Auto where +module Wingman.Auto where -import Control.Monad.State (gets) -import Ide.Plugin.Tactic.Context -import Ide.Plugin.Tactic.Judgements -import Ide.Plugin.Tactic.KnownStrategies -import Ide.Plugin.Tactic.Machinery (tracing) -import Ide.Plugin.Tactic.Tactics -import Ide.Plugin.Tactic.Types +import Control.Monad.State (gets) import Refinery.Tactic +import Wingman.Context +import Wingman.Judgements +import Wingman.KnownStrategies +import Wingman.Machinery (tracing) +import Wingman.Tactics +import Wingman.Types ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CaseSplit.hs b/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs similarity index 83% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CaseSplit.hs rename to plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs index 79ce781d4d..8083240951 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CaseSplit.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs @@ -1,25 +1,20 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Ide.Plugin.Tactic.CaseSplit +module Wingman.CaseSplit ( mkFirstAgda , iterateSplit , splitToDecl ) where -import Data.Bool (bool) +import Data.Bool (bool) import Data.Data import Data.Generics -import Data.Set (Set) -import qualified Data.Set as S +import Data.Set (Set) +import qualified Data.Set as S import Development.IDE.GHC.Compat -import GHC.Exts (IsString (fromString)) -import GHC.SourceGen (funBinds, match, wildP) -import Ide.Plugin.Tactic.GHC -import Ide.Plugin.Tactic.Types +import GHC.Exts (IsString (fromString)) +import GHC.SourceGen (funBinds, match, wildP) import OccName +import Wingman.GHC +import Wingman.Types diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs similarity index 94% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs rename to plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs index 750743dca1..3906fcc578 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs @@ -3,9 +3,9 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -module Ide.Plugin.Tactic.CodeGen - ( module Ide.Plugin.Tactic.CodeGen - , module Ide.Plugin.Tactic.CodeGen.Utils +module Wingman.CodeGen + ( module Wingman.CodeGen + , module Wingman.CodeGen.Utils ) where @@ -22,13 +22,13 @@ import GHC.SourceGen.Binds import GHC.SourceGen.Expr import GHC.SourceGen.Overloaded import GHC.SourceGen.Pat -import Ide.Plugin.Tactic.CodeGen.Utils -import Ide.Plugin.Tactic.GHC -import Ide.Plugin.Tactic.Judgements -import Ide.Plugin.Tactic.Machinery -import Ide.Plugin.Tactic.Naming -import Ide.Plugin.Tactic.Types import Type hiding (Var) +import Wingman.CodeGen.Utils +import Wingman.GHC +import Wingman.Judgements +import Wingman.Machinery +import Wingman.Naming +import Wingman.Types destructMatches diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen/Utils.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs similarity index 94% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen/Utils.hs rename to plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs index eb728066bc..4a0a0d07db 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen/Utils.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE ViewPatterns #-} - -module Ide.Plugin.Tactic.CodeGen.Utils where +module Wingman.CodeGen.Utils where import Data.List import DataCon @@ -8,7 +6,7 @@ import Development.IDE.GHC.Compat import GHC.Exts import GHC.SourceGen (RdrNameStr, recordConE) import GHC.SourceGen.Overloaded -import Ide.Plugin.Tactic.GHC (getRecordFields) +import Wingman.GHC (getRecordFields) import Name diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Context.hs b/plugins/hls-tactics-plugin/src/Wingman/Context.hs similarity index 82% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Context.hs rename to plugins/hls-tactics-plugin/src/Wingman/Context.hs index 28df47b695..e148fcd1b8 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Context.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Context.hs @@ -1,16 +1,13 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - -module Ide.Plugin.Tactic.Context where +module Wingman.Context where import Bag import Control.Arrow import Control.Monad.Reader import Development.IDE.GHC.Compat -import Ide.Plugin.Tactic.FeatureSet (FeatureSet) -import Ide.Plugin.Tactic.Types import OccName import TcRnTypes +import Wingman.FeatureSet (FeatureSet) +import Wingman.Types mkContext :: FeatureSet -> [(OccName, CType)] -> TcGblEnv -> Context diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Debug.hs b/plugins/hls-tactics-plugin/src/Wingman/Debug.hs similarity index 98% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Debug.hs rename to plugins/hls-tactics-plugin/src/Wingman/Debug.hs index a66fe016d2..7db728b9ab 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Debug.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Debug.hs @@ -2,7 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-} -module Ide.Plugin.Tactic.Debug +module Wingman.Debug ( unsafeRender , unsafeRender' , traceM diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/FeatureSet.hs b/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs similarity index 97% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/FeatureSet.hs rename to plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs index 426d7949bf..a36f2da49a 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/FeatureSet.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -module Ide.Plugin.Tactic.FeatureSet +module Wingman.FeatureSet ( Feature (..) , FeatureSet , hasFeature diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs similarity index 95% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs rename to plugins/hls-tactics-plugin/src/Wingman/GHC.hs index c4d9de9728..ccb68d1e5f 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs @@ -1,17 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Ide.Plugin.Tactic.GHC where - -import Control.Arrow +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Wingman.GHC where + import Control.Monad.State import Data.Function (on) +import Data.Functor ((<&>)) import Data.List (isPrefixOf) import qualified Data.Map as M import Data.Maybe (isJust) @@ -22,7 +16,6 @@ import DataCon import Development.IDE.GHC.Compat import GHC.SourceGen (case', lambda, match) import Generics.SYB (Data, everything, everywhere, listify, mkQ, mkT) -import Ide.Plugin.Tactic.Types import OccName import TcType import TyCoRep @@ -30,7 +23,7 @@ import Type import TysWiredIn (charTyCon, doubleTyCon, floatTyCon, intTyCon) import Unique import Var -import Data.Functor ((<&>)) +import Wingman.Types tcTyVar_maybe :: Type -> Maybe Var diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs similarity index 97% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements.hs rename to plugins/hls-tactics-plugin/src/Wingman/Judgements.hs index 882cd4b5f8..24f262a019 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Ide.Plugin.Tactic.Judgements where +module Wingman.Judgements where import Control.Arrow import Control.Lens hiding (Context) @@ -16,10 +13,10 @@ import Data.Set (Set) import qualified Data.Set as S import DataCon (DataCon) import Development.IDE.Spans.LocalBindings -import Ide.Plugin.Tactic.Types import OccName import SrcLoc import Type +import Wingman.Types ------------------------------------------------------------------------------ @@ -211,12 +208,13 @@ jAncestryMap jdg = provAncestryOf :: Provenance -> Set OccName -provAncestryOf (TopLevelArgPrv o i i3) = S.singleton o -provAncestryOf (PatternMatchPrv (PatVal mo so ud i)) = maybe mempty S.singleton mo <> so -provAncestryOf (ClassMethodPrv uc) = mempty +provAncestryOf (TopLevelArgPrv o _ _) = S.singleton o +provAncestryOf (PatternMatchPrv (PatVal mo so _ _)) = + maybe mempty S.singleton mo <> so +provAncestryOf (ClassMethodPrv _) = mempty provAncestryOf UserPrv = mempty provAncestryOf RecursivePrv = mempty -provAncestryOf (DisallowedPrv d p2) = provAncestryOf p2 +provAncestryOf (DisallowedPrv _ p2) = provAncestryOf p2 ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements/Theta.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs similarity index 92% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements/Theta.hs rename to plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs index 9559f77756..8504c7babb 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements/Theta.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.Tactic.Judgements.Theta +module Wingman.Judgements.Theta ( getMethodHypothesisAtHole ) where @@ -10,8 +10,8 @@ import qualified Data.Set as S import Development.IDE.GHC.Compat import Generics.SYB import GhcPlugins (EvVar, mkVarOcc) -import Ide.Plugin.Tactic.Machinery -import Ide.Plugin.Tactic.Types +import Wingman.Machinery +import Wingman.Types ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/KnownStrategies.hs b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs similarity index 65% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/KnownStrategies.hs rename to plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs index d159dd03b5..21eb5b3359 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/KnownStrategies.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs @@ -1,15 +1,13 @@ -{-# LANGUAGE LambdaCase #-} - -module Ide.Plugin.Tactic.KnownStrategies where +module Wingman.KnownStrategies where import Control.Monad.Error.Class -import Ide.Plugin.Tactic.Context (getCurrentDefinitions) -import Ide.Plugin.Tactic.KnownStrategies.QuickCheck (deriveArbitrary) -import Ide.Plugin.Tactic.Machinery (tracing) -import Ide.Plugin.Tactic.Tactics -import Ide.Plugin.Tactic.Types import OccName (mkVarOcc) import Refinery.Tactic +import Wingman.Context (getCurrentDefinitions) +import Wingman.KnownStrategies.QuickCheck (deriveArbitrary) +import Wingman.Machinery (tracing) +import Wingman.Tactics +import Wingman.Types knownStrategies :: TacticsM () diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/KnownStrategies/QuickCheck.hs b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies/QuickCheck.hs similarity index 72% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/KnownStrategies/QuickCheck.hs rename to plugins/hls-tactics-plugin/src/Wingman/KnownStrategies/QuickCheck.hs index a61f86dbce..50eb2d791e 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/KnownStrategies/QuickCheck.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies/QuickCheck.hs @@ -1,29 +1,26 @@ -{-# LANGUAGE ViewPatterns #-} +module Wingman.KnownStrategies.QuickCheck where -module Ide.Plugin.Tactic.KnownStrategies.QuickCheck where - -import Control.Monad.Except (MonadError (throwError)) -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 GHC.Exts (IsString (fromString)) -import GHC.List (foldl') -import GHC.SourceGen (int) -import GHC.SourceGen.Binds (match, valBind) -import GHC.SourceGen.Expr (case', lambda, let') -import GHC.SourceGen.Overloaded (App ((@@)), HasList (list)) -import GHC.SourceGen.Pat (conP) -import Ide.Plugin.Tactic.CodeGen -import Ide.Plugin.Tactic.Judgements (jGoal) -import Ide.Plugin.Tactic.Machinery (tracePrim) -import Ide.Plugin.Tactic.Types -import OccName (HasOccName (occName), mkVarOcc, - occNameString) -import Refinery.Tactic (goal, rule) -import TyCon (TyCon, tyConDataCons, tyConName) -import Type (splitTyConApp_maybe) +import Control.Monad.Except (MonadError (throwError)) +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 GHC.Exts (IsString (fromString)) +import GHC.List (foldl') +import GHC.SourceGen (int) +import GHC.SourceGen.Binds (match, valBind) +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) +import TyCon (TyCon, tyConDataCons, tyConName) +import Type (splitTyConApp_maybe) +import Wingman.CodeGen +import Wingman.Judgements (jGoal) +import Wingman.Machinery (tracePrim) +import Wingman.Types ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs similarity index 94% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs rename to plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 172e847b38..15589e36e2 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -1,13 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} -module Ide.Plugin.Tactic.LanguageServer where +module Wingman.LanguageServer where import ConLike import Control.Arrow @@ -40,19 +34,19 @@ import qualified FastString import GhcPlugins (mkAppTys, tupleDataCon, consDataCon) import Ide.Plugin.Config (PluginConfig (plcConfig)) import qualified Ide.Plugin.Config as Plugin -import Ide.Plugin.Tactic.Context -import Ide.Plugin.Tactic.FeatureSet -import Ide.Plugin.Tactic.GHC -import Ide.Plugin.Tactic.Judgements -import Ide.Plugin.Tactic.Judgements.Theta (getMethodHypothesisAtHole) -import Ide.Plugin.Tactic.Range -import Ide.Plugin.Tactic.Types import Language.LSP.Server (MonadLsp, sendNotification) import Language.LSP.Types import OccName import Prelude hiding (span) import SrcLoc (containsSpan) import TcRnTypes (tcg_binds) +import Wingman.Context +import Wingman.FeatureSet +import Wingman.GHC +import Wingman.Judgements +import Wingman.Judgements.Theta (getMethodHypothesisAtHole) +import Wingman.Range +import Wingman.Types tacticDesc :: T.Text -> T.Text diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs similarity index 95% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer/TacticProviders.hs rename to plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs index 345d14c891..825285ce8c 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer/TacticProviders.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs @@ -1,11 +1,6 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wall #-} - -module Ide.Plugin.Tactic.LanguageServer.TacticProviders +{-# LANGUAGE OverloadedStrings #-} + +module Wingman.LanguageServer.TacticProviders ( commandProvider , commandTactic , tcCommandId @@ -26,12 +21,12 @@ import DataCon (dataConName) import Development.IDE.GHC.Compat import GHC.Generics import GHC.LanguageExtensions.Type (Extension (LambdaCase)) -import Ide.Plugin.Tactic.Auto -import Ide.Plugin.Tactic.FeatureSet -import Ide.Plugin.Tactic.GHC -import Ide.Plugin.Tactic.Judgements -import Ide.Plugin.Tactic.Tactics -import Ide.Plugin.Tactic.Types +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 diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Machinery.hs b/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs similarity index 94% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Machinery.hs rename to plugins/hls-tactics-plugin/src/Wingman/Machinery.hs index 30fc29cf42..c737ff17a2 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Machinery.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs @@ -1,15 +1,6 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.Tactic.Machinery where +module Wingman.Machinery where import Class (Class (classTyVars)) import Control.Lens ((<>~)) @@ -31,9 +22,6 @@ import Data.Ord (Down (..), comparing) import Data.Set (Set) import qualified Data.Set as S import Development.IDE.GHC.Compat -import Ide.Plugin.Tactic.Judgements -import Ide.Plugin.Tactic.Simplify (simplify) -import Ide.Plugin.Tactic.Types import OccName (HasOccName (occName)) import Refinery.ProofState import Refinery.Tactic @@ -41,6 +29,9 @@ import Refinery.Tactic.Internal import TcType import Type import Unify +import Wingman.Judgements +import Wingman.Simplify (simplify) +import Wingman.Types substCTy :: TCvSubst -> CType -> CType diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Naming.hs b/plugins/hls-tactics-plugin/src/Wingman/Naming.hs similarity index 86% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Naming.hs rename to plugins/hls-tactics-plugin/src/Wingman/Naming.hs index 03c91972a4..810cb5311f 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Naming.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Naming.hs @@ -1,21 +1,18 @@ -{-# LANGUAGE ViewPatterns #-} - -module Ide.Plugin.Tactic.Naming where +module Wingman.Naming where import Control.Monad.State.Strict -import Data.Bool (bool) +import Data.Bool (bool) import Data.Char -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S import Data.Traversable import Name import TcType import TyCon import Type -import TysWiredIn (listTyCon, pairTyCon, unitTyCon) -import Ide.Plugin.Tactic.Types +import TysWiredIn (listTyCon, pairTyCon, unitTyCon) ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs new file mode 100644 index 0000000000..d2c2df7e2b --- /dev/null +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | A plugin that uses tactics to synthesize code +module Wingman.Plugin + ( descriptor + , tacticTitle + , TacticCommand (..) + ) where + +import Bag (bagToList, listToBag) +import Control.Exception (evaluate) +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Bifunctor (first) +import Data.Data (Data) +import Data.Foldable (for_) +import Data.Generics.Aliases (mkQ) +import Data.Generics.Schemes (everything) +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import Data.Traversable +import Development.IDE.Core.Shake (IdeState (..)) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.ExactPrint +import Ide.Types +import Language.LSP.Server +import Language.LSP.Types +import Language.LSP.Types.Capabilities +import OccName +import Prelude hiding (span) +import System.Timeout +import Wingman.CaseSplit +import Wingman.GHC +import Wingman.LanguageServer +import Wingman.LanguageServer.TacticProviders +import Wingman.Range +import Wingman.Tactics +import Wingman.Types + + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginCommands + = fmap (\tc -> + PluginCommand + (tcCommandId tc) + (tacticDesc $ tcCommandName tc) + (tacticCmd $ commandTactic tc)) + [minBound .. maxBound] + , pluginHandlers = + mkPluginHandler STextDocumentCodeAction codeActionProvider + } + + + +codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range _ctx) + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do + cfg <- getTacticConfig $ shakeExtras state + liftIO $ fromMaybeT (Right $ List []) $ do + (_, jdg, _, dflags) <- judgementForHole state nfp range $ cfg_feature_set cfg + actions <- lift $ + -- This foldMap is over the function monoid. + foldMap commandProvider [minBound .. maxBound] + dflags + cfg + plId + uri + range + jdg + pure $ Right $ List actions +codeActionProvider _ _ _ = pure $ Right $ List [] + + +showUserFacingMessage + :: MonadLsp cfg m + => UserFacingMessage + -> m (Either ResponseError a) +showUserFacingMessage ufm = do + showLspMessage $ mkShowMessageParams ufm + pure $ Left $ mkErr InternalError $ T.pack $ show ufm + + +tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams +tacticCmd tac state (TacticParams uri range var_name) + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do + features <- getFeatureSet $ shakeExtras state + 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 + + timingOut 2e8 $ join $ + case runTactic ctx jdg $ tac $ mkVarOcc $ T.unpack var_name of + Left _ -> Left TacticErrors + Right rtr -> + case rtr_extract rtr of + L _ (HsVar _ (L _ rdr)) | isHole (occName rdr) -> + Left NothingToDo + _ -> pure $ mkWorkspaceEdits span dflags ccs uri pm rtr + + case res of + Nothing -> do + showUserFacingMessage TimedOut + Just (Left ufm) -> do + showUserFacingMessage ufm + Just (Right edit) -> do + _ <- sendRequest + SWorkspaceApplyEdit + (ApplyWorkspaceEditParams Nothing edit) + (const $ pure ()) + pure $ Right Null +tacticCmd _ _ _ = + pure $ Left $ mkErr InvalidRequest "Bad URI" + + +timingOut + :: Int -- ^ Time in microseconds + -> a -- ^ Computation to run + -> MaybeT IO a +timingOut t m = MaybeT $ timeout t $ evaluate m + + +mkErr :: ErrorCode -> T.Text -> ResponseError +mkErr code err = ResponseError code err Nothing + + +------------------------------------------------------------------------------ +-- | Turn a 'RunTacticResults' into concrete edits to make in the source +-- document. +mkWorkspaceEdits + :: RealSrcSpan + -> DynFlags + -> ClientCapabilities + -> Uri + -> Annotated ParsedSource + -> RunTacticResults + -> Either UserFacingMessage WorkspaceEdit +mkWorkspaceEdits span dflags ccs uri pm rtr = do + for_ (rtr_other_solns rtr) $ traceMX "other solution" + traceMX "solution" $ rtr_extract rtr + let g = graftHole (RealSrcSpan span) rtr + response = transform dflags ccs uri g pm + in first (InfrastructureError . T.pack) response + + +------------------------------------------------------------------------------ +-- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly +-- deals with top-level holes, in which we might need to fiddle with the +-- 'Match's that bind variables. +graftHole + :: SrcSpan + -> RunTacticResults + -> Graft (Either String) ParsedSource +graftHole span rtr + | _jIsTopHole (rtr_jdg rtr) + = graftSmallestDeclsWithM span + $ graftDecl span $ \pats -> + splitToDecl (fst $ last $ ctxDefiningFuncs $ rtr_ctx rtr) + $ iterateSplit + $ mkFirstAgda (fmap unXPat pats) + $ unLoc + $ rtr_extract rtr +graftHole span rtr + = graft span + $ rtr_extract rtr + + +------------------------------------------------------------------------------ +-- | Merge in the 'Match'es of a 'FunBind' into a 'HsDecl'. Used to perform +-- agda-style case splitting in which we need to separate one 'Match' into +-- many, without affecting any matches which might exist but don't need to be +-- split. +mergeFunBindMatches + :: ([Pat GhcPs] -> LHsDecl GhcPs) + -> SrcSpan + -> HsBind GhcPs + -> Either String (HsBind GhcPs) +mergeFunBindMatches make_decl span + (fb@FunBind {fun_matches = mg@MG {mg_alts = L alts_src alts}}) = + pure $ fb + { fun_matches = mg + { mg_alts = L alts_src $ do + alt@(L alt_src match) <- alts + case span `isSubspanOf` alt_src of + True -> do + let pats = fmap fromPatCompatPs $ m_pats match + L _ (ValD _ (FunBind {fun_matches = MG + {mg_alts = L _ to_add}})) = make_decl pats + to_add + False -> pure alt + } + } +mergeFunBindMatches _ _ _ = + Left "mergeFunBindMatches: called on something that isnt a funbind" + + +throwError :: String -> TransformT (Either String) a +throwError = lift . Left + + +------------------------------------------------------------------------------ +-- | Helper function to route 'mergeFunBindMatches' into the right place in an +-- AST --- correctly dealing with inserting into instance declarations. +graftDecl + :: SrcSpan + -> ([Pat GhcPs] -> LHsDecl GhcPs) + -> LHsDecl GhcPs + -> TransformT (Either String) (Maybe [LHsDecl GhcPs]) +graftDecl span + make_decl + (L src (ValD ext fb)) + = either throwError (pure . Just . pure . L src . ValD ext) $ + mergeFunBindMatches make_decl span fb +-- TODO(sandy): add another case for default methods in class definitions +graftDecl span + make_decl + (L src (InstD ext + cid@ClsInstD{cid_inst = + cidi@ClsInstDecl{cid_sigs = _sigs, cid_binds = binds}})) + = do + binds' <- + for (bagToList binds) $ \b@(L bsrc bind) -> do + case bind of + fb@FunBind{} | span `isSubspanOf` bsrc -> + either throwError (pure . L bsrc) $ + mergeFunBindMatches make_decl span fb + _ -> pure b + + pure $ Just $ pure $ L src $ InstD ext $ cid + { cid_inst = cidi + { cid_binds = listToBag binds' + } + } +graftDecl span _ x = do + traceMX "biggest" $ + unsafeRender $ + locateBiggest @(Match GhcPs (LHsExpr GhcPs)) span x + traceMX "first" $ + unsafeRender $ + locateFirst @(Match GhcPs (LHsExpr GhcPs)) x + throwError "graftDecl: don't know about this AST form" + + +fromMaybeT :: Functor m => a -> MaybeT m a -> m a +fromMaybeT def = fmap (fromMaybe def) . runMaybeT + + +locateBiggest :: (Data r, Data a) => SrcSpan -> a -> Maybe r +locateBiggest ss x = getFirst $ everything (<>) + ( mkQ mempty $ \case + L span r | ss `isSubspanOf` span -> pure r + _ -> mempty + ) x + + +locateFirst :: (Data r, Data a) => a -> Maybe r +locateFirst x = getFirst $ everything (<>) + ( mkQ mempty $ \case + r -> pure r + ) x + + diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Range.hs b/plugins/hls-tactics-plugin/src/Wingman/Range.hs similarity index 87% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Range.hs rename to plugins/hls-tactics-plugin/src/Wingman/Range.hs index 3c8de54ee4..470e207742 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Range.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Range.hs @@ -1,7 +1,7 @@ -module Ide.Plugin.Tactic.Range where +module Wingman.Range where import Development.IDE.Types.Location -import qualified FastString as FS +import qualified FastString as FS import SrcLoc ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs b/plugins/hls-tactics-plugin/src/Wingman/Simplify.hs similarity index 80% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs rename to plugins/hls-tactics-plugin/src/Wingman/Simplify.hs index b89f290756..c21986cf51 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Simplify.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Simplify.hs @@ -1,22 +1,17 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} -module Ide.Plugin.Tactic.Simplify +module Wingman.Simplify ( simplify ) where -import Data.Generics (GenericT, everywhere, mkT) -import Data.List.Extra (unsnoc) -import Data.Monoid (Endo (..)) -import Development.IDE.GHC.Compat -import GHC.SourceGen (var) -import GHC.SourceGen.Expr (lambda) -import Ide.Plugin.Tactic.CodeGen.Utils -import Ide.Plugin.Tactic.GHC (containsHsVar, - fromPatCompatPs) +import Data.Generics (GenericT, everywhere, mkT) +import Data.List.Extra (unsnoc) +import Data.Monoid (Endo (..)) +import Development.IDE.GHC.Compat +import GHC.SourceGen (var) +import GHC.SourceGen.Expr (lambda) +import Wingman.CodeGen.Utils +import Wingman.GHC (containsHsVar, fromPatCompatPs) ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Tactics.hs b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs similarity index 94% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Tactics.hs rename to plugins/hls-tactics-plugin/src/Wingman/Tactics.hs index 9179f5d677..7b1b88f571 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Tactics.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs @@ -1,13 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - -{-# LANGUAGE TypeApplications #-} -module Ide.Plugin.Tactic.Tactics - ( module Ide.Plugin.Tactic.Tactics +module Wingman.Tactics + ( module Wingman.Tactics , runTactic ) where @@ -29,18 +21,18 @@ import Development.IDE.GHC.Compat import GHC.Exts import GHC.SourceGen.Expr import GHC.SourceGen.Overloaded -import Ide.Plugin.Tactic.CodeGen -import Ide.Plugin.Tactic.Context -import Ide.Plugin.Tactic.GHC -import Ide.Plugin.Tactic.Judgements -import Ide.Plugin.Tactic.Machinery -import Ide.Plugin.Tactic.Naming -import Ide.Plugin.Tactic.Types import Name (occNameString, occName) import Refinery.Tactic import Refinery.Tactic.Internal import TcType import Type hiding (Var) +import Wingman.CodeGen +import Wingman.Context +import Wingman.GHC +import Wingman.Judgements +import Wingman.Machinery +import Wingman.Naming +import Wingman.Types ------------------------------------------------------------------------------ @@ -248,7 +240,7 @@ splitDataCon dc = requireConcreteHole $ tracing ("splitDataCon:" <> show dc) $ rule $ \jdg -> do let g = jGoal jdg case splitTyConApp_maybe $ unCType g of - Just (tc, apps) -> do + Just (_, apps) -> do buildDataCon (unwhitelistingSplit jdg) dc apps Nothing -> throwError $ GoalMismatch "splitDataCon" g @@ -281,11 +273,12 @@ userSplit occ = do -- code action, send it as a string, and then look it up again. Can we push -- this over LSP somehow instead? case splitTyConApp_maybe $ unCType g of - Just (tc, apps) -> do + Just (tc, _) -> do case find (sloppyEqOccName occ . occName . dataConName) $ tyConDataCons tc of Just dc -> splitDataCon dc Nothing -> throwError $ NotInScope occ + Nothing -> throwError $ NotInScope occ ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs similarity index 94% rename from plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs rename to plugins/hls-tactics-plugin/src/Wingman/Types.hs index 312b765828..bc6e0a8290 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs @@ -1,21 +1,11 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Ide.Plugin.Tactic.Types - ( module Ide.Plugin.Tactic.Types - , module Ide.Plugin.Tactic.Debug +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Wingman.Types + ( module Wingman.Types + , module Wingman.Debug , OccName , Name , Type @@ -35,22 +25,22 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromMaybe) import Data.Semigroup import Data.Set (Set) -import qualified Data.Text as T import Data.Text (Text) +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 Ide.Plugin.Tactic.Debug -import Ide.Plugin.Tactic.FeatureSet import OccName import Refinery.Tactic import System.IO.Unsafe (unsafePerformIO) import Type (TCvSubst, Var, eqType, nonDetCmpType, emptyTCvSubst) import UniqSupply (takeUniqFromSupply, mkSplitUniqSupply, UniqSupply) import Unique (nonDetCmpUnique, Uniquable, getUnique, Unique) +import Wingman.Debug +import Wingman.FeatureSet ------------------------------------------------------------------------------ @@ -297,7 +287,7 @@ type Judgement = Judgement' CType newtype ExtractM a = ExtractM { unExtractM :: Reader Context a } - deriving (Functor, Applicative, Monad, MonadReader Context) + deriving newtype (Functor, Applicative, Monad, MonadReader Context) ------------------------------------------------------------------------------ -- | Orphan instance for producing holes when attempting to solve tactics. @@ -445,7 +435,7 @@ rose a rs = Rose $ Node a $ coerce rs ------------------------------------------------------------------------------ --- | The results of 'Ide.Plugin.Tactic.Machinery.runTactic' +-- | The results of 'Wingman.Machinery.runTactic' data RunTacticResults = RunTacticResults { rtr_trace :: Trace , rtr_extract :: LHsExpr GhcPs diff --git a/plugins/hls-tactics-plugin/test/AutoTupleSpec.hs b/plugins/hls-tactics-plugin/test/AutoTupleSpec.hs index 2681c0acc0..4d721b4475 100644 --- a/plugins/hls-tactics-plugin/test/AutoTupleSpec.hs +++ b/plugins/hls-tactics-plugin/test/AutoTupleSpec.hs @@ -3,10 +3,10 @@ module AutoTupleSpec where import Data.Either (isRight) -import Ide.Plugin.Tactic.Judgements (mkFirstJudgement) -import Ide.Plugin.Tactic.Machinery -import Ide.Plugin.Tactic.Tactics (auto') -import Ide.Plugin.Tactic.Types +import Wingman.Judgements (mkFirstJudgement) +import Wingman.Machinery +import Wingman.Tactics (auto') +import Wingman.Types import OccName (mkVarOcc) import Test.Hspec import Test.QuickCheck diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs index 995b9dc29d..b7939f664b 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs @@ -7,10 +7,10 @@ module CodeAction.AutoSpec where -import Ide.Plugin.Tactic.Types +import Wingman.Types import Test.Hspec import Utils -import Ide.Plugin.Tactic.FeatureSet (allFeatures) +import Wingman.FeatureSet (allFeatures) spec :: Spec diff --git a/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs index 77db7fa335..5e5a11fe0f 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs @@ -7,7 +7,7 @@ module CodeAction.DestructAllSpec where -import Ide.Plugin.Tactic.Types +import Wingman.Types import Test.Hspec import Utils diff --git a/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs index f330f1288a..2757f3b56a 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs @@ -7,7 +7,7 @@ module CodeAction.DestructSpec where -import Ide.Plugin.Tactic.Types +import Wingman.Types import Test.Hspec import Utils diff --git a/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs index d209df207c..821e48a61b 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs @@ -7,7 +7,7 @@ module CodeAction.IntrosSpec where -import Ide.Plugin.Tactic.Types +import Wingman.Types import Test.Hspec import Utils diff --git a/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs index 813f6d60e6..12f1f9ce8a 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs @@ -7,10 +7,10 @@ module CodeAction.RefineSpec where -import Ide.Plugin.Tactic.Types +import Wingman.Types import Test.Hspec import Utils -import Ide.Plugin.Tactic.FeatureSet (allFeatures) +import Wingman.FeatureSet (allFeatures) spec :: Spec diff --git a/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs index d3f9b110b7..676111bc6f 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs @@ -8,7 +8,7 @@ module CodeAction.UseDataConSpec where import qualified Data.Text as T -import Ide.Plugin.Tactic.Types +import Wingman.Types import Test.Hspec import Utils diff --git a/plugins/hls-tactics-plugin/test/ProviderSpec.hs b/plugins/hls-tactics-plugin/test/ProviderSpec.hs index 3db52ebd6f..0121c3078e 100644 --- a/plugins/hls-tactics-plugin/test/ProviderSpec.hs +++ b/plugins/hls-tactics-plugin/test/ProviderSpec.hs @@ -7,7 +7,7 @@ module ProviderSpec where -import Ide.Plugin.Tactic.Types +import Wingman.Types import Test.Hspec import Utils diff --git a/plugins/hls-tactics-plugin/test/UnificationSpec.hs b/plugins/hls-tactics-plugin/test/UnificationSpec.hs index 013193fec8..7d8d2abd26 100644 --- a/plugins/hls-tactics-plugin/test/UnificationSpec.hs +++ b/plugins/hls-tactics-plugin/test/UnificationSpec.hs @@ -10,14 +10,14 @@ import Data.Maybe (mapMaybe) import qualified Data.Set as S import Data.Traversable import Data.Tuple (swap) -import Ide.Plugin.Tactic.Machinery -import Ide.Plugin.Tactic.Types import TcType (substTy, tcGetTyVar_maybe) import Test.Hspec import Test.QuickCheck import Type (mkTyVarTy) import TysPrim (alphaTyVars) import TysWiredIn (mkBoxedTupleTy) +import Wingman.Machinery +import Wingman.Types spec :: Spec diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index d0d4a15335..6ede016ae7 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -19,9 +19,9 @@ import Data.Maybe import Data.Text (Text) import qualified Data.Text.IO as T import qualified Ide.Plugin.Config as Plugin -import Ide.Plugin.Tactic.FeatureSet (FeatureSet, allFeatures) -import Ide.Plugin.Tactic.LanguageServer (mkShowMessageParams) -import Ide.Plugin.Tactic.Types +import Wingman.FeatureSet (FeatureSet, allFeatures) +import Wingman.LanguageServer (mkShowMessageParams) +import Wingman.Types import Language.LSP.Test import Language.LSP.Types import Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title)