diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index a80d39ca18..0df844e4e5 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -140,6 +140,7 @@ library include exposed-modules: Control.Concurrent.Strict + Generics.SYB.GHC Development.IDE Development.IDE.Main Development.IDE.Core.Actions diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index 7535ba4c0a..659ceacb47 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -28,9 +28,7 @@ module Development.IDE.GHC.ExactPrint TransformT, Anns, Annotate, - mkBindListT, setPrecedingLinesT, - everywhereM', ) where @@ -56,6 +54,7 @@ import Development.Shake (RuleResult, Rules) import Development.Shake.Classes import qualified GHC.Generics as GHC import Generics.SYB +import Generics.SYB.GHC import Ide.PluginUtils import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers @@ -67,8 +66,7 @@ import Parser (parseIdentifier) import Data.Traversable (for) import Data.Foldable (Foldable(fold)) import Data.Bool (bool) -import Data.Monoid (All(All), Any(Any), getAll) -import Data.Functor.Compose (Compose(Compose)) +import Data.Monoid (All(All), getAll) import Control.Arrow @@ -328,21 +326,6 @@ graftWithM dst trans = Graft $ \dflags a -> do ) a --- | A generic query intended to be used for calling 'smallestM' and --- 'largestM'. If the current node is a 'Located', returns whether or not the --- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which --- indicates uncertainty. The search strategy in 'smallestM' et al. will --- continue searching uncertain nodes. -genericIsSubspan :: - forall ast. - Typeable ast => - -- | The type of nodes we'd like to consider. - Proxy (Located ast) -> - SrcSpan -> - GenericQ (Maybe Bool) -genericIsSubspan _ dst = mkQ Nothing $ \case - (L span _ :: Located ast) -> Just $ dst `isSubspanOf` span - -- | Run the given transformation only on the smallest node in the tree that -- contains the 'SrcSpan'. genericGraftWithSmallestM :: @@ -370,15 +353,6 @@ genericGraftWithLargestM proxy dst trans = Graft $ \dflags -> largestM (genericIsSubspan proxy dst) (trans dflags) --- | Lift a function that replaces a value with several values into a generic --- function. The result doesn't perform any searching, so should be driven via --- 'everywhereM' or friends. --- --- The 'Int' argument is the index in the list being bound. -mkBindListT :: forall b m. (Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m -mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..] - - graftDecls :: forall a. (HasDecls a) => @@ -432,12 +406,6 @@ graftDeclsWithM dst toDecls = Graft $ \dflags a -> do modifyDeclsT (fmap DL.toList . go) a -everywhereM' :: forall m. Monad m => GenericM m -> GenericM m -everywhereM' f = go - where - go :: GenericM m - go = gmapM go <=< f - class (Data ast, Outputable ast) => ASTElement ast where parseAST :: Parser (Located ast) maybeParensAST :: Located ast -> Located ast @@ -547,76 +515,3 @@ render dflags = showSDoc dflags . ppr parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs parenthesize = parenthesizeHsExpr appPrec - ------------------------------------------------------------------------------- --- Custom SYB machinery ------------------------------------------------------------------------------- - --- | Generic monadic transformations that return side-channel data. -type GenericMQ r m = forall a. Data a => a -> m (r, a) - ------------------------------------------------------------------------------- --- | Apply the given 'GenericM' at all every node whose children fail the --- 'GenericQ', but which passes the query itself. --- --- The query must be a monotonic function when it returns 'Just'. That is, if --- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It --- is the True-to-false edge of the query that triggers the transformation. --- --- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes --- with data nodes, so for any given node we can only definitely return an --- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is --- used. -smallestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m -smallestM q f = fmap snd . go - where - go :: GenericMQ Any m - go x = do - case q x of - Nothing -> gmapMQ go x - Just True -> do - it@(r, x') <- gmapMQ go x - case r of - Any True -> pure it - Any False -> fmap (Any True,) $ f x' - Just False -> pure (mempty, x) - ------------------------------------------------------------------------------- --- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but --- don't descend into children if the query matches. Because this traversal is --- root-first, this policy will find the largest subtrees for which the query --- holds true. --- --- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes --- with data nodes, so for any given node we can only definitely return an --- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is --- used. -largestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m -largestM q f = go - where - go :: GenericM m - go x = do - case q x of - Just True -> f x - Just False -> pure x - Nothing -> gmapM go x - -newtype MonadicQuery r m a = MonadicQuery - { runMonadicQuery :: m (r, a) - } - deriving stock (Functor) - deriving Applicative via Compose m ((,) r) - - ------------------------------------------------------------------------------- --- | Like 'gmapM', but also returns side-channel data. -gmapMQ :: - forall f r a. (Monoid r, Data a, Applicative f) => - (forall d. Data d => d -> f (r, d)) -> - a -> - f (r, a) -gmapMQ f = runMonadicQuery . gfoldl k pure - where - k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b - k c x = c <*> MonadicQuery (f x) - diff --git a/ghcide/src/Generics/SYB/GHC.hs b/ghcide/src/Generics/SYB/GHC.hs new file mode 100644 index 0000000000..3291d4f72e --- /dev/null +++ b/ghcide/src/Generics/SYB/GHC.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RankNTypes #-} + +-- | Custom SYB traversals explicitly designed for operating over the GHC AST. +module Generics.SYB.GHC + ( genericIsSubspan, + mkBindListT, + everywhereM', + smallestM, + largestM + ) where + +import Control.Monad +import Data.Functor.Compose (Compose(Compose)) +import Data.Monoid (Any(Any)) +import Development.IDE.GHC.Compat +import Development.Shake.Classes +import Generics.SYB + + +-- | A generic query intended to be used for calling 'smallestM' and +-- 'largestM'. If the current node is a 'Located', returns whether or not the +-- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which +-- indicates uncertainty. The search strategy in 'smallestM' et al. will +-- continue searching uncertain nodes. +genericIsSubspan :: + forall ast. + Typeable ast => + -- | The type of nodes we'd like to consider. + Proxy (Located ast) -> + SrcSpan -> + GenericQ (Maybe Bool) +genericIsSubspan _ dst = mkQ Nothing $ \case + (L span _ :: Located ast) -> Just $ dst `isSubspanOf` span + + +-- | Lift a function that replaces a value with several values into a generic +-- function. The result doesn't perform any searching, so should be driven via +-- 'everywhereM' or friends. +-- +-- The 'Int' argument is the index in the list being bound. +mkBindListT :: forall b m. (Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m +mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..] + + +-- | Apply a monadic transformation everywhere in a top-down manner. +everywhereM' :: forall m. Monad m => GenericM m -> GenericM m +everywhereM' f = go + where + go :: GenericM m + go = gmapM go <=< f + + +------------------------------------------------------------------------------ +-- Custom SYB machinery +------------------------------------------------------------------------------ + +-- | Generic monadic transformations that return side-channel data. +type GenericMQ r m = forall a. Data a => a -> m (r, a) + +------------------------------------------------------------------------------ +-- | Apply the given 'GenericM' at all every node whose children fail the +-- 'GenericQ', but which passes the query itself. +-- +-- The query must be a monotonic function when it returns 'Just'. That is, if +-- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It +-- is the True-to-false edge of the query that triggers the transformation. +-- +-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes +-- with data nodes, so for any given node we can only definitely return an +-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is +-- used. +smallestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m +smallestM q f = fmap snd . go + where + go :: GenericMQ Any m + go x = do + case q x of + Nothing -> gmapMQ go x + Just True -> do + it@(r, x') <- gmapMQ go x + case r of + Any True -> pure it + Any False -> fmap (Any True,) $ f x' + Just False -> pure (mempty, x) + +------------------------------------------------------------------------------ +-- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but +-- don't descend into children if the query matches. Because this traversal is +-- root-first, this policy will find the largest subtrees for which the query +-- holds true. +-- +-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes +-- with data nodes, so for any given node we can only definitely return an +-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is +-- used. +largestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m +largestM q f = go + where + go :: GenericM m + go x = do + case q x of + Just True -> f x + Just False -> pure x + Nothing -> gmapM go x + +newtype MonadicQuery r m a = MonadicQuery + { runMonadicQuery :: m (r, a) + } + deriving stock (Functor) + deriving Applicative via Compose m ((,) r) + + +------------------------------------------------------------------------------ +-- | Like 'gmapM', but also returns side-channel data. +gmapMQ :: + forall f r a. (Monoid r, Data a, Applicative f) => + (forall d. Data d => d -> f (r, d)) -> + a -> + f (r, a) +gmapMQ f = runMonadicQuery . gfoldl k pure + where + k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b + k c x = c <*> MonadicQuery (f x) + diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index 437b51ffaf..ab758cc91d 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -20,6 +20,7 @@ import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.Core.UseStale (Tracked, TrackedStale(..), unTrack, mapAgeFrom, unsafeMkCurrent) import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint +import Generics.SYB.GHC import Ide.Types import Language.LSP.Server import Language.LSP.Types