Skip to content

Commit 709639b

Browse files
isovectorisovector
authored
Tease apart the custom SYB from ExactPrint (#1746)
1 parent 3152c35 commit 709639b

File tree

4 files changed

+129
-107
lines changed

4 files changed

+129
-107
lines changed

‎ghcide/ghcide.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -140,6 +140,7 @@ library
140140
include
141141
exposed-modules:
142142
Control.Concurrent.Strict
143+
Generics.SYB.GHC
143144
Development.IDE
144145
Development.IDE.Main
145146
Development.IDE.Core.Actions

‎ghcide/src/Development/IDE/GHC/ExactPrint.hs

Lines changed: 2 additions & 107 deletions
Original file line numberDiff line numberDiff line change
@@ -28,9 +28,7 @@ module Development.IDE.GHC.ExactPrint
2828
TransformT,
2929
Anns,
3030
Annotate,
31-
mkBindListT,
3231
setPrecedingLinesT,
33-
everywhereM',
3432
)
3533
where
3634

@@ -56,6 +54,7 @@ import Development.Shake (RuleResult, Rules)
5654
import Development.Shake.Classes
5755
import qualified GHC.Generics as GHC
5856
import Generics.SYB
57+
import Generics.SYB.GHC
5958
import Ide.PluginUtils
6059
import Language.Haskell.GHC.ExactPrint
6160
import Language.Haskell.GHC.ExactPrint.Parsers
@@ -67,8 +66,7 @@ import Parser (parseIdentifier)
6766
import Data.Traversable (for)
6867
import Data.Foldable (Foldable(fold))
6968
import Data.Bool (bool)
70-
import Data.Monoid (All(All), Any(Any), getAll)
71-
import Data.Functor.Compose (Compose(Compose))
69+
import Data.Monoid (All(All), getAll)
7270
import Control.Arrow
7371

7472

@@ -328,21 +326,6 @@ graftWithM dst trans = Graft $ \dflags a -> do
328326
)
329327
a
330328

331-
-- | A generic query intended to be used for calling 'smallestM' and
332-
-- 'largestM'. If the current node is a 'Located', returns whether or not the
333-
-- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which
334-
-- indicates uncertainty. The search strategy in 'smallestM' et al. will
335-
-- continue searching uncertain nodes.
336-
genericIsSubspan ::
337-
forall ast.
338-
Typeable ast =>
339-
-- | The type of nodes we'd like to consider.
340-
Proxy (Located ast) ->
341-
SrcSpan ->
342-
GenericQ (Maybe Bool)
343-
genericIsSubspan _ dst = mkQ Nothing $ \case
344-
(L span _ :: Located ast) -> Just $ dst `isSubspanOf` span
345-
346329
-- | Run the given transformation only on the smallest node in the tree that
347330
-- contains the 'SrcSpan'.
348331
genericGraftWithSmallestM ::
@@ -370,15 +353,6 @@ genericGraftWithLargestM proxy dst trans = Graft $ \dflags ->
370353
largestM (genericIsSubspan proxy dst) (trans dflags)
371354

372355

373-
-- | Lift a function that replaces a value with several values into a generic
374-
-- function. The result doesn't perform any searching, so should be driven via
375-
-- 'everywhereM' or friends.
376-
--
377-
-- The 'Int' argument is the index in the list being bound.
378-
mkBindListT :: forall b m. (Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m
379-
mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..]
380-
381-
382356
graftDecls ::
383357
forall a.
384358
(HasDecls a) =>
@@ -432,12 +406,6 @@ graftDeclsWithM dst toDecls = Graft $ \dflags a -> do
432406
modifyDeclsT (fmap DL.toList . go) a
433407

434408

435-
everywhereM' :: forall m. Monad m => GenericM m -> GenericM m
436-
everywhereM' f = go
437-
where
438-
go :: GenericM m
439-
go = gmapM go <=< f
440-
441409
class (Data ast, Outputable ast) => ASTElement ast where
442410
parseAST :: Parser (Located ast)
443411
maybeParensAST :: Located ast -> Located ast
@@ -547,76 +515,3 @@ render dflags = showSDoc dflags . ppr
547515
parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs
548516
parenthesize = parenthesizeHsExpr appPrec
549517

550-
551-
------------------------------------------------------------------------------
552-
-- Custom SYB machinery
553-
------------------------------------------------------------------------------
554-
555-
-- | Generic monadic transformations that return side-channel data.
556-
type GenericMQ r m = forall a. Data a => a -> m (r, a)
557-
558-
------------------------------------------------------------------------------
559-
-- | Apply the given 'GenericM' at all every node whose children fail the
560-
-- 'GenericQ', but which passes the query itself.
561-
--
562-
-- The query must be a monotonic function when it returns 'Just'. That is, if
563-
-- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It
564-
-- is the True-to-false edge of the query that triggers the transformation.
565-
--
566-
-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes
567-
-- with data nodes, so for any given node we can only definitely return an
568-
-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is
569-
-- used.
570-
smallestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m
571-
smallestM q f = fmap snd . go
572-
where
573-
go :: GenericMQ Any m
574-
go x = do
575-
case q x of
576-
Nothing -> gmapMQ go x
577-
Just True -> do
578-
it@(r, x') <- gmapMQ go x
579-
case r of
580-
Any True -> pure it
581-
Any False -> fmap (Any True,) $ f x'
582-
Just False -> pure (mempty, x)
583-
584-
------------------------------------------------------------------------------
585-
-- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but
586-
-- don't descend into children if the query matches. Because this traversal is
587-
-- root-first, this policy will find the largest subtrees for which the query
588-
-- holds true.
589-
--
590-
-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes
591-
-- with data nodes, so for any given node we can only definitely return an
592-
-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is
593-
-- used.
594-
largestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m
595-
largestM q f = go
596-
where
597-
go :: GenericM m
598-
go x = do
599-
case q x of
600-
Just True -> f x
601-
Just False -> pure x
602-
Nothing -> gmapM go x
603-
604-
newtype MonadicQuery r m a = MonadicQuery
605-
{ runMonadicQuery :: m (r, a)
606-
}
607-
deriving stock (Functor)
608-
deriving Applicative via Compose m ((,) r)
609-
610-
611-
------------------------------------------------------------------------------
612-
-- | Like 'gmapM', but also returns side-channel data.
613-
gmapMQ ::
614-
forall f r a. (Monoid r, Data a, Applicative f) =>
615-
(forall d. Data d => d -> f (r, d)) ->
616-
a ->
617-
f (r, a)
618-
gmapMQ f = runMonadicQuery . gfoldl k pure
619-
where
620-
k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b
621-
k c x = c <*> MonadicQuery (f x)
622-

‎ghcide/src/Generics/SYB/GHC.hs

Lines changed: 125 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,125 @@
1+
{-# LANGUAGE DerivingVia #-}
2+
{-# LANGUAGE RankNTypes #-}
3+
4+
-- | Custom SYB traversals explicitly designed for operating over the GHC AST.
5+
module Generics.SYB.GHC
6+
( genericIsSubspan,
7+
mkBindListT,
8+
everywhereM',
9+
smallestM,
10+
largestM
11+
) where
12+
13+
import Control.Monad
14+
import Data.Functor.Compose (Compose(Compose))
15+
import Data.Monoid (Any(Any))
16+
import Development.IDE.GHC.Compat
17+
import Development.Shake.Classes
18+
import Generics.SYB
19+
20+
21+
-- | A generic query intended to be used for calling 'smallestM' and
22+
-- 'largestM'. If the current node is a 'Located', returns whether or not the
23+
-- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which
24+
-- indicates uncertainty. The search strategy in 'smallestM' et al. will
25+
-- continue searching uncertain nodes.
26+
genericIsSubspan ::
27+
forall ast.
28+
Typeable ast =>
29+
-- | The type of nodes we'd like to consider.
30+
Proxy (Located ast) ->
31+
SrcSpan ->
32+
GenericQ (Maybe Bool)
33+
genericIsSubspan _ dst = mkQ Nothing $ \case
34+
(L span _ :: Located ast) -> Just $ dst `isSubspanOf` span
35+
36+
37+
-- | Lift a function that replaces a value with several values into a generic
38+
-- function. The result doesn't perform any searching, so should be driven via
39+
-- 'everywhereM' or friends.
40+
--
41+
-- The 'Int' argument is the index in the list being bound.
42+
mkBindListT :: forall b m. (Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m
43+
mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..]
44+
45+
46+
-- | Apply a monadic transformation everywhere in a top-down manner.
47+
everywhereM' :: forall m. Monad m => GenericM m -> GenericM m
48+
everywhereM' f = go
49+
where
50+
go :: GenericM m
51+
go = gmapM go <=< f
52+
53+
54+
------------------------------------------------------------------------------
55+
-- Custom SYB machinery
56+
------------------------------------------------------------------------------
57+
58+
-- | Generic monadic transformations that return side-channel data.
59+
type GenericMQ r m = forall a. Data a => a -> m (r, a)
60+
61+
------------------------------------------------------------------------------
62+
-- | Apply the given 'GenericM' at all every node whose children fail the
63+
-- 'GenericQ', but which passes the query itself.
64+
--
65+
-- The query must be a monotonic function when it returns 'Just'. That is, if
66+
-- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It
67+
-- is the True-to-false edge of the query that triggers the transformation.
68+
--
69+
-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes
70+
-- with data nodes, so for any given node we can only definitely return an
71+
-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is
72+
-- used.
73+
smallestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m
74+
smallestM q f = fmap snd . go
75+
where
76+
go :: GenericMQ Any m
77+
go x = do
78+
case q x of
79+
Nothing -> gmapMQ go x
80+
Just True -> do
81+
it@(r, x') <- gmapMQ go x
82+
case r of
83+
Any True -> pure it
84+
Any False -> fmap (Any True,) $ f x'
85+
Just False -> pure (mempty, x)
86+
87+
------------------------------------------------------------------------------
88+
-- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but
89+
-- don't descend into children if the query matches. Because this traversal is
90+
-- root-first, this policy will find the largest subtrees for which the query
91+
-- holds true.
92+
--
93+
-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes
94+
-- with data nodes, so for any given node we can only definitely return an
95+
-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is
96+
-- used.
97+
largestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m
98+
largestM q f = go
99+
where
100+
go :: GenericM m
101+
go x = do
102+
case q x of
103+
Just True -> f x
104+
Just False -> pure x
105+
Nothing -> gmapM go x
106+
107+
newtype MonadicQuery r m a = MonadicQuery
108+
{ runMonadicQuery :: m (r, a)
109+
}
110+
deriving stock (Functor)
111+
deriving Applicative via Compose m ((,) r)
112+
113+
114+
------------------------------------------------------------------------------
115+
-- | Like 'gmapM', but also returns side-channel data.
116+
gmapMQ ::
117+
forall f r a. (Monoid r, Data a, Applicative f) =>
118+
(forall d. Data d => d -> f (r, d)) ->
119+
a ->
120+
f (r, a)
121+
gmapMQ f = runMonadicQuery . gfoldl k pure
122+
where
123+
k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b
124+
k c x = c <*> MonadicQuery (f x)
125+

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ 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 Generics.SYB.GHC
2324
import Ide.Types
2425
import Language.LSP.Server
2526
import Language.LSP.Types

0 commit comments

Comments
 (0)