{-# 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)


------------------------------------------------------------------------------
-- | Get the latest version of the annotated parse source.
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


------------------------------------------------------------------------------
-- | A transformation for grafting source trees together. Use the semigroup
-- instance to combine 'Graft's, and run them via 'transform'.
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


------------------------------------------------------------------------------
-- | Convert a 'Graft' into a 'WorkspaceEdit'.
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


------------------------------------------------------------------------------
-- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the
-- given 'LHSExpr'. The node at that position must already be a 'LHsExpr', or
-- this is a no-op.
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


------------------------------------------------------------------------------
-- | Dark magic I stole from retrie. No idea what it does.
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


------------------------------------------------------------------------------
-- | Given an 'LHSExpr', compute its exactprint annotations.
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')


------------------------------------------------------------------------------
-- | Print out something 'Outputable'.
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


------------------------------------------------------------------------------
-- | Put parentheses around an expression if required.
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