{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where
import Control.Lens ((^.))
import Control.Monad.Except (ExceptT, MonadIO, liftIO)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text, unpack)
import qualified Data.Text as T
import Development.IDE (GetParsedModule (GetParsedModule),
IdeState, RuleResult, Rules,
define, realSrcSpanToRange,
runAction, use)
import qualified Development.IDE.Core.Shake as Shake
import Development.IDE.GHC.Compat hiding (getSrcSpan)
import Development.IDE.GHC.Util (getExtensions)
import Development.IDE.Graph.Classes (Hashable, NFData, rnf)
import Development.IDE.Spans.Pragmas (NextPragmaInfo, getFirstPragma,
insertNewPragma)
import Development.IDE.Types.Logger as Logger
import GHC.Generics (Generic)
import Ide.Plugin.Conversion (AlternateFormat,
ExtensionNeeded (NeedsExtension, NoExtension),
alternateFormat)
import Ide.Plugin.Literals
import Ide.Plugin.RangeMap (RangeMap)
import qualified Ide.Plugin.RangeMap as RangeMap
import Ide.PluginUtils (getNormalizedFilePath,
handleMaybeM, pluginResponse)
import Ide.Types
import Language.LSP.Types
import qualified Language.LSP.Types.Lens as L
newtype Log = LogShake Shake.Log deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> String
$cshow :: Log -> String
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show
instance Pretty Log where
pretty :: forall ann. Log -> Doc ann
pretty = \case
LogShake Log
log -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
pId = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
pId)
{ pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeAction
STextDocumentCodeAction PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionHandler
, pluginRules :: Rules ()
pluginRules = Recorder (WithPriority Log) -> Rules ()
collectLiteralsRule Recorder (WithPriority Log)
recorder
}
data CollectLiterals = CollectLiterals
deriving (Int -> CollectLiterals -> ShowS
[CollectLiterals] -> ShowS
CollectLiterals -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CollectLiterals] -> ShowS
$cshowList :: [CollectLiterals] -> ShowS
show :: CollectLiterals -> String
$cshow :: CollectLiterals -> String
showsPrec :: Int -> CollectLiterals -> ShowS
$cshowsPrec :: Int -> CollectLiterals -> ShowS
Show, CollectLiterals -> CollectLiterals -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CollectLiterals -> CollectLiterals -> Bool
$c/= :: CollectLiterals -> CollectLiterals -> Bool
== :: CollectLiterals -> CollectLiterals -> Bool
$c== :: CollectLiterals -> CollectLiterals -> Bool
Eq, forall x. Rep CollectLiterals x -> CollectLiterals
forall x. CollectLiterals -> Rep CollectLiterals x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CollectLiterals x -> CollectLiterals
$cfrom :: forall x. CollectLiterals -> Rep CollectLiterals x
Generic)
instance Hashable CollectLiterals
instance NFData CollectLiterals
type instance RuleResult CollectLiterals = CollectLiteralsResult
data CollectLiteralsResult = CLR
{ CollectLiteralsResult -> RangeMap Literal
literals :: RangeMap Literal
, CollectLiteralsResult -> [GhcExtension]
enabledExtensions :: [GhcExtension]
} deriving (forall x. Rep CollectLiteralsResult x -> CollectLiteralsResult
forall x. CollectLiteralsResult -> Rep CollectLiteralsResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CollectLiteralsResult x -> CollectLiteralsResult
$cfrom :: forall x. CollectLiteralsResult -> Rep CollectLiteralsResult x
Generic)
newtype GhcExtension = GhcExtension { GhcExtension -> Extension
unExt :: Extension }
instance NFData GhcExtension where
rnf :: GhcExtension -> ()
rnf GhcExtension
x = GhcExtension
x seq :: forall a b. a -> b -> b
`seq` ()
instance Show CollectLiteralsResult where
show :: CollectLiteralsResult -> String
show CollectLiteralsResult
_ = String
"<CollectLiteralResult>"
instance NFData CollectLiteralsResult
collectLiteralsRule :: Recorder (WithPriority Log) -> Rules ()
collectLiteralsRule :: Recorder (WithPriority Log) -> Rules ()
collectLiteralsRule Recorder (WithPriority Log)
recorder = forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \CollectLiterals
CollectLiterals NormalizedFilePath
nfp -> do
Maybe ParsedModule
pm <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModule
GetParsedModule NormalizedFilePath
nfp
let exts :: Maybe [GhcExtension]
exts = forall a b. (a -> b) -> [a] -> [b]
map Extension -> GhcExtension
GhcExtension forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> [Extension]
getExtensions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ParsedModule
pm
lits :: Maybe [Literal]
lits = forall ast. (Data ast, Typeable ast) => ast -> [Literal]
collectLiterals forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ParsedSource
pm_parsed_source forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ParsedModule
pm
litMap :: Maybe (RangeMap Literal)
litMap = forall a. (a -> Range) -> [a] -> RangeMap a
RangeMap.fromList (RealSrcSpan -> Range
realSrcSpanToRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> RealSrcSpan
getSrcSpan) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Literal]
lits
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], RangeMap Literal -> [GhcExtension] -> CollectLiteralsResult
CLR forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RangeMap Literal)
litMap forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [GhcExtension]
exts)
codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionHandler IdeState
state PluginId
pId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
docId Range
currRange 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
docId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri)
CLR{[GhcExtension]
RangeMap Literal
enabledExtensions :: [GhcExtension]
literals :: RangeMap Literal
enabledExtensions :: CollectLiteralsResult -> [GhcExtension]
literals :: CollectLiteralsResult -> RangeMap Literal
..} <- forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT String m CollectLiteralsResult
requestLiterals PluginId
pId IdeState
state NormalizedFilePath
nfp
NextPragmaInfo
pragma <- forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT String m NextPragmaInfo
getFirstPragma PluginId
pId IdeState
state NormalizedFilePath
nfp
let litsInRange :: [Literal]
litsInRange = forall a. Range -> RangeMap a -> [a]
RangeMap.filterByRange Range
currRange RangeMap Literal
literals
literalPairs :: [(Literal, [AlternateFormat])]
literalPairs = forall a b. (a -> b) -> [a] -> [b]
map (\Literal
lit -> (Literal
lit, Literal -> [AlternateFormat]
alternateFormat Literal
lit)) [Literal]
litsInRange
actions :: [Command |? CodeAction]
actions = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Literal
lit, [AlternateFormat]
alts) -> forall a b. (a -> b) -> [a] -> [b]
map (NormalizedFilePath
-> Literal
-> [GhcExtension]
-> NextPragmaInfo
-> AlternateFormat
-> Command |? CodeAction
mkCodeAction NormalizedFilePath
nfp Literal
lit [GhcExtension]
enabledExtensions NextPragmaInfo
pragma) [AlternateFormat]
alts) [(Literal, [AlternateFormat])]
literalPairs
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
mkCodeAction :: NormalizedFilePath -> Literal -> [GhcExtension] -> NextPragmaInfo -> AlternateFormat -> Command |? CodeAction
mkCodeAction :: NormalizedFilePath
-> Literal
-> [GhcExtension]
-> NextPragmaInfo
-> AlternateFormat
-> Command |? CodeAction
mkCodeAction NormalizedFilePath
nfp Literal
lit [GhcExtension]
enabled NextPragmaInfo
npi af :: AlternateFormat
af@(Text
alt, ExtensionNeeded
ext) = forall a b. b -> a |? b
InR CodeAction {
$sel:_title:CodeAction :: Text
_title = Literal -> AlternateFormat -> [GhcExtension] -> Text
mkCodeActionTitle Literal
lit AlternateFormat
af [GhcExtension]
enabled
, $sel:_kind:CodeAction :: Maybe CodeActionKind
_kind = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> CodeActionKind
CodeActionUnknown Text
"quickfix.literals.style"
, $sel:_diagnostics:CodeAction :: Maybe (List Diagnostic)
_diagnostics = forall a. Maybe a
Nothing
, $sel:_isPreferred:CodeAction :: Maybe Bool
_isPreferred = forall a. Maybe a
Nothing
, $sel:_disabled:CodeAction :: Maybe Reason
_disabled = forall a. Maybe a
Nothing
, $sel:_edit:CodeAction :: Maybe WorkspaceEdit
_edit = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
mkWorkspaceEdit NormalizedFilePath
nfp [TextEdit]
edits
, $sel:_command:CodeAction :: Maybe Command
_command = forall a. Maybe a
Nothing
, $sel:_xdata:CodeAction :: Maybe Value
_xdata = forall a. Maybe a
Nothing
}
where
edits :: [TextEdit]
edits = [Range -> Text -> TextEdit
TextEdit (RealSrcSpan -> Range
realSrcSpanToRange forall a b. (a -> b) -> a -> b
$ Literal -> RealSrcSpan
getSrcSpan Literal
lit) Text
alt] forall a. Semigroup a => a -> a -> a
<> [TextEdit]
pragmaEdit
pragmaEdit :: [TextEdit]
pragmaEdit = case ExtensionNeeded
ext of
NeedsExtension Extension
ext' -> [NextPragmaInfo -> Extension -> TextEdit
insertNewPragma NextPragmaInfo
npi Extension
ext' | Extension -> [GhcExtension] -> Bool
needsExtension Extension
ext' [GhcExtension]
enabled]
ExtensionNeeded
NoExtension -> []
mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
mkWorkspaceEdit NormalizedFilePath
nfp [TextEdit]
edits = Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit Maybe WorkspaceEditMap
changes forall a. Maybe a
Nothing forall a. Maybe a
Nothing
where
changes :: Maybe WorkspaceEditMap
changes = forall a. a -> Maybe a
Just 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)]
mkCodeActionTitle :: Literal -> AlternateFormat -> [GhcExtension] -> Text
mkCodeActionTitle :: Literal -> AlternateFormat -> [GhcExtension] -> Text
mkCodeActionTitle Literal
lit (Text
alt, ExtensionNeeded
ext) [GhcExtension]
ghcExts
| (NeedsExtension Extension
ext') <- ExtensionNeeded
ext
, Extension -> [GhcExtension] -> Bool
needsExtension Extension
ext' [GhcExtension]
ghcExts = Text
title forall a. Semigroup a => a -> a -> a
<> Text
" (needs extension: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Extension
ext') forall a. Semigroup a => a -> a -> a
<> Text
")"
| Bool
otherwise = Text
title
where
title :: Text
title = Text
"Convert " forall a. Semigroup a => a -> a -> a
<> Literal -> Text
getSrcText Literal
lit forall a. Semigroup a => a -> a -> a
<> Text
" into " forall a. Semigroup a => a -> a -> a
<> Text
alt
needsExtension :: Extension -> [GhcExtension] -> Bool
needsExtension :: Extension -> [GhcExtension] -> Bool
needsExtension Extension
ext [GhcExtension]
ghcExts = Extension
ext forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a b. (a -> b) -> [a] -> [b]
map GhcExtension -> Extension
unExt [GhcExtension]
ghcExts
requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m CollectLiteralsResult
requestLiterals :: forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT String m CollectLiteralsResult
requestLiterals (PluginId Text
pId) IdeState
state = forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"Could not Collect Literals"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> IdeState -> Action a -> IO a
runAction (Text -> String
unpack Text
pId forall a. Semigroup a => a -> a -> a
<> String
".CollectLiterals") IdeState
state
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use CollectLiterals
CollectLiterals