{-# LANGUAGE DataKinds     #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies  #-}
{-# LANGUAGE TypeOperators #-}
module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where

import           Control.Lens                     ((^.))
import           Control.Monad.Except             (ExceptT)
import           Control.Monad.IO.Class           (MonadIO, liftIO)
import qualified Data.Map                         as Map
import           Data.Text                        (Text, unpack)
import qualified Data.Text                        as T
import           Development.IDE                  (GetParsedModule (GetParsedModule),
                                                   IdeState, RuleResult, Rules,
                                                   define, realSrcSpanToRange,
                                                   runAction, use)
import           Development.IDE.Core.PluginUtils
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           GHC.Generics                     (Generic)
import           Ide.Logger                       as Logger
import           Ide.Plugin.Conversion            (AlternateFormat,
                                                   ExtensionNeeded (NeedsExtension, NoExtension),
                                                   alternateFormat)
import           Ide.Plugin.Error
import           Ide.Plugin.Literals
import           Ide.Plugin.RangeMap              (RangeMap)
import qualified Ide.Plugin.RangeMap              as RangeMap
import           Ide.Types
import qualified Language.LSP.Protocol.Lens       as L
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types


newtype Log = LogShake Shake.Log deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> String
show :: Log -> String
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogShake Log
log -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> 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 = (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
pId Text
"Provides code actions to convert numeric literals to different formats")
    { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionHandler
    , pluginRules = collectLiteralsRule recorder
    }

data CollectLiterals = CollectLiterals
                     deriving (Int -> CollectLiterals -> ShowS
[CollectLiterals] -> ShowS
CollectLiterals -> String
(Int -> CollectLiterals -> ShowS)
-> (CollectLiterals -> String)
-> ([CollectLiterals] -> ShowS)
-> Show CollectLiterals
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CollectLiterals -> ShowS
showsPrec :: Int -> CollectLiterals -> ShowS
$cshow :: CollectLiterals -> String
show :: CollectLiterals -> String
$cshowList :: [CollectLiterals] -> ShowS
showList :: [CollectLiterals] -> ShowS
Show, CollectLiterals -> CollectLiterals -> Bool
(CollectLiterals -> CollectLiterals -> Bool)
-> (CollectLiterals -> CollectLiterals -> Bool)
-> Eq CollectLiterals
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CollectLiterals -> CollectLiterals -> Bool
== :: CollectLiterals -> CollectLiterals -> Bool
$c/= :: CollectLiterals -> CollectLiterals -> Bool
/= :: CollectLiterals -> CollectLiterals -> Bool
Eq, (forall x. CollectLiterals -> Rep CollectLiterals x)
-> (forall x. Rep CollectLiterals x -> CollectLiterals)
-> Generic CollectLiterals
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
$cfrom :: forall x. CollectLiterals -> Rep CollectLiterals x
from :: forall x. CollectLiterals -> Rep CollectLiterals x
$cto :: forall x. Rep CollectLiterals x -> CollectLiterals
to :: forall x. Rep CollectLiterals x -> CollectLiterals
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. CollectLiteralsResult -> Rep CollectLiteralsResult x)
-> (forall x. Rep CollectLiteralsResult x -> CollectLiteralsResult)
-> Generic CollectLiteralsResult
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
$cfrom :: forall x. CollectLiteralsResult -> Rep CollectLiteralsResult x
from :: forall x. CollectLiteralsResult -> Rep CollectLiteralsResult x
$cto :: forall x. Rep CollectLiteralsResult x -> CollectLiteralsResult
to :: forall x. Rep CollectLiteralsResult x -> CollectLiteralsResult
Generic)

newtype GhcExtension = GhcExtension { GhcExtension -> Extension
unExt :: Extension }

instance NFData GhcExtension where
    rnf :: GhcExtension -> ()
rnf GhcExtension
x = GhcExtension
x GhcExtension -> () -> ()
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 = Recorder (WithPriority Log)
-> (CollectLiterals
    -> NormalizedFilePath -> Action (IdeResult CollectLiteralsResult))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) ((CollectLiterals
  -> NormalizedFilePath -> Action (IdeResult CollectLiteralsResult))
 -> Rules ())
-> (CollectLiterals
    -> NormalizedFilePath -> Action (IdeResult CollectLiteralsResult))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \CollectLiterals
CollectLiterals NormalizedFilePath
nfp -> do
    Maybe ParsedModule
pm <- GetParsedModule
-> NormalizedFilePath -> Action (Maybe ParsedModule)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModule
GetParsedModule NormalizedFilePath
nfp
    -- get the current extensions active and transform them into FormatTypes
    let exts :: Maybe [GhcExtension]
exts = (Extension -> GhcExtension) -> [Extension] -> [GhcExtension]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> GhcExtension
GhcExtension ([Extension] -> [GhcExtension])
-> (ParsedModule -> [Extension]) -> ParsedModule -> [GhcExtension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> [Extension]
getExtensions (ParsedModule -> [GhcExtension])
-> Maybe ParsedModule -> Maybe [GhcExtension]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ParsedModule
pm
        -- collect all the literals for a file
        lits :: Maybe [Literal]
lits = ParsedSource -> [Literal]
forall ast. (Data ast, Typeable ast) => ast -> [Literal]
collectLiterals (ParsedSource -> [Literal])
-> (ParsedModule -> ParsedSource) -> ParsedModule -> [Literal]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ParsedSource
pm_parsed_source (ParsedModule -> [Literal])
-> Maybe ParsedModule -> Maybe [Literal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ParsedModule
pm
        litMap :: Maybe (RangeMap Literal)
litMap = (Literal -> Range) -> [Literal] -> RangeMap Literal
forall a. (a -> Range) -> [a] -> RangeMap a
RangeMap.fromList (RealSrcSpan -> Range
realSrcSpanToRange (RealSrcSpan -> Range)
-> (Literal -> RealSrcSpan) -> Literal -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> RealSrcSpan
getSrcSpan) ([Literal] -> RangeMap Literal)
-> Maybe [Literal] -> Maybe (RangeMap Literal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Literal]
lits
    IdeResult CollectLiteralsResult
-> Action (IdeResult CollectLiteralsResult)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], RangeMap Literal -> [GhcExtension] -> CollectLiteralsResult
CLR (RangeMap Literal -> [GhcExtension] -> CollectLiteralsResult)
-> Maybe (RangeMap Literal)
-> Maybe ([GhcExtension] -> CollectLiteralsResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RangeMap Literal)
litMap Maybe ([GhcExtension] -> CollectLiteralsResult)
-> Maybe [GhcExtension] -> Maybe CollectLiteralsResult
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [GhcExtension]
exts)

codeActionHandler :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionHandler :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionHandler IdeState
state PluginId
pId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
docId Range
currRange CodeActionContext
_) = do
    NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (TextDocumentIdentifier
docId 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)
    CLR{[GhcExtension]
RangeMap Literal
literals :: CollectLiteralsResult -> RangeMap Literal
enabledExtensions :: CollectLiteralsResult -> [GhcExtension]
literals :: RangeMap Literal
enabledExtensions :: [GhcExtension]
..} <- PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError (LspM Config) CollectLiteralsResult
forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError m CollectLiteralsResult
requestLiterals PluginId
pId IdeState
state NormalizedFilePath
nfp
    NextPragmaInfo
pragma <- 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
        -- remove any invalid literals (see validTarget comment)
    let litsInRange :: [Literal]
litsInRange = Range -> RangeMap Literal -> [Literal]
forall a. Range -> RangeMap a -> [a]
RangeMap.filterByRange Range
currRange RangeMap Literal
literals
        -- generate alternateFormats and zip with the literal that generated the alternates
        literalPairs :: [(Literal, [AlternateFormat])]
literalPairs = (Literal -> (Literal, [AlternateFormat]))
-> [Literal] -> [(Literal, [AlternateFormat])]
forall a b. (a -> b) -> [a] -> [b]
map (\Literal
lit -> (Literal
lit, Literal -> [AlternateFormat]
alternateFormat Literal
lit)) [Literal]
litsInRange
        -- make a code action for every literal and its' alternates (then flatten the result)
        actions :: [Command |? CodeAction]
actions = ((Literal, [AlternateFormat]) -> [Command |? CodeAction])
-> [(Literal, [AlternateFormat])] -> [Command |? CodeAction]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Literal
lit, [AlternateFormat]
alts) -> (AlternateFormat -> Command |? CodeAction)
-> [AlternateFormat] -> [Command |? CodeAction]
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
    ([Command |? CodeAction] |? Null)
-> ExceptT
     PluginError (LspM Config) ([Command |? CodeAction] |? Null)
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Command |? CodeAction] |? Null)
 -> ExceptT
      PluginError (LspM Config) ([Command |? CodeAction] |? Null))
-> ([Command |? CodeAction] |? Null)
-> ExceptT
     PluginError (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] -> [Command |? CodeAction] |? Null)
-> [Command |? CodeAction] -> [Command |? CodeAction] |? Null
forall a b. (a -> b) -> a -> b
$ [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) = CodeAction -> Command |? CodeAction
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 = CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just (CodeActionKind -> Maybe CodeActionKind)
-> CodeActionKind -> Maybe CodeActionKind
forall a b. (a -> b) -> a -> b
$ Text -> CodeActionKind
CodeActionKind_Custom Text
"quickfix.literals.style"
            , $sel:_diagnostics:CodeAction :: Maybe [Diagnostic]
_diagnostics = Maybe [Diagnostic]
forall a. Maybe a
Nothing
            , $sel:_isPreferred:CodeAction :: Maybe Bool
_isPreferred = Maybe Bool
forall a. Maybe a
Nothing
            , $sel:_disabled:CodeAction :: Maybe (Rec (("reason" .== Text) .+ Empty))
_disabled = Maybe (Rec (("reason" .== Text) .+ Empty))
Maybe (Rec ('R '["reason" ':-> Text]))
forall a. Maybe a
Nothing
            , $sel:_edit:CodeAction :: Maybe WorkspaceEdit
_edit = WorkspaceEdit -> Maybe WorkspaceEdit
forall a. a -> Maybe a
Just (WorkspaceEdit -> Maybe WorkspaceEdit)
-> WorkspaceEdit -> Maybe WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
mkWorkspaceEdit NormalizedFilePath
nfp [TextEdit]
edits
            , $sel:_command:CodeAction :: Maybe Command
_command = Maybe Command
forall a. Maybe a
Nothing
            , $sel:_data_:CodeAction :: Maybe Value
_data_ = Maybe Value
forall a. Maybe a
Nothing
            }
            where
                edits :: [TextEdit]
edits =  [Range -> Text -> TextEdit
TextEdit (RealSrcSpan -> Range
realSrcSpanToRange (RealSrcSpan -> Range) -> RealSrcSpan -> Range
forall a b. (a -> b) -> a -> b
$ Literal -> RealSrcSpan
getSrcSpan Literal
lit) Text
alt] [TextEdit] -> [TextEdit] -> [TextEdit]
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 (Map Uri [TextEdit])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit Maybe (Map Uri [TextEdit])
changes Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing
            where
                changes :: Maybe (Map Uri [TextEdit])
changes = Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a. a -> Maybe a
Just (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)]

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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (needs extension: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Extension -> String
forall a. Show a => a -> String
show Extension
ext') Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    | Bool
otherwise = Text
title
    where
        title :: Text
title = Text
"Convert " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Literal -> Text
getSrcText Literal
lit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" into " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
alt


-- | Checks whether the extension given is already enabled
needsExtension :: Extension -> [GhcExtension] -> Bool
needsExtension :: Extension -> [GhcExtension] -> Bool
needsExtension Extension
ext [GhcExtension]
ghcExts = Extension
ext Extension -> [Extension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (GhcExtension -> Extension) -> [GhcExtension] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map GhcExtension -> Extension
unExt [GhcExtension]
ghcExts

requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m CollectLiteralsResult
requestLiterals :: forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError m CollectLiteralsResult
requestLiterals (PluginId Text
pId) IdeState
state =
    String
-> IdeState
-> ExceptT PluginError Action CollectLiteralsResult
-> ExceptT PluginError m CollectLiteralsResult
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE (Text -> String
unpack Text
pId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".CollectLiterals") IdeState
state
    (ExceptT PluginError Action CollectLiteralsResult
 -> ExceptT PluginError m CollectLiteralsResult)
-> (NormalizedFilePath
    -> ExceptT PluginError Action CollectLiteralsResult)
-> NormalizedFilePath
-> ExceptT PluginError m CollectLiteralsResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CollectLiterals
-> NormalizedFilePath
-> ExceptT PluginError Action CollectLiteralsResult
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE CollectLiterals
CollectLiterals