{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeOperators     #-}
{-# LANGUAGE ViewPatterns      #-}
module Ide.Plugin.GADT (descriptor) where

import           Control.Lens                  ((^.))
import           Control.Monad.Except
import           Data.Aeson                    (FromJSON, ToJSON, Value (Null),
                                                toJSON)
import           Data.Either.Extra             (maybeToEither)
import qualified Data.HashMap.Lazy             as HashMap
import qualified Data.Text                     as T
import           Development.IDE
import           Development.IDE.GHC.Compat

import           Control.Monad.Trans.Except    (throwE)
import           Data.Maybe                    (mapMaybe)
import           Development.IDE.Spans.Pragmas (getFirstPragma, insertNewPragma)
import           GHC.Generics                  (Generic)
import           Ide.Plugin.GHC
import           Ide.PluginUtils
import           Ide.Types
import           Language.LSP.Server           (sendRequest)
import           Language.LSP.Types
import qualified Language.LSP.Types.Lens       as L

descriptor :: PluginId -> PluginDescriptor IdeState
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor PluginId
plId = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
    { pluginHandlers :: PluginHandlers IdeState
Ide.Types.pluginHandlers =
        forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeAction
STextDocumentCodeAction PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionHandler
    , pluginCommands :: [PluginCommand IdeState]
pluginCommands =
        [forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand CommandId
toGADTSyntaxCommandId Text
"convert data decl to GADT syntax" (PluginId -> CommandFunction IdeState ToGADTParams
toGADTCommand PluginId
plId)]
    }

-- | Parameter used in the command
data ToGADTParams = ToGADTParams
    { ToGADTParams -> Uri
uri   :: Uri
    , ToGADTParams -> Range
range :: Range
    } deriving (forall x. Rep ToGADTParams x -> ToGADTParams
forall x. ToGADTParams -> Rep ToGADTParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ToGADTParams x -> ToGADTParams
$cfrom :: forall x. ToGADTParams -> Rep ToGADTParams x
Generic, [ToGADTParams] -> Encoding
[ToGADTParams] -> Value
ToGADTParams -> Encoding
ToGADTParams -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ToGADTParams] -> Encoding
$ctoEncodingList :: [ToGADTParams] -> Encoding
toJSONList :: [ToGADTParams] -> Value
$ctoJSONList :: [ToGADTParams] -> Value
toEncoding :: ToGADTParams -> Encoding
$ctoEncoding :: ToGADTParams -> Encoding
toJSON :: ToGADTParams -> Value
$ctoJSON :: ToGADTParams -> Value
ToJSON, Value -> Parser [ToGADTParams]
Value -> Parser ToGADTParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ToGADTParams]
$cparseJSONList :: Value -> Parser [ToGADTParams]
parseJSON :: Value -> Parser ToGADTParams
$cparseJSON :: Value -> Parser ToGADTParams
FromJSON)

toGADTSyntaxCommandId :: CommandId
toGADTSyntaxCommandId :: CommandId
toGADTSyntaxCommandId = CommandId
"GADT.toGADT"

-- | A command replaces H98 data decl with GADT decl in place
toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams
toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams
toGADTCommand pId :: PluginId
pId@(PluginId Text
pId') IdeState
state ToGADTParams{Uri
Range
range :: Range
uri :: Uri
range :: ToGADTParams -> Range
uri :: ToGADTParams -> Uri
..} = forall (m :: * -> *) a.
Monad m =>
ExceptT String m a -> m (Either ResponseError a)
pluginResponse forall a b. (a -> b) -> a -> b
$ do
    NormalizedFilePath
nfp <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT String m NormalizedFilePath
getNormalizedFilePath Uri
uri
    ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls, [Extension]
exts) <- forall (m :: * -> *).
MonadIO m =>
IdeState
-> Range
-> NormalizedFilePath
-> ExceptT String m ([LTyClDecl GP], [Extension])
getInRangeH98DeclsAndExts IdeState
state Range
range NormalizedFilePath
nfp
    (L SrcSpanAnn' (EpAnn AnnListItem)
ann TyClDecl GP
decl) <- case [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls of
        [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
d] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
d
        [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
_   -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ String
"Expected 1 declaration, but got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls)
    Maybe HscEnvEq
deps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IdeState -> Action a -> IO a
runAction (Text -> String
T.unpack Text
pId' forall a. Semigroup a => a -> a -> a
<> String
".GhcSessionDeps") IdeState
state forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSessionDeps
GhcSessionDeps NormalizedFilePath
nfp
    (HscEnv -> DynFlags
hsc_dflags forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnvEq -> HscEnv
hscEnv -> DynFlags
df) <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
        forall a b. (a -> b) -> a -> b
$ forall a b. a -> Maybe b -> Either a b
maybeToEither String
"Get GhcSessionDeps failed" Maybe HscEnvEq
deps
    Text
txt <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DynFlags -> TyClDecl GP -> Either String String
prettyGADTDecl DynFlags
df forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl GP -> TyClDecl GP
h98ToGADTDecl) TyClDecl GP
decl
    Range
range <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
        forall a b. (a -> b) -> a -> b
$ forall a b. a -> Maybe b -> Either a b
maybeToEither String
"Unable to get data decl range"
        forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Range
srcSpanToRange forall a b. (a -> b) -> a -> b
$ forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn AnnListItem)
ann
    NextPragmaInfo
pragma <- forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT String m NextPragmaInfo
getFirstPragma PluginId
pId IdeState
state NormalizedFilePath
nfp
    let insertEdit :: [TextEdit]
insertEdit = [NextPragmaInfo -> Extension -> TextEdit
insertNewPragma NextPragmaInfo
pragma Extension
GADTs | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Extension]
exts) [Extension
GADTSyntax, Extension
GADTs]]

    LspId 'WorkspaceApplyEdit
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest
            SMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit
            (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing (NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
workSpaceEdit NormalizedFilePath
nfp (Range -> Text -> TextEdit
TextEdit Range
range Text
txt forall a. a -> [a] -> [a]
: [TextEdit]
insertEdit)))
            (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

    forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null
    where
        workSpaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
workSpaceEdit NormalizedFilePath
nfp [TextEdit]
edits = Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit
            (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
                [(String -> Uri
filePathToUri forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp,
                 forall a. [a] -> List a
List [TextEdit]
edits)])
                 forall a. Maybe a
Nothing forall a. Maybe a
Nothing

codeActionHandler :: PluginMethodHandler IdeState TextDocumentCodeAction
codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionHandler IdeState
state PluginId
plId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
doc Range
range CodeActionContext
_) = forall (m :: * -> *) a.
Monad m =>
ExceptT String m a -> m (Either ResponseError a)
pluginResponse forall a b. (a -> b) -> a -> b
$ do
    NormalizedFilePath
nfp <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT String m NormalizedFilePath
getNormalizedFilePath (TextDocumentIdentifier
doc forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri)
    ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
inRangeH98Decls, [Extension]
_) <- forall (m :: * -> *).
MonadIO m =>
IdeState
-> Range
-> NormalizedFilePath
-> ExceptT String m ([LTyClDecl GP], [Extension])
getInRangeH98DeclsAndExts IdeState
state Range
range NormalizedFilePath
nfp
    let actions :: [Command |? CodeAction]
actions = forall a b. (a -> b) -> [a] -> [b]
map (Text -> Command |? CodeAction
mkAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> Text
printOutputable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. TyClDecl pass -> LIdP pass
tcdLName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
inRangeH98Decls
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List [Command |? CodeAction]
actions
    where
        mkAction :: T.Text -> Command |? CodeAction
        mkAction :: Text -> Command |? CodeAction
mkAction Text
name = forall a b. b -> a |? b
InR CodeAction{Maybe CodeActionKind
Maybe Command
Text
forall a. Maybe a
$sel:_title:CodeAction :: Text
$sel:_kind:CodeAction :: Maybe CodeActionKind
$sel:_diagnostics:CodeAction :: Maybe (List Diagnostic)
$sel:_isPreferred:CodeAction :: Maybe Bool
$sel:_disabled:CodeAction :: Maybe Reason
$sel:_edit:CodeAction :: Maybe WorkspaceEdit
$sel:_command:CodeAction :: Maybe Command
$sel:_xdata:CodeAction :: Maybe Value
_xdata :: forall a. Maybe a
_command :: Maybe Command
_edit :: forall a. Maybe a
_disabled :: forall a. Maybe a
_isPreferred :: forall a. Maybe a
_diagnostics :: forall a. Maybe a
_kind :: Maybe CodeActionKind
_title :: Text
..}
            where
                _title :: Text
_title = Text
"Convert \"" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"\" to GADT syntax"
                _kind :: Maybe CodeActionKind
_kind = forall a. a -> Maybe a
Just CodeActionKind
CodeActionRefactorRewrite
                _diagnostics :: Maybe a
_diagnostics = forall a. Maybe a
Nothing
                _isPreferred :: Maybe a
_isPreferred = forall a. Maybe a
Nothing
                _disabled :: Maybe a
_disabled = forall a. Maybe a
Nothing
                _edit :: Maybe a
_edit = forall a. Maybe a
Nothing
                _command :: Maybe Command
_command = forall a. a -> Maybe a
Just
                    forall a b. (a -> b) -> a -> b
$ PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
toGADTSyntaxCommandId Text
_title (forall a. a -> Maybe a
Just [forall a. ToJSON a => a -> Value
toJSON ToGADTParams
mkParam])
                _xdata :: Maybe a
_xdata = forall a. Maybe a
Nothing

        mkParam :: ToGADTParams
mkParam = Uri -> Range -> ToGADTParams
ToGADTParams (TextDocumentIdentifier
doc forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri) Range
range

-- | Get all H98 decls in the given range, and enabled extensions
getInRangeH98DeclsAndExts :: (MonadIO m) =>
    IdeState
    -> Range
    -> NormalizedFilePath
    -> ExceptT String m ([LTyClDecl GP], [Extension])
getInRangeH98DeclsAndExts :: forall (m :: * -> *).
MonadIO m =>
IdeState
-> Range
-> NormalizedFilePath
-> ExceptT String m ([LTyClDecl GP], [Extension])
getInRangeH98DeclsAndExts IdeState
state Range
range NormalizedFilePath
nfp = do
    ParsedModule
pm <- forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"Unable to get ParsedModuleWithComments"
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        forall a b. (a -> b) -> a -> b
$ forall a. String -> IdeState -> Action a -> IO a
runAction String
"GADT.GetParsedModuleWithComments" IdeState
state
        forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModuleWithComments
GetParsedModuleWithComments NormalizedFilePath
nfp
    let (L SrcSpan
_ [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)]
hsDecls) = HsModule -> [LHsDecl GP]
hsmodDecls forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsedModule -> ParsedSource
pm_parsed_source ParsedModule
pm
        decls :: [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls = forall a. (a -> Bool) -> [a] -> [a]
filter LTyClDecl GP -> Bool
isH98DataDecl
            forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LHsDecl GP -> Maybe (LTyClDecl GP)
getDataDecl
            forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. HasSrcSpan a => Range -> a -> Bool
inRange Range
range) [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)]
hsDecls
        exts :: [Extension]
exts = ParsedModule -> [Extension]
getExtensions ParsedModule
pm
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls, [Extension]
exts)