{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# 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 = (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
"Provides a code action to convert datatypes to GADT syntax")
    { Ide.Types.pluginHandlers =
        mkPluginHandler SMethod_TextDocumentCodeAction codeActionHandler
    , pluginCommands =
        [PluginCommand toGADTSyntaxCommandId "convert data decl to GADT syntax" (toGADTCommand plId)]
    }

-- | Parameter used in the command
data ToGADTParams = ToGADTParams
    { ToGADTParams -> Uri
uri   :: Uri
    , ToGADTParams -> Range
range :: Range
    } deriving ((forall x. ToGADTParams -> Rep ToGADTParams x)
-> (forall x. Rep ToGADTParams x -> ToGADTParams)
-> Generic ToGADTParams
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
$cfrom :: forall x. ToGADTParams -> Rep ToGADTParams x
from :: forall x. ToGADTParams -> Rep ToGADTParams x
$cto :: forall x. Rep ToGADTParams x -> ToGADTParams
to :: forall x. Rep ToGADTParams x -> ToGADTParams
Generic, [ToGADTParams] -> Value
[ToGADTParams] -> Encoding
ToGADTParams -> Bool
ToGADTParams -> Value
ToGADTParams -> Encoding
(ToGADTParams -> Value)
-> (ToGADTParams -> Encoding)
-> ([ToGADTParams] -> Value)
-> ([ToGADTParams] -> Encoding)
-> (ToGADTParams -> Bool)
-> ToJSON ToGADTParams
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ToGADTParams -> Value
toJSON :: ToGADTParams -> Value
$ctoEncoding :: ToGADTParams -> Encoding
toEncoding :: ToGADTParams -> Encoding
$ctoJSONList :: [ToGADTParams] -> Value
toJSONList :: [ToGADTParams] -> Value
$ctoEncodingList :: [ToGADTParams] -> Encoding
toEncodingList :: [ToGADTParams] -> Encoding
$comitField :: ToGADTParams -> Bool
omitField :: ToGADTParams -> Bool
ToJSON, Maybe ToGADTParams
Value -> Parser [ToGADTParams]
Value -> Parser ToGADTParams
(Value -> Parser ToGADTParams)
-> (Value -> Parser [ToGADTParams])
-> Maybe ToGADTParams
-> FromJSON ToGADTParams
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ToGADTParams
parseJSON :: Value -> Parser ToGADTParams
$cparseJSONList :: Value -> Parser [ToGADTParams]
parseJSONList :: Value -> Parser [ToGADTParams]
$comittedField :: Maybe ToGADTParams
omittedField :: Maybe 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 Maybe ProgressToken
_ ToGADTParams{Range
Uri
uri :: ToGADTParams -> Uri
range :: ToGADTParams -> Range
uri :: Uri
range :: Range
..} = (GadtPluginError -> PluginError)
-> ExceptT GadtPluginError (LspM Config) (Value |? Null)
-> ExceptT PluginError (LspM Config) (Value |? Null)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GadtPluginError -> PluginError
handleGhcidePluginError (ExceptT GadtPluginError (LspM Config) (Value |? Null)
 -> ExceptT PluginError (LspM Config) (Value |? Null))
-> ExceptT GadtPluginError (LspM Config) (Value |? Null)
-> ExceptT PluginError (LspM Config) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ do
    NormalizedFilePath
nfp <- (PluginError -> GadtPluginError)
-> ExceptT PluginError (LspM Config) NormalizedFilePath
-> ExceptT GadtPluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> GadtPluginError
GhcidePluginErrors (ExceptT PluginError (LspM Config) NormalizedFilePath
 -> ExceptT GadtPluginError (LspM Config) NormalizedFilePath)
-> ExceptT PluginError (LspM Config) NormalizedFilePath
-> ExceptT GadtPluginError (LspM Config) NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
    ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls, [Extension]
exts) <- IdeState
-> Range
-> NormalizedFilePath
-> ExceptT
     GadtPluginError (LspM Config) ([LTyClDecl GP], [Extension])
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] -> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
-> ExceptT
     GadtPluginError
     (LspM Config)
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP))
forall a. a -> ExceptT GadtPluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
d
        [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
_   -> GadtPluginError
-> ExceptT
     GadtPluginError
     (LspM Config)
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP))
forall a.
GadtPluginError -> ExceptT GadtPluginError (LspM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GadtPluginError
 -> ExceptT
      GadtPluginError
      (LspM Config)
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)))
-> GadtPluginError
-> ExceptT
     GadtPluginError
     (LspM Config)
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP))
forall a b. (a -> b) -> a -> b
$ Int -> GadtPluginError
UnexpectedNumberOfDeclarations ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls)
    HscEnvEq
deps <- (PluginError -> GadtPluginError)
-> ExceptT PluginError (LspM Config) HscEnvEq
-> ExceptT GadtPluginError (LspM Config) HscEnvEq
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> GadtPluginError
GhcidePluginErrors
        (ExceptT PluginError (LspM Config) HscEnvEq
 -> ExceptT GadtPluginError (LspM Config) HscEnvEq)
-> ExceptT PluginError (LspM Config) HscEnvEq
-> ExceptT GadtPluginError (LspM Config) HscEnvEq
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> ExceptT PluginError Action HscEnvEq
-> ExceptT PluginError (LspM Config) HscEnvEq
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE (Text -> String
T.unpack Text
pId' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".GhcSessionDeps") IdeState
state
        (ExceptT PluginError Action HscEnvEq
 -> ExceptT PluginError (LspM Config) HscEnvEq)
-> ExceptT PluginError Action HscEnvEq
-> ExceptT PluginError (LspM Config) HscEnvEq
forall a b. (a -> b) -> a -> b
$ GhcSessionDeps
-> NormalizedFilePath -> ExceptT PluginError Action HscEnvEq
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE GhcSessionDeps
GhcSessionDeps NormalizedFilePath
nfp
    (HscEnv -> DynFlags
hsc_dflags (HscEnv -> DynFlags)
-> (HscEnvEq -> HscEnv) -> HscEnvEq -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnvEq -> HscEnv
hscEnv -> DynFlags
df) <- HscEnvEq -> ExceptT GadtPluginError (LspM Config) HscEnvEq
forall a. a -> ExceptT GadtPluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HscEnvEq
deps
    Text
txt <- (String -> GadtPluginError)
-> ExceptT String (LspM Config) Text
-> ExceptT GadtPluginError (LspM Config) Text
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (Text -> GadtPluginError
PrettyGadtError (Text -> GadtPluginError)
-> (String -> Text) -> String -> GadtPluginError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (ExceptT String (LspM Config) Text
 -> ExceptT GadtPluginError (LspM Config) Text)
-> ExceptT String (LspM Config) Text
-> ExceptT GadtPluginError (LspM Config) Text
forall a b. (a -> b) -> a -> b
$ Either String Text -> ExceptT String (LspM Config) Text
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String Text -> ExceptT String (LspM Config) Text)
-> Either String Text -> ExceptT String (LspM Config) Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> Either String String -> Either String Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DynFlags -> TyClDecl GP -> Either String String
prettyGADTDecl DynFlags
df (TyClDecl GP -> Either String String)
-> (TyClDecl GP -> TyClDecl GP)
-> TyClDecl GP
-> Either String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl GP -> TyClDecl GP
h98ToGADTDecl) TyClDecl GP
decl
    Range
range <- Either GadtPluginError Range
-> ExceptT GadtPluginError (LspM Config) Range
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
        (Either GadtPluginError Range
 -> ExceptT GadtPluginError (LspM Config) Range)
-> Either GadtPluginError Range
-> ExceptT GadtPluginError (LspM Config) Range
forall a b. (a -> b) -> a -> b
$ GadtPluginError -> Maybe Range -> Either GadtPluginError Range
forall a b. a -> Maybe b -> Either a b
maybeToEither GadtPluginError
FailedToFindDataDeclRange
        (Maybe Range -> Either GadtPluginError Range)
-> Maybe Range -> Either GadtPluginError Range
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Maybe Range
srcSpanToRange (SrcSpan -> Maybe Range) -> SrcSpan -> Maybe Range
forall a b. (a -> b) -> a -> b
$ SrcSpanAnn' (EpAnn AnnListItem) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn AnnListItem)
ann
    NextPragmaInfo
pragma <- (PluginError -> GadtPluginError)
-> ExceptT PluginError (LspM Config) NextPragmaInfo
-> ExceptT GadtPluginError (LspM Config) NextPragmaInfo
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> GadtPluginError
GhcidePluginErrors (ExceptT PluginError (LspM Config) NextPragmaInfo
 -> ExceptT GadtPluginError (LspM Config) NextPragmaInfo)
-> ExceptT PluginError (LspM Config) NextPragmaInfo
-> ExceptT GadtPluginError (LspM Config) NextPragmaInfo
forall a b. (a -> b) -> a -> b
$ PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError (LspM Config) NextPragmaInfo
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 | (Extension -> Bool) -> [Extension] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Extension -> [Extension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Extension]
exts) [Extension
GADTSyntax, Extension
GADTs]]

    LspId 'Method_WorkspaceApplyEdit
_ <- LspM Config (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
     GadtPluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT GadtPluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LspM Config (LspId 'Method_WorkspaceApplyEdit)
 -> ExceptT
      GadtPluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit))
-> LspM Config (LspId 'Method_WorkspaceApplyEdit)
-> ExceptT
     GadtPluginError (LspM Config) (LspId 'Method_WorkspaceApplyEdit)
forall a b. (a -> b) -> a -> b
$ SServerMethod 'Method_WorkspaceApplyEdit
-> MessageParams 'Method_WorkspaceApplyEdit
-> (Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspM Config (LspId 'Method_WorkspaceApplyEdit)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
sendRequest
            SServerMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit
            (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing (NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
workSpaceEdit NormalizedFilePath
nfp (Range -> Text -> TextEdit
TextEdit Range
range Text
txt TextEdit -> [TextEdit] -> [TextEdit]
forall a. a -> [a] -> [a]
: [TextEdit]
insertEdit)))
            (\Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

    (Value |? Null)
-> ExceptT GadtPluginError (LspM Config) (Value |? Null)
forall a. a -> ExceptT GadtPluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Value |? Null)
 -> ExceptT GadtPluginError (LspM Config) (Value |? Null))
-> (Value |? Null)
-> ExceptT GadtPluginError (LspM Config) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> Value |? Null
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
            (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit]))
-> Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a b. (a -> b) -> a -> b
$ [(Uri, [TextEdit])] -> Map Uri [TextEdit]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [(String -> Uri
filePathToUri (String -> Uri) -> String -> Uri
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
nfp,
                [TextEdit]
edits)])
                 Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
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
_) = (GadtPluginError -> PluginError)
-> ExceptT
     GadtPluginError
     (LspM Config)
     (MessageResult 'Method_TextDocumentCodeAction)
-> ExceptT
     PluginError
     (LspM Config)
     (MessageResult 'Method_TextDocumentCodeAction)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GadtPluginError -> PluginError
handleGhcidePluginError (ExceptT
   GadtPluginError
   (LspM Config)
   (MessageResult 'Method_TextDocumentCodeAction)
 -> ExceptT
      PluginError
      (LspM Config)
      (MessageResult 'Method_TextDocumentCodeAction))
-> ExceptT
     GadtPluginError
     (LspM Config)
     (MessageResult 'Method_TextDocumentCodeAction)
-> ExceptT
     PluginError
     (LspM Config)
     (MessageResult 'Method_TextDocumentCodeAction)
forall a b. (a -> b) -> a -> b
$ do
    NormalizedFilePath
nfp <- (PluginError -> GadtPluginError)
-> ExceptT PluginError (LspM Config) NormalizedFilePath
-> ExceptT GadtPluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> GadtPluginError
GhcidePluginErrors (ExceptT PluginError (LspM Config) NormalizedFilePath
 -> ExceptT GadtPluginError (LspM Config) NormalizedFilePath)
-> ExceptT PluginError (LspM Config) NormalizedFilePath
-> ExceptT GadtPluginError (LspM Config) NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (TextDocumentIdentifier
doc TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
L.uri)
    ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
inRangeH98Decls, [Extension]
_) <- IdeState
-> Range
-> NormalizedFilePath
-> ExceptT
     GadtPluginError (LspM Config) ([LTyClDecl GP], [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 = (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
 -> Command |? CodeAction)
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
-> [Command |? CodeAction]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Command |? CodeAction
mkAction (Text -> Command |? CodeAction)
-> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
    -> Text)
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
-> Command |? CodeAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN RdrName -> Text
forall a. Outputable a => a -> Text
printOutputable (GenLocated SrcSpanAnnN RdrName -> Text)
-> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
    -> GenLocated SrcSpanAnnN RdrName)
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl GP -> LIdP GP
TyClDecl GP -> GenLocated SrcSpanAnnN RdrName
forall pass. TyClDecl pass -> LIdP pass
tcdLName (TyClDecl GP -> GenLocated SrcSpanAnnN RdrName)
-> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
    -> TyClDecl GP)
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
-> GenLocated SrcSpanAnnN RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
-> TyClDecl GP
forall l e. GenLocated l e -> e
unLoc) [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
inRangeH98Decls
    ([Command |? CodeAction] |? Null)
-> ExceptT
     GadtPluginError (LspM Config) ([Command |? CodeAction] |? Null)
forall a. a -> ExceptT GadtPluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Command |? CodeAction] |? Null)
 -> ExceptT
      GadtPluginError (LspM Config) ([Command |? CodeAction] |? Null))
-> ([Command |? CodeAction] |? Null)
-> ExceptT
     GadtPluginError (LspM Config) ([Command |? CodeAction] |? Null)
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> [Command |? CodeAction] |? Null
forall a b. a -> a |? b
InL [Command |? CodeAction]
actions
    where
        mkAction :: T.Text -> Command |? CodeAction
        mkAction :: Text -> Command |? CodeAction
mkAction Text
name = CodeAction -> Command |? CodeAction
forall a b. b -> a |? b
InR CodeAction{Maybe Bool
Maybe [Diagnostic]
Maybe Value
Maybe WorkspaceEdit
Maybe (Rec (("reason" .== Text) .+ Empty))
Maybe (Rec ('R '["reason" ':-> Text]))
Maybe Command
Maybe CodeActionKind
Text
forall a. Maybe a
_title :: Text
_kind :: Maybe CodeActionKind
_diagnostics :: forall a. Maybe a
_isPreferred :: forall a. Maybe a
_disabled :: forall a. Maybe a
_edit :: forall a. Maybe a
_command :: Maybe Command
_data_ :: forall a. Maybe a
$sel:_command:CodeAction :: Maybe Command
$sel:_data_:CodeAction :: Maybe Value
$sel:_diagnostics:CodeAction :: Maybe [Diagnostic]
$sel:_disabled:CodeAction :: Maybe (Rec (("reason" .== Text) .+ Empty))
$sel:_edit:CodeAction :: Maybe WorkspaceEdit
$sel:_isPreferred:CodeAction :: Maybe Bool
$sel:_kind:CodeAction :: Maybe CodeActionKind
$sel:_title:CodeAction :: Text
..}
            where
                _title :: Text
_title = Text
"Convert \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" to GADT syntax"
                _kind :: Maybe CodeActionKind
_kind = CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
CodeActionKind_RefactorRewrite
                _diagnostics :: Maybe a
_diagnostics = Maybe a
forall a. Maybe a
Nothing
                _isPreferred :: Maybe a
_isPreferred = Maybe a
forall a. Maybe a
Nothing
                _disabled :: Maybe a
_disabled = Maybe a
forall a. Maybe a
Nothing
                _edit :: Maybe a
_edit = Maybe a
forall a. Maybe a
Nothing
                _command :: Maybe Command
_command = Command -> Maybe Command
forall a. a -> Maybe a
Just
                    (Command -> Maybe Command) -> Command -> Maybe Command
forall a b. (a -> b) -> a -> b
$ PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plId CommandId
toGADTSyntaxCommandId Text
_title ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [ToGADTParams -> Value
forall a. ToJSON a => a -> Value
toJSON ToGADTParams
mkParam])
                _data_ :: Maybe a
_data_ = Maybe a
forall a. Maybe a
Nothing

        mkParam :: ToGADTParams
mkParam = Uri -> Range -> ToGADTParams
ToGADTParams (TextDocumentIdentifier
doc TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
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 <- (PluginError -> GadtPluginError)
-> ExceptT PluginError m ParsedModule
-> ExceptT GadtPluginError m ParsedModule
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT PluginError -> GadtPluginError
GhcidePluginErrors
        (ExceptT PluginError m ParsedModule
 -> ExceptT GadtPluginError m ParsedModule)
-> ExceptT PluginError m ParsedModule
-> ExceptT GadtPluginError m ParsedModule
forall a b. (a -> b) -> a -> b
$ String
-> IdeState
-> ExceptT PluginError Action ParsedModule
-> ExceptT PluginError m ParsedModule
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"GADT.GetParsedModuleWithComments" IdeState
state
        (ExceptT PluginError Action ParsedModule
 -> ExceptT PluginError m ParsedModule)
-> ExceptT PluginError Action ParsedModule
-> ExceptT PluginError m ParsedModule
forall a b. (a -> b) -> a -> b
$ GetParsedModuleWithComments
-> NormalizedFilePath -> ExceptT PluginError Action ParsedModule
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 GP -> [LHsDecl GP]
HsModule GP
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)]
forall p. HsModule p -> [LHsDecl p]
hsmodDecls (HsModule GP
 -> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)])
-> GenLocated SrcSpan (HsModule GP)
-> GenLocated
     SrcSpan [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsedModule -> GenLocated SrcSpan (HsModule GP)
pm_parsed_source ParsedModule
pm
        decls :: [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
decls = (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)
 -> Bool)
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
forall a. (a -> Bool) -> [a] -> [a]
filter LTyClDecl GP -> Bool
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP) -> Bool
isH98DataDecl
            ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
 -> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)])
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
forall a b. (a -> b) -> a -> b
$ (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)
 -> Maybe
      (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)))
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)]
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LHsDecl GP -> Maybe (LTyClDecl GP)
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)
-> Maybe
     (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP))
getDataDecl
            ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)]
 -> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)])
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)]
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)]
forall a b. (a -> b) -> a -> b
$ (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP) -> Bool)
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)]
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Range
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsDecl GP) -> Bool
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
    ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)],
 [Extension])
-> ExceptT
     GadtPluginError
     m
     ([GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GP)],
      [Extension])
forall a. a -> ExceptT GadtPluginError m a
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 (Text -> PluginError) -> Text -> PluginError
forall a b. (a -> b) -> a -> b
$ Text
"Expected one declaration but found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
nums)
    GadtPluginError
FailedToFindDataDeclRange ->
        Text -> PluginError
PluginInternalError Text
"Unable to get data decl range"
    PrettyGadtError Text
errMsg ->
        Text -> PluginError
PluginInternalError Text
errMsg
    GhcidePluginErrors PluginError
errors ->
        PluginError
errors