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

import           Control.Lens                     ((^.))

import           Control.Monad.Error.Class        (MonadError (throwError),
                                                   liftEither)
import           Control.Monad.IO.Class           (MonadIO)
import           Control.Monad.Trans.Class        (MonadTrans (lift))
import           Control.Monad.Trans.Except       (ExceptT, withExceptT)
import           Data.Aeson                       (FromJSON, ToJSON, toJSON)
import           Data.Either.Extra                (maybeToEither)
import qualified Data.Map                         as Map
import qualified Data.Text                        as T
import           Development.IDE
import           Development.IDE.GHC.Compat

import           Data.Maybe                       (mapMaybe)
import           Development.IDE.Core.PluginUtils
import           Development.IDE.Spans.Pragmas    (getFirstPragma,
                                                   insertNewPragma)
import           GHC.Generics                     (Generic)
import           Ide.Plugin.Error
import           Ide.Plugin.GHC
import           Ide.PluginUtils
import           Ide.Types
import qualified Language.LSP.Protocol.Lens       as L
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import           Language.LSP.Server              (sendRequest)

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 ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'Method_TextDocumentCodeAction
SMethod_TextDocumentCodeAction PluginMethodHandler IdeState 'Method_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 :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GadtPluginError -> PluginError
handleGhcidePluginError forall a b. (a -> b) -> a -> b
$ do
    NormalizedFilePath
nfp <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (PluginError -> GadtPluginError
GhcidePluginErrors) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
    ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls, [Extension]
exts) <- forall (m :: * -> *).
MonadIO m =>
IdeState
-> Range
-> NormalizedFilePath
-> ExceptT GadtPluginError 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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Int -> GadtPluginError
UnexpectedNumberOfDeclarations (forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls)
    HscEnvEq
deps <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> GadtPluginError
GhcidePluginErrors
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE (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 -> ExceptT PluginError Action v
useE GhcSessionDeps
GhcSessionDeps NormalizedFilePath
nfp
    (HscEnv -> DynFlags
hsc_dflags forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnvEq -> HscEnv
hscEnv -> DynFlags
df) <- forall (f :: * -> *) a. Applicative f => a -> f a
pure HscEnvEq
deps
    Text
txt <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (Text -> GadtPluginError
PrettyGadtError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) forall a b. (a -> b) -> a -> b
$ 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 GadtPluginError
FailedToFindDataDeclRange
        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 :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> GadtPluginError
GhcidePluginErrors forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError 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 'Method_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 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest
            SMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit
            (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 (MessageResult 'Method_WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR Null
Null
    where
        workSpaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
workSpaceEdit NormalizedFilePath
nfp [TextEdit]
edits = Maybe (Map Uri [TextEdit])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit
            (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [(String -> Uri
filePathToUri forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp,
                [TextEdit]
edits)])
                 forall a. Maybe a
Nothing forall a. Maybe a
Nothing

codeActionHandler :: PluginMethodHandler IdeState Method_TextDocumentCodeAction
codeActionHandler :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionHandler IdeState
state PluginId
plId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
doc Range
range CodeActionContext
_) = forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GadtPluginError -> PluginError
handleGhcidePluginError forall a b. (a -> b) -> a -> b
$ do
    NormalizedFilePath
nfp <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (PluginError -> GadtPluginError
GhcidePluginErrors) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (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 GadtPluginError 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 b. a -> a |? b
InL [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 [Diagnostic]
$sel:_isPreferred:CodeAction :: Maybe Bool
$sel:_disabled:CodeAction :: Maybe (Rec (("reason" .== Text) .+ Empty))
$sel:_edit:CodeAction :: Maybe WorkspaceEdit
$sel:_command:CodeAction :: Maybe Command
$sel:_data_:CodeAction :: Maybe Value
_data_ :: 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
CodeActionKind_RefactorRewrite
                _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])
                _data_ :: Maybe a
_data_ = 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 GadtPluginError m ([LTyClDecl GP], [Extension])
getInRangeH98DeclsAndExts :: forall (m :: * -> *).
MonadIO m =>
IdeState
-> Range
-> NormalizedFilePath
-> ExceptT GadtPluginError m ([LTyClDecl GP], [Extension])
getInRangeH98DeclsAndExts IdeState
state Range
range NormalizedFilePath
nfp = do
    ParsedModule
pm <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> GadtPluginError
GhcidePluginErrors
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"GADT.GetParsedModuleWithComments" IdeState
state
        forall a b. (a -> b) -> a -> b
$ forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE 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)

data GadtPluginError
    = UnexpectedNumberOfDeclarations Int
    | FailedToFindDataDeclRange
    | PrettyGadtError T.Text
    | GhcidePluginErrors PluginError

handleGhcidePluginError ::
    GadtPluginError ->
    PluginError
handleGhcidePluginError :: GadtPluginError -> PluginError
handleGhcidePluginError = \case
    UnexpectedNumberOfDeclarations Int
nums -> do
        Text -> PluginError
PluginInternalError forall a b. (a -> b) -> a -> b
$ Text
"Expected one declaration but found: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Int
nums)
    GadtPluginError
FailedToFindDataDeclRange ->
        Text -> PluginError
PluginInternalError forall a b. (a -> b) -> a -> b
$ Text
"Unable to get data decl range"
    PrettyGadtError Text
errMsg ->
        Text -> PluginError
PluginInternalError forall a b. (a -> b) -> a -> b
$ Text
errMsg
    GhcidePluginErrors PluginError
errors ->
        PluginError
errors