Skip to content

Commit 3383f64

Browse files
isovectorisovector
committed
Move the staticplugin out of ghcide
1 parent 7961245 commit 3383f64

File tree

6 files changed

+77
-55
lines changed

6 files changed

+77
-55
lines changed

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

Lines changed: 0 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -773,17 +773,13 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
773773
setLinkerOptions $
774774
disableOptimisation $
775775
setUpTypedHoles $
776-
enableQuasiQuotes $
777776
makeDynFlagsAbsolute compRoot dflags'
778777
-- initPackages parses the -package flags and
779778
-- sets up the visibility for each component.
780779
-- Throws if a -package flag cannot be satisfied.
781780
(final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags''
782781
return (final_df, targets)
783782

784-
enableQuasiQuotes :: DynFlags -> DynFlags
785-
enableQuasiQuotes = flip xopt_set QuasiQuotes
786-
787783
-- we don't want to generate object code so we compile to bytecode
788784
-- (HscInterpreted) which implies LinkInMemory
789785
-- HscInterpreted

‎ghcide/src/Development/IDE/Core/Compile.hs‎

Lines changed: 0 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,6 @@ module Development.IDE.Core.Compile
3232
, setupFinderCache
3333
, getDocsBatch
3434
, lookupName
35-
, pattern WingmanMetaprogram
3635
) where
3736

3837
import Development.IDE.Core.Preprocessor
@@ -124,7 +123,6 @@ import Data.Unique
124123
import GHC.Fingerprint
125124
import qualified Language.LSP.Server as LSP
126125
import qualified Language.LSP.Types as LSP
127-
import Generics.SYB hiding (orElse)
128126

129127
-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
130128
parseModule
@@ -212,37 +210,6 @@ captureSplices dflags k = do
212210
liftIO $ modifyIORef' var $ awSplicesL %~ ((e, aw') :)
213211
pure $ f aw'
214212

215-
216-
wingmanMetaprogrammingPlugin :: StaticPlugin
217-
wingmanMetaprogrammingPlugin =
218-
StaticPlugin $ PluginWithArgs (defaultPlugin { parsedResultAction = worker }) []
219-
where
220-
worker :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
221-
worker _ _ pm = pure $ pm { hpm_module = addWingmanMetaprogrammingSyntax $ hpm_module pm }
222-
223-
224-
pattern WingmanMetaprogram :: FastString -> HsExpr p
225-
pattern WingmanMetaprogram mp
226-
<- HsSCC _ (SourceText "wingman-meta-program") (StringLiteral NoSourceText mp)
227-
(L _ ( HsVar _ _))
228-
229-
mkWingmanMetaprogram :: SrcSpan -> FastString -> HsExpr GhcPs
230-
mkWingmanMetaprogram ss mp =
231-
HsSCC noExt (SourceText "wingman-meta-program") (StringLiteral NoSourceText mp)
232-
$ L ss
233-
$ HsVar noExt
234-
$ L ss
235-
$ mkRdrUnqual
236-
$ mkVarOcc "_"
237-
238-
239-
addWingmanMetaprogrammingSyntax :: Data a => a -> a
240-
addWingmanMetaprogrammingSyntax =
241-
everywhere $ mkT $ \case
242-
L ss (HsSpliceE _ (HsQuasiQuote _ _ (occNameString . rdrNameOcc -> "wingman") _ mp)) ->
243-
L ss $ mkWingmanMetaprogram ss mp
244-
(x :: LHsExpr GhcPs) -> x
245-
246213
tcRnModule :: HscEnv -> (DynFlags -> DynFlags) -> [Linkable] -> ParsedModule -> IO TcModuleResult
247214
tcRnModule hsc_env modify_dflags keep_lbls pmod = do
248215
let ms = pm_mod_summary pmod

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,7 @@ library
4949
Wingman.Metaprogramming.Parser
5050
Wingman.Naming
5151
Wingman.Plugin
52+
Wingman.StaticPlugin
5253
Wingman.Range
5354
Wingman.Simplify
5455
Wingman.Tactics

‎plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs‎

Lines changed: 6 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -14,9 +14,8 @@ import Control.Monad.State (State, get, put, evalState)
1414
import Control.Monad.Trans.Maybe
1515
import Data.Bifunctor (first)
1616
import Data.Coerce
17+
import Data.Foldable (for_)
1718
import Data.Functor ((<&>))
18-
import Data.Generics.Aliases (mkQ)
19-
import Data.Generics.Schemes (everything)
2019
import qualified Data.HashMap.Strict as Map
2120
import Data.IORef (readIORef)
2221
import qualified Data.Map as M
@@ -37,11 +36,12 @@ import Development.IDE.Core.UseStale
3736
import Development.IDE.GHC.Compat
3837
import Development.IDE.GHC.Error (realSrcSpanToRange)
3938
import Development.IDE.GHC.ExactPrint
40-
import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings)
4139
import Development.IDE.Graph (Action, RuleResult, Rules, action)
42-
import Development.IDE.Graph.Classes (Typeable, Binary, Hashable, NFData)
40+
import Development.IDE.Graph.Classes (Binary, Hashable, NFData)
41+
import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings)
4342
import qualified FastString
4443
import GHC.Generics (Generic)
44+
import Generics.SYB hiding (Generic)
4545
import GhcPlugins (tupleDataCon, consDataCon, substTyAddInScope, ExternalPackageState, HscEnv (hsc_EPS), liftIO, unpackFS)
4646
import qualified Ide.Plugin.Config as Plugin
4747
import Ide.Plugin.Properties
@@ -60,12 +60,10 @@ import Wingman.GHC
6060
import Wingman.Judgements
6161
import Wingman.Judgements.SYB (everythingContaining)
6262
import Wingman.Judgements.Theta
63+
import Wingman.Metaprogramming.Parser (attempt_it)
6364
import Wingman.Range
65+
import Wingman.StaticPlugin (pattern WingmanMetaprogram)
6466
import Wingman.Types
65-
import Generics.SYB hiding (Generic)
66-
import Development.IDE.Core.Compile (pattern WingmanMetaprogram)
67-
import Data.Foldable (for_)
68-
import Wingman.Metaprogramming.Parser (attempt_it)
6967

7068

7169
tacticDesc :: T.Text -> T.Text

‎plugins/hls-tactics-plugin/src/Wingman/Plugin.hs‎

Lines changed: 2 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,6 @@ import Development.IDE.Core.Shake (IdeState (..))
2020
import Development.IDE.Core.UseStale (Tracked, TrackedStale(..), unTrack, mapAgeFrom, unsafeMkCurrent)
2121
import Development.IDE.GHC.Compat
2222
import Development.IDE.GHC.ExactPrint
23-
import GHC.LanguageExtensions.Type (Extension(EmptyCase))
2423
import Generics.SYB.GHC
2524
import Ide.Types
2625
import Language.LSP.Server
@@ -36,6 +35,7 @@ import Wingman.LanguageServer
3635
import Wingman.LanguageServer.TacticProviders
3736
import Wingman.Machinery (scoreSolution)
3837
import Wingman.Range
38+
import Wingman.StaticPlugin
3939
import Wingman.Tactics
4040
import Wingman.Types
4141

@@ -63,18 +63,10 @@ descriptor plId = (defaultPluginDescriptor plId)
6363
, pluginRules = wingmanRules plId
6464
, pluginConfigDescriptor =
6565
defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}
66-
, pluginModifyDynflags = allowEmptyCaseButWithWarning
66+
, pluginModifyDynflags = staticPlugin
6767
}
6868

6969

70-
-- | Wingman wants to support destructing of empty cases, but these are a parse
71-
-- error by default. So we want to enable 'EmptyCase', but then that leads to
72-
-- silent errors without 'Opt_WarnIncompletePatterns'.
73-
allowEmptyCaseButWithWarning :: DynFlags -> DynFlags
74-
allowEmptyCaseButWithWarning =
75-
flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns
76-
77-
7870
codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
7971
codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) (unsafeMkCurrent -> range) _ctx)
8072
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do

‎plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs‎

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
module Wingman.StaticPlugin
2+
( staticPlugin
3+
, pattern WingmanMetaprogram
4+
) where
5+
6+
import Data.Data
7+
import Development.IDE.GHC.Compat
8+
import GHC.LanguageExtensions.Type (Extension(EmptyCase, QuasiQuotes))
9+
import Generics.SYB
10+
import GhcPlugins hiding ((<>))
11+
12+
13+
staticPlugin :: DynFlags -> DynFlags
14+
staticPlugin df
15+
= allowEmptyCaseButWithWarning
16+
$ enableQuasiQuotes
17+
$ df
18+
{ staticPlugins = staticPlugins df <> [metaprogrammingPlugin] }
19+
20+
21+
pattern MetaprogramSourceText :: SourceText
22+
pattern MetaprogramSourceText = SourceText "wingman-meta-program"
23+
24+
25+
26+
pattern WingmanMetaprogram :: FastString -> HsExpr p
27+
pattern WingmanMetaprogram mp
28+
<- HsSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp)
29+
(L _ ( HsVar _ _))
30+
31+
32+
enableQuasiQuotes :: DynFlags -> DynFlags
33+
enableQuasiQuotes = flip xopt_set QuasiQuotes
34+
35+
36+
-- | Wingman wants to support destructing of empty cases, but these are a parse
37+
-- error by default. So we want to enable 'EmptyCase', but then that leads to
38+
-- silent errors without 'Opt_WarnIncompletePatterns'.
39+
allowEmptyCaseButWithWarning :: DynFlags -> DynFlags
40+
allowEmptyCaseButWithWarning =
41+
flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns
42+
43+
44+
metaprogrammingPlugin :: StaticPlugin
45+
metaprogrammingPlugin =
46+
StaticPlugin $ PluginWithArgs (defaultPlugin { parsedResultAction = worker }) []
47+
where
48+
worker :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
49+
worker _ _ pm = pure $ pm { hpm_module = addMetaprogrammingSyntax $ hpm_module pm }
50+
51+
52+
mkMetaprogram :: SrcSpan -> FastString -> HsExpr GhcPs
53+
mkMetaprogram ss mp =
54+
HsSCC noExt MetaprogramSourceText (StringLiteral NoSourceText mp)
55+
$ L ss
56+
$ HsVar noExt
57+
$ L ss
58+
$ mkRdrUnqual
59+
$ mkVarOcc "_"
60+
61+
62+
addMetaprogrammingSyntax :: Data a => a -> a
63+
addMetaprogrammingSyntax =
64+
everywhere $ mkT $ \case
65+
L ss (HsSpliceE _ (HsQuasiQuote _ _ (occNameString . rdrNameOcc -> "wingman") _ mp)) ->
66+
L ss $ mkMetaprogram ss mp
67+
(x :: LHsExpr GhcPs) -> x
68+

0 commit comments

Comments
 (0)