{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ide.TreeTransform
( Graft, graft, transform, useAnnotatedSource
) where
import BasicTypes (appPrec)
import Control.Monad
import Control.Monad.Trans.Class
import qualified Data.Text as T
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Rules
import Development.IDE.Core.Shake
import Development.IDE.GHC.Compat hiding (parseExpr)
import Development.IDE.Types.Location
import Generics.SYB
import Ide.PluginUtils
import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.Parsers
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities)
import Outputable
import Retrie.ExactPrint hiding (parseExpr)
useAnnotatedSource
:: String
-> IdeState
-> NormalizedFilePath
-> IO (Maybe (Annotated ParsedSource))
useAnnotatedSource :: String
-> IdeState
-> NormalizedFilePath
-> IO (Maybe (Annotated ParsedSource))
useAnnotatedSource String
herald IdeState
state NormalizedFilePath
nfp = do
Maybe ParsedModule
pm <- String
-> IdeState
-> Action (Maybe ParsedModule)
-> IO (Maybe ParsedModule)
forall a. String -> IdeState -> Action a -> IO a
runAction String
herald IdeState
state (Action (Maybe ParsedModule) -> IO (Maybe ParsedModule))
-> Action (Maybe ParsedModule) -> IO (Maybe ParsedModule)
forall a b. (a -> b) -> a -> b
$ GetParsedModule
-> NormalizedFilePath -> Action (Maybe ParsedModule)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModule
GetParsedModule NormalizedFilePath
nfp
Maybe (Annotated ParsedSource)
-> IO (Maybe (Annotated ParsedSource))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Annotated ParsedSource)
-> IO (Maybe (Annotated ParsedSource)))
-> Maybe (Annotated ParsedSource)
-> IO (Maybe (Annotated ParsedSource))
forall a b. (a -> b) -> a -> b
$ (ParsedModule -> Annotated ParsedSource)
-> Maybe ParsedModule -> Maybe (Annotated ParsedSource)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParsedModule -> Annotated ParsedSource
fixAnns Maybe ParsedModule
pm
newtype Graft a = Graft
{ Graft a -> DynFlags -> a -> TransformT (Either String) a
runGraft :: DynFlags -> a -> TransformT (Either String) a
}
instance Semigroup (Graft a) where
Graft DynFlags -> a -> TransformT (Either String) a
a <> :: Graft a -> Graft a -> Graft a
<> Graft DynFlags -> a -> TransformT (Either String) a
b = (DynFlags -> a -> TransformT (Either String) a) -> Graft a
forall a.
(DynFlags -> a -> TransformT (Either String) a) -> Graft a
Graft ((DynFlags -> a -> TransformT (Either String) a) -> Graft a)
-> (DynFlags -> a -> TransformT (Either String) a) -> Graft a
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags -> DynFlags -> a -> TransformT (Either String) a
a DynFlags
dflags (a -> TransformT (Either String) a)
-> (a -> TransformT (Either String) a)
-> a
-> TransformT (Either String) a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> DynFlags -> a -> TransformT (Either String) a
b DynFlags
dflags
instance Monoid (Graft a) where
mempty :: Graft a
mempty = (DynFlags -> a -> TransformT (Either String) a) -> Graft a
forall a.
(DynFlags -> a -> TransformT (Either String) a) -> Graft a
Graft ((DynFlags -> a -> TransformT (Either String) a) -> Graft a)
-> (DynFlags -> a -> TransformT (Either String) a) -> Graft a
forall a b. (a -> b) -> a -> b
$ (a -> TransformT (Either String) a)
-> DynFlags -> a -> TransformT (Either String) a
forall a b. a -> b -> a
const a -> TransformT (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
transform
:: DynFlags
-> ClientCapabilities
-> Uri
-> Graft ParsedSource
-> Annotated ParsedSource
-> Either String WorkspaceEdit
transform :: DynFlags
-> ClientCapabilities
-> Uri
-> Graft ParsedSource
-> Annotated ParsedSource
-> Either String WorkspaceEdit
transform DynFlags
dflags ClientCapabilities
ccs Uri
uri Graft ParsedSource
f Annotated ParsedSource
a = do
let src :: String
src = Annotated ParsedSource -> String
forall ast. Annotate ast => Annotated (Located ast) -> String
printA Annotated ParsedSource
a
Annotated ParsedSource
a' <- Annotated ParsedSource
-> (ParsedSource -> TransformT (Either String) ParsedSource)
-> Either String (Annotated ParsedSource)
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA Annotated ParsedSource
a ((ParsedSource -> TransformT (Either String) ParsedSource)
-> Either String (Annotated ParsedSource))
-> (ParsedSource -> TransformT (Either String) ParsedSource)
-> Either String (Annotated ParsedSource)
forall a b. (a -> b) -> a -> b
$ Graft ParsedSource
-> DynFlags
-> ParsedSource
-> TransformT (Either String) ParsedSource
forall a. Graft a -> DynFlags -> a -> TransformT (Either String) a
runGraft Graft ParsedSource
f DynFlags
dflags
let res :: String
res = Annotated ParsedSource -> String
forall ast. Annotate ast => Annotated (Located ast) -> String
printA Annotated ParsedSource
a'
WorkspaceEdit -> Either String WorkspaceEdit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WorkspaceEdit -> Either String WorkspaceEdit)
-> WorkspaceEdit -> Either String WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ ClientCapabilities
-> (Uri, Text) -> Text -> WithDeletions -> WorkspaceEdit
diffText ClientCapabilities
ccs (Uri
uri, String -> Text
T.pack String
src) (String -> Text
T.pack String
res) WithDeletions
IncludeDeletions
graft
:: forall a
. Data a
=> SrcSpan
-> LHsExpr GhcPs
-> Graft a
graft :: SrcSpan -> LHsExpr GhcPs -> Graft a
graft SrcSpan
dst LHsExpr GhcPs
val = (DynFlags -> a -> TransformT (Either String) a) -> Graft a
forall a.
(DynFlags -> a -> TransformT (Either String) a) -> Graft a
Graft ((DynFlags -> a -> TransformT (Either String) a) -> Graft a)
-> (DynFlags -> a -> TransformT (Either String) a) -> Graft a
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags a
a -> do
(Anns
anns, LHsExpr GhcPs
val') <- DynFlags
-> LHsExpr GhcPs
-> TransformT (Either String) (Anns, LHsExpr GhcPs)
annotate DynFlags
dflags (LHsExpr GhcPs -> TransformT (Either String) (Anns, LHsExpr GhcPs))
-> LHsExpr GhcPs
-> TransformT (Either String) (Anns, LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
parenthesize LHsExpr GhcPs
val
(Anns -> Anns) -> TransformT (Either String) ()
forall (m :: * -> *). Monad m => (Anns -> Anns) -> TransformT m ()
modifyAnnsT ((Anns -> Anns) -> TransformT (Either String) ())
-> (Anns -> Anns) -> TransformT (Either String) ()
forall a b. (a -> b) -> a -> b
$ Anns -> Anns -> Anns
forall a. Monoid a => a -> a -> a
mappend Anns
anns
a -> TransformT (Either String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> TransformT (Either String) a)
-> a -> TransformT (Either String) a
forall a b. (a -> b) -> a -> b
$ (forall a. Data a => a -> a) -> a -> a
(forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere'
( (LHsExpr GhcPs -> LHsExpr GhcPs) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((LHsExpr GhcPs -> LHsExpr GhcPs) -> a -> a)
-> (LHsExpr GhcPs -> LHsExpr GhcPs) -> a -> a
forall a b. (a -> b) -> a -> b
$
\case
(L SrcSpan
src HsExpr GhcPs
_ :: LHsExpr GhcPs) | SrcSpan
src SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
dst -> LHsExpr GhcPs
val'
LHsExpr GhcPs
l -> LHsExpr GhcPs
l
) a
a
fixAnns :: ParsedModule -> Annotated ParsedSource
fixAnns :: ParsedModule -> Annotated ParsedSource
fixAnns ParsedModule {[String]
ApiAnns
ModSummary
ParsedSource
pm_mod_summary :: ParsedModule -> ModSummary
pm_parsed_source :: ParsedModule -> ParsedSource
pm_extra_src_files :: ParsedModule -> [String]
pm_annotations :: ParsedModule -> ApiAnns
pm_annotations :: ApiAnns
pm_extra_src_files :: [String]
pm_parsed_source :: ParsedSource
pm_mod_summary :: ModSummary
..} =
let ranns :: Anns
ranns = ParsedSource -> ApiAnns -> Anns
forall ast.
(Data (SrcSpanLess ast), Annotate ast, HasSrcSpan ast) =>
ast -> ApiAnns -> Anns
relativiseApiAnns ParsedSource
pm_parsed_source ApiAnns
pm_annotations
in ParsedSource -> Anns -> Int -> Annotated ParsedSource
forall ast. ast -> Anns -> Int -> Annotated ast
unsafeMkA ParsedSource
pm_parsed_source Anns
ranns Int
0
annotate :: DynFlags -> LHsExpr GhcPs -> TransformT (Either String) (Anns, LHsExpr GhcPs)
annotate :: DynFlags
-> LHsExpr GhcPs
-> TransformT (Either String) (Anns, LHsExpr GhcPs)
annotate DynFlags
dflags LHsExpr GhcPs
expr = do
String
uniq <- SrcSpan -> String
forall a. Show a => a -> String
show (SrcSpan -> String)
-> TransformT (Either String) SrcSpan
-> TransformT (Either String) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TransformT (Either String) SrcSpan
forall (m :: * -> *). Monad m => TransformT m SrcSpan
uniqueSrcSpanT
let rendered :: String
rendered = DynFlags -> LHsExpr GhcPs -> String
forall a. Outputable a => DynFlags -> a -> String
render DynFlags
dflags LHsExpr GhcPs
expr
(Anns
anns, LHsExpr GhcPs
expr') <- Either String (Anns, LHsExpr GhcPs)
-> TransformT (Either String) (Anns, LHsExpr GhcPs)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String (Anns, LHsExpr GhcPs)
-> TransformT (Either String) (Anns, LHsExpr GhcPs))
-> Either String (Anns, LHsExpr GhcPs)
-> TransformT (Either String) (Anns, LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ (ErrorMessages -> Either String (Anns, LHsExpr GhcPs))
-> ((Anns, LHsExpr GhcPs) -> Either String (Anns, LHsExpr GhcPs))
-> Either ErrorMessages (Anns, LHsExpr GhcPs)
-> Either String (Anns, LHsExpr GhcPs)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String (Anns, LHsExpr GhcPs)
forall a b. a -> Either a b
Left (String -> Either String (Anns, LHsExpr GhcPs))
-> (ErrorMessages -> String)
-> ErrorMessages
-> Either String (Anns, LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessages -> String
forall a. Show a => a -> String
show) (Anns, LHsExpr GhcPs) -> Either String (Anns, LHsExpr GhcPs)
forall a b. b -> Either a b
Right (Either ErrorMessages (Anns, LHsExpr GhcPs)
-> Either String (Anns, LHsExpr GhcPs))
-> Either ErrorMessages (Anns, LHsExpr GhcPs)
-> Either String (Anns, LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ Parser (LHsExpr GhcPs)
parseExpr DynFlags
dflags String
uniq String
rendered
let anns' :: Anns
anns' = LHsExpr GhcPs -> Int -> Int -> Anns -> Anns
forall a. Data a => Located a -> Int -> Int -> Anns -> Anns
setPrecedingLines LHsExpr GhcPs
expr' Int
0 Int
1 Anns
anns
(Anns, LHsExpr GhcPs)
-> TransformT (Either String) (Anns, LHsExpr GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
anns', LHsExpr GhcPs
expr')
render :: Outputable a => DynFlags -> a -> String
render :: DynFlags -> a -> String
render DynFlags
dflags = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> (a -> SDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr
parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs
parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs
parenthesize = PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
appPrec