{-# LANGUAGE CPP               #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE ViewPatterns      #-}
module Ide.Plugin.OverloadedRecordDot
  ( descriptor
  , Log
  ) where

-- based off of Berk Okzuturk's hls-explicit-records-fields-plugin

import           Control.Lens                         ((^.))
import           Control.Monad                        (replicateM)
import           Control.Monad.IO.Class               (MonadIO, liftIO)
import           Control.Monad.Trans.Except           (ExceptT)
import           Data.Aeson                           (FromJSON, ToJSON, toJSON)
import           Data.Generics                        (GenericQ, everythingBut,
                                                       mkQ)
import qualified Data.IntMap.Strict                   as IntMap
import qualified Data.Map                             as Map
import           Data.Maybe                           (mapMaybe, maybeToList)
import           Data.Text                            (Text)
import           Data.Unique                          (hashUnique, newUnique)
import           Development.IDE                      (IdeState,
                                                       NormalizedFilePath,
                                                       Pretty (..), Range,
                                                       Recorder (..), Rules,
                                                       WithPriority (..),
                                                       realSrcSpanToRange)
import           Development.IDE.Core.RuleTypes       (TcModuleResult (..),
                                                       TypeCheck (..))
import           Development.IDE.Core.Shake           (define, useWithStale)
import qualified Development.IDE.Core.Shake           as Shake

#if __GLASGOW_HASKELL__ >= 903
import           Development.IDE.GHC.Compat           (HsExpr (HsRecSel))
#else
import           Development.IDE.GHC.Compat           (HsExpr (HsRecFld))
#endif

import           Control.DeepSeq                      (rwhnf)
import           Development.IDE.Core.PluginUtils
import           Development.IDE.Core.PositionMapping (PositionMapping,
                                                       toCurrentRange)
import           Development.IDE.GHC.Compat           (Extension (OverloadedRecordDot),
                                                       GhcPass,
                                                       HsExpansion (HsExpanded),
                                                       HsExpr (HsApp, HsVar, OpApp, XExpr),
                                                       LHsExpr, Pass (..),
                                                       appPrec, dollarName,
                                                       getLoc, hs_valds,
                                                       parenthesizeHsExpr,
                                                       pattern RealSrcSpan,
                                                       unLoc)
import           Development.IDE.GHC.Util             (getExtensions,
                                                       printOutputable)
import           Development.IDE.Graph                (RuleResult)
import           Development.IDE.Graph.Classes        (Hashable, NFData (rnf))
import           Development.IDE.Spans.Pragmas        (NextPragmaInfo (..),
                                                       getFirstPragma,
                                                       insertNewPragma)
import           GHC.Generics                         (Generic)
import           Ide.Logger                           (Priority (..),
                                                       cmapWithPrio, logWith,
                                                       (<+>))
import           Ide.Plugin.Error                     (PluginError (..),
                                                       getNormalizedFilePathE,
                                                       handleMaybe)
import           Ide.Plugin.RangeMap                  (RangeMap)
import qualified Ide.Plugin.RangeMap                  as RangeMap
import           Ide.Plugin.Resolve                   (mkCodeActionHandlerWithResolve)
import           Ide.Types                            (PluginDescriptor (..),
                                                       PluginId (..),
                                                       PluginMethodHandler,
                                                       ResolveFunction,
                                                       defaultPluginDescriptor)
import qualified Language.LSP.Protocol.Lens           as L
import           Language.LSP.Protocol.Message        (Method (..))
import           Language.LSP.Protocol.Types          (CodeAction (..),
                                                       CodeActionKind (CodeActionKind_RefactorRewrite),
                                                       CodeActionParams (..),
                                                       TextEdit (..), Uri (..),
                                                       WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),
                                                       type (|?) (..))

data Log
    = LogShake Shake.Log
    | LogCollectedRecordSelectors [RecordSelectorExpr]
    | forall a. (Pretty a) => LogResolve a

instance Pretty Log where
    pretty :: forall ann. Log -> Doc ann
pretty = \case
        LogShake Log
shakeLog -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
shakeLog
        LogCollectedRecordSelectors [RecordSelectorExpr]
recs -> Doc ann
"Collected record selectors:"
                                                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [RecordSelectorExpr] -> Doc ann
forall ann. [RecordSelectorExpr] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [RecordSelectorExpr]
recs
        LogResolve a
msg -> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
msg

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

instance Hashable CollectRecordSelectors
instance NFData CollectRecordSelectors

data CollectRecordSelectorsResult = CRSR
    { -- |We store everything in here that we need to create the unresolved
      -- codeAction: the range, an uniquely identifiable int, and the selector
      --selector expression  (HSExpr) that we use to generate the name
      CollectRecordSelectorsResult -> RangeMap (Int, HsExpr GhcRn)
records           :: RangeMap (Int, HsExpr (GhcPass 'Renamed))
      -- |This is for when we need to fully generate a textEdit. It contains the
      -- whole expression we are interested in indexed to the unique id we got
      -- from the previous field
    , CollectRecordSelectorsResult -> IntMap RecordSelectorExpr
recordInfos       :: IntMap.IntMap RecordSelectorExpr
    , CollectRecordSelectorsResult -> [Extension]
enabledExtensions :: [Extension]
    }
    deriving ((forall x.
 CollectRecordSelectorsResult -> Rep CollectRecordSelectorsResult x)
-> (forall x.
    Rep CollectRecordSelectorsResult x -> CollectRecordSelectorsResult)
-> Generic CollectRecordSelectorsResult
forall x.
Rep CollectRecordSelectorsResult x -> CollectRecordSelectorsResult
forall x.
CollectRecordSelectorsResult -> Rep CollectRecordSelectorsResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
CollectRecordSelectorsResult -> Rep CollectRecordSelectorsResult x
from :: forall x.
CollectRecordSelectorsResult -> Rep CollectRecordSelectorsResult x
$cto :: forall x.
Rep CollectRecordSelectorsResult x -> CollectRecordSelectorsResult
to :: forall x.
Rep CollectRecordSelectorsResult x -> CollectRecordSelectorsResult
Generic)

instance NFData CollectRecordSelectorsResult

instance Show CollectRecordSelectorsResult where
    show :: CollectRecordSelectorsResult -> String
show CollectRecordSelectorsResult
_ = String
"<CollectRecordsResult>"

type instance RuleResult CollectRecordSelectors = CollectRecordSelectorsResult

-- |Where we store our collected record selectors
data RecordSelectorExpr = RecordSelectorExpr
    { -- |The location of the matched expression
    RecordSelectorExpr -> Range
location     :: Range,
    -- |The record selector, this is found in front of recordExpr, but get's
    -- placed after it when converted into record dot syntax
    RecordSelectorExpr -> LHsExpr GhcRn
selectorExpr :: LHsExpr (GhcPass 'Renamed),
    -- |The record expression. The only requirement is that it evaluates to a
    -- record in the end
    RecordSelectorExpr -> LHsExpr GhcRn
recordExpr   :: LHsExpr (GhcPass 'Renamed) }

instance Pretty RecordSelectorExpr where
    pretty :: forall ann. RecordSelectorExpr -> Doc ann
pretty (RecordSelectorExpr Range
_ LHsExpr GhcRn
rs LHsExpr GhcRn
se) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Text
forall a. Outputable a => a -> Text
printOutputable LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
rs) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":"
                                            Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Text
forall a. Outputable a => a -> Text
printOutputable LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
se)

instance NFData RecordSelectorExpr where
  rnf :: RecordSelectorExpr -> ()
rnf = RecordSelectorExpr -> ()
forall a. a -> ()
rwhnf

-- |The data that is serialized and placed in the data field of resolvable
-- code actions
data ORDResolveData = ORDRD {
  -- |We need the uri to get shake results
  ORDResolveData -> Uri
uri      :: Uri
  -- |The unique id that allows us to find the specific codeAction we want
, ORDResolveData -> Int
uniqueID :: Int
} deriving ((forall x. ORDResolveData -> Rep ORDResolveData x)
-> (forall x. Rep ORDResolveData x -> ORDResolveData)
-> Generic ORDResolveData
forall x. Rep ORDResolveData x -> ORDResolveData
forall x. ORDResolveData -> Rep ORDResolveData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ORDResolveData -> Rep ORDResolveData x
from :: forall x. ORDResolveData -> Rep ORDResolveData x
$cto :: forall x. Rep ORDResolveData x -> ORDResolveData
to :: forall x. Rep ORDResolveData x -> ORDResolveData
Generic, Int -> ORDResolveData -> ShowS
[ORDResolveData] -> ShowS
ORDResolveData -> String
(Int -> ORDResolveData -> ShowS)
-> (ORDResolveData -> String)
-> ([ORDResolveData] -> ShowS)
-> Show ORDResolveData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ORDResolveData -> ShowS
showsPrec :: Int -> ORDResolveData -> ShowS
$cshow :: ORDResolveData -> String
show :: ORDResolveData -> String
$cshowList :: [ORDResolveData] -> ShowS
showList :: [ORDResolveData] -> ShowS
Show)
instance ToJSON ORDResolveData
instance FromJSON ORDResolveData

descriptor :: Recorder (WithPriority Log) -> PluginId
                -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId =
  let resolveRecorder :: Recorder (WithPriority Log)
resolveRecorder = (Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
forall a. Pretty a => a -> Log
LogResolve Recorder (WithPriority Log)
recorder
      pluginHandler :: PluginHandlers IdeState
pluginHandler = Recorder (WithPriority Log)
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
-> ResolveFunction
     IdeState ORDResolveData 'Method_CodeActionResolve
-> PluginHandlers IdeState
forall ideState a.
FromJSON a =>
Recorder (WithPriority Log)
-> PluginMethodHandler ideState 'Method_TextDocumentCodeAction
-> ResolveFunction ideState a 'Method_CodeActionResolve
-> PluginHandlers ideState
mkCodeActionHandlerWithResolve Recorder (WithPriority Log)
resolveRecorder PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionProvider ResolveFunction IdeState ORDResolveData 'Method_CodeActionResolve
resolveProvider
  in (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
"Provides a code action to convert record selector usage to use overloaded record dot syntax")
    { pluginHandlers = pluginHandler
    , pluginRules = collectRecSelsRule recorder
    }

resolveProvider :: ResolveFunction IdeState ORDResolveData 'Method_CodeActionResolve
resolveProvider :: ResolveFunction IdeState ORDResolveData 'Method_CodeActionResolve
resolveProvider IdeState
ideState PluginId
plId MessageParams 'Method_CodeActionResolve
ca Uri
uri (ORDRD Uri
_ Int
int) =
  do
    NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
    CRSR RangeMap (Int, HsExpr GhcRn)
_ IntMap RecordSelectorExpr
crsDetails [Extension]
exts <- IdeState
-> NormalizedFilePath
-> ExceptT PluginError (LspM Config) CollectRecordSelectorsResult
forall (m :: * -> *).
MonadIO m =>
IdeState
-> NormalizedFilePath
-> ExceptT PluginError m CollectRecordSelectorsResult
collectRecSelResult IdeState
ideState 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
plId IdeState
ideState NormalizedFilePath
nfp
    RecordSelectorExpr
rse <- PluginError
-> Maybe RecordSelectorExpr
-> ExceptT PluginError (LspM Config) RecordSelectorExpr
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe PluginError
PluginStaleResolve (Maybe RecordSelectorExpr
 -> ExceptT PluginError (LspM Config) RecordSelectorExpr)
-> Maybe RecordSelectorExpr
-> ExceptT PluginError (LspM Config) RecordSelectorExpr
forall a b. (a -> b) -> a -> b
$ Int -> IntMap RecordSelectorExpr -> Maybe RecordSelectorExpr
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
int IntMap RecordSelectorExpr
crsDetails
    CodeAction -> ExceptT PluginError (LspM Config) CodeAction
forall a. a -> ExceptT PluginError (LspM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeAction -> ExceptT PluginError (LspM Config) CodeAction)
-> CodeAction -> ExceptT PluginError (LspM Config) CodeAction
forall a b. (a -> b) -> a -> b
$ MessageParams 'Method_CodeActionResolve
ca {_edit = mkWorkspaceEdit uri rse exts pragma}

codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionProvider IdeState
ideState PluginId
_ (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
caDocId Range
caRange CodeActionContext
_) =
    do
        NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (TextDocumentIdentifier
caDocId 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)
        CRSR RangeMap (Int, HsExpr GhcRn)
crsMap IntMap RecordSelectorExpr
_ [Extension]
exts <- IdeState
-> NormalizedFilePath
-> ExceptT PluginError (LspM Config) CollectRecordSelectorsResult
forall (m :: * -> *).
MonadIO m =>
IdeState
-> NormalizedFilePath
-> ExceptT PluginError m CollectRecordSelectorsResult
collectRecSelResult IdeState
ideState NormalizedFilePath
nfp
        let mkCodeAction :: (Int, HsExpr GhcRn) -> Command |? CodeAction
mkCodeAction (Int
crsM, HsExpr GhcRn
nse)  = CodeAction -> Command |? CodeAction
forall a b. b -> a |? b
InR CodeAction
                { -- We pass the record selector to the title function, so that
                  -- we can have the name of the record selector in the title of
                  -- the codeAction. This allows the user can easily distinguish
                  -- between the different codeActions when using nested record
                  -- selectors, the disadvantage is we need to print out the
                  -- name of the record selector which will decrease performance
                  $sel:_title:CodeAction :: Text
_title = [Extension] -> HsExpr GhcRn -> Text
mkCodeActionTitle [Extension]
exts HsExpr GhcRn
nse
                , $sel:_kind:CodeAction :: Maybe CodeActionKind
_kind = CodeActionKind -> Maybe CodeActionKind
forall a. a -> Maybe a
Just CodeActionKind
CodeActionKind_RefactorRewrite
                , $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 = Maybe WorkspaceEdit
forall a. Maybe a
Nothing
                , $sel:_command:CodeAction :: Maybe Command
_command = Maybe Command
forall a. Maybe a
Nothing
                , $sel:_data_:CodeAction :: Maybe Value
_data_ = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ORDResolveData -> Value
forall a. ToJSON a => a -> Value
toJSON (ORDResolveData -> Value) -> ORDResolveData -> Value
forall a b. (a -> b) -> a -> b
$ Uri -> Int -> ORDResolveData
ORDRD (TextDocumentIdentifier
caDocId 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) Int
crsM
                }
            actions :: [Command |? CodeAction]
actions = ((Int, HsExpr GhcRn) -> Command |? CodeAction)
-> [(Int, HsExpr GhcRn)] -> [Command |? CodeAction]
forall a b. (a -> b) -> [a] -> [b]
map (Int, HsExpr GhcRn) -> Command |? CodeAction
mkCodeAction (Range -> RangeMap (Int, HsExpr GhcRn) -> [(Int, HsExpr GhcRn)]
forall a. Range -> RangeMap a -> [a]
RangeMap.filterByRange Range
caRange RangeMap (Int, HsExpr GhcRn)
crsMap)
        ([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]
actions
    where
    mkCodeActionTitle :: [Extension] -> HsExpr (GhcPass 'Renamed) -> Text
    mkCodeActionTitle :: [Extension] -> HsExpr GhcRn -> Text
mkCodeActionTitle [Extension]
exts HsExpr GhcRn
se =
        if Extension
OverloadedRecordDot Extension -> [Extension] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Extension]
exts
            then Text
title
            else Text
title Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (needs extension: OverloadedRecordDot)"
        where
            title :: Text
title = Text
"Convert `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HsExpr GhcRn -> Text
forall a. Outputable a => a -> Text
printOutputable HsExpr GhcRn
se Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` to record dot syntax"

mkWorkspaceEdit:: Uri -> RecordSelectorExpr -> [Extension] -> NextPragmaInfo-> Maybe WorkspaceEdit
mkWorkspaceEdit :: Uri
-> RecordSelectorExpr
-> [Extension]
-> NextPragmaInfo
-> Maybe WorkspaceEdit
mkWorkspaceEdit Uri
uri RecordSelectorExpr
recSel [Extension]
exts NextPragmaInfo
pragma =
    WorkspaceEdit -> Maybe WorkspaceEdit
forall a. a -> Maybe a
Just (WorkspaceEdit -> Maybe WorkspaceEdit)
-> WorkspaceEdit -> Maybe WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ WorkspaceEdit
    { $sel:_changes:WorkspaceEdit :: Maybe (Map Uri [TextEdit])
_changes =
        Map Uri [TextEdit] -> Maybe (Map Uri [TextEdit])
forall a. a -> Maybe a
Just (Uri -> [TextEdit] -> Map Uri [TextEdit]
forall k a. k -> a -> Map k a
Map.singleton Uri
uri (RecordSelectorExpr -> TextEdit
convertRecordSelectors RecordSelectorExpr
recSel TextEdit -> [TextEdit] -> [TextEdit]
forall a. a -> [a] -> [a]
: Maybe TextEdit -> [TextEdit]
forall a. Maybe a -> [a]
maybeToList Maybe TextEdit
pragmaEdit))
    , $sel:_documentChanges:WorkspaceEdit :: Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
_documentChanges = Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing
    , $sel:_changeAnnotations:WorkspaceEdit :: Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
_changeAnnotations = Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing}
    where pragmaEdit :: Maybe TextEdit
pragmaEdit =
            if Extension
OverloadedRecordDot Extension -> [Extension] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Extension]
exts
            then Maybe TextEdit
forall a. Maybe a
Nothing
            else TextEdit -> Maybe TextEdit
forall a. a -> Maybe a
Just (TextEdit -> Maybe TextEdit) -> TextEdit -> Maybe TextEdit
forall a b. (a -> b) -> a -> b
$ NextPragmaInfo -> Extension -> TextEdit
insertNewPragma NextPragmaInfo
pragma Extension
OverloadedRecordDot

collectRecSelsRule :: Recorder (WithPriority Log) -> Rules ()
collectRecSelsRule :: Recorder (WithPriority Log) -> Rules ()
collectRecSelsRule Recorder (WithPriority Log)
recorder = Recorder (WithPriority Log)
-> (CollectRecordSelectors
    -> NormalizedFilePath
    -> Action (IdeResult CollectRecordSelectorsResult))
-> 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) ((CollectRecordSelectors
  -> NormalizedFilePath
  -> Action (IdeResult CollectRecordSelectorsResult))
 -> Rules ())
-> (CollectRecordSelectors
    -> NormalizedFilePath
    -> Action (IdeResult CollectRecordSelectorsResult))
-> Rules ()
forall a b. (a -> b) -> a -> b
$
    \CollectRecordSelectors
CollectRecordSelectors NormalizedFilePath
nfp ->
        TypeCheck
-> NormalizedFilePath
-> Action (Maybe (TcModuleResult, PositionMapping))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
useWithStale TypeCheck
TypeCheck NormalizedFilePath
nfp Action (Maybe (TcModuleResult, PositionMapping))
-> (Maybe (TcModuleResult, PositionMapping)
    -> Action (IdeResult CollectRecordSelectorsResult))
-> Action (IdeResult CollectRecordSelectorsResult)
forall a b. Action a -> (a -> Action b) -> Action b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- `useWithStale` here allows us to be able to return codeActions even
        -- if the file does not typecheck. The disadvantage being that we
        -- sometimes will end up corrupting code. This is most obvious in that
        -- used code actions will continue to be presented, and when applied
        -- multiple times will almost always cause code corruption.
        Maybe (TcModuleResult, PositionMapping)
Nothing -> IdeResult CollectRecordSelectorsResult
-> Action (IdeResult CollectRecordSelectorsResult)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe CollectRecordSelectorsResult
forall a. Maybe a
Nothing)
        Just (TcModuleResult
tmr, PositionMapping
pm) -> do
            let -- We need the file's extensions to check whether we need to add
                -- the OverloadedRecordDot pragma
                exts :: [Extension]
exts = TcModuleResult -> [Extension]
getEnabledExtensions TcModuleResult
tmr
                recSels :: [RecordSelectorExpr]
recSels = (RecordSelectorExpr -> Maybe RecordSelectorExpr)
-> [RecordSelectorExpr] -> [RecordSelectorExpr]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PositionMapping -> RecordSelectorExpr -> Maybe RecordSelectorExpr
rewriteRange PositionMapping
pm) (TcModuleResult -> [RecordSelectorExpr]
getRecordSelectors TcModuleResult
tmr)
            -- We are creating a list as long as our rec selectors of unique int s
            -- created by calling hashUnique on a Unique. The reason why we are
            -- extracting the ints is because they don't need any work to serialize.
            [Int]
uniques <- IO [Int] -> Action [Int]
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Int] -> Action [Int]) -> IO [Int] -> Action [Int]
forall a b. (a -> b) -> a -> b
$ Int -> IO Int -> IO [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([RecordSelectorExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RecordSelectorExpr]
recSels) (Unique -> Int
hashUnique (Unique -> Int) -> IO Unique -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique)
            Recorder (WithPriority Log) -> Priority -> Log -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug ([RecordSelectorExpr] -> Log
LogCollectedRecordSelectors [RecordSelectorExpr]
recSels)
            let crsUniquesAndDetails :: [(Int, RecordSelectorExpr)]
crsUniquesAndDetails =  [Int] -> [RecordSelectorExpr] -> [(Int, RecordSelectorExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
uniques [RecordSelectorExpr]
recSels
                -- We need the rangeMap to be able to filter by range later
                rangeAndUnique :: [(Range, (Int, HsExpr GhcRn))]
rangeAndUnique = (Int, RecordSelectorExpr) -> (Range, (Int, HsExpr GhcRn))
forall {a}. (a, RecordSelectorExpr) -> (Range, (a, HsExpr GhcRn))
toRangeAndUnique ((Int, RecordSelectorExpr) -> (Range, (Int, HsExpr GhcRn)))
-> [(Int, RecordSelectorExpr)] -> [(Range, (Int, HsExpr GhcRn))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, RecordSelectorExpr)]
crsUniquesAndDetails
                crsMap :: RangeMap (Int,  HsExpr (GhcPass 'Renamed))
                crsMap :: RangeMap (Int, HsExpr GhcRn)
crsMap = [(Range, (Int, HsExpr GhcRn))] -> RangeMap (Int, HsExpr GhcRn)
forall a. [(Range, a)] -> RangeMap a
RangeMap.fromList' [(Range, (Int, HsExpr GhcRn))]
rangeAndUnique
            IdeResult CollectRecordSelectorsResult
-> Action (IdeResult CollectRecordSelectorsResult)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], RangeMap (Int, HsExpr GhcRn)
-> IntMap RecordSelectorExpr
-> [Extension]
-> CollectRecordSelectorsResult
CRSR (RangeMap (Int, HsExpr GhcRn)
 -> IntMap RecordSelectorExpr
 -> [Extension]
 -> CollectRecordSelectorsResult)
-> Maybe (RangeMap (Int, HsExpr GhcRn))
-> Maybe
     (IntMap RecordSelectorExpr
      -> [Extension] -> CollectRecordSelectorsResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RangeMap (Int, HsExpr GhcRn)
-> Maybe (RangeMap (Int, HsExpr GhcRn))
forall a. a -> Maybe a
Just RangeMap (Int, HsExpr GhcRn)
crsMap Maybe
  (IntMap RecordSelectorExpr
   -> [Extension] -> CollectRecordSelectorsResult)
-> Maybe (IntMap RecordSelectorExpr)
-> Maybe ([Extension] -> CollectRecordSelectorsResult)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IntMap RecordSelectorExpr -> Maybe (IntMap RecordSelectorExpr)
forall a. a -> Maybe a
Just ([(Int, RecordSelectorExpr)] -> IntMap RecordSelectorExpr
forall a. [(Int, a)] -> IntMap a
IntMap.fromList [(Int, RecordSelectorExpr)]
crsUniquesAndDetails) Maybe ([Extension] -> CollectRecordSelectorsResult)
-> Maybe [Extension] -> Maybe CollectRecordSelectorsResult
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Extension] -> Maybe [Extension]
forall a. a -> Maybe a
Just [Extension]
exts)
    where getEnabledExtensions :: TcModuleResult -> [Extension]
          getEnabledExtensions :: TcModuleResult -> [Extension]
getEnabledExtensions = ParsedModule -> [Extension]
getExtensions (ParsedModule -> [Extension])
-> (TcModuleResult -> ParsedModule)
-> TcModuleResult
-> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcModuleResult -> ParsedModule
tmrParsed
          getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr]
          getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr]
getRecordSelectors (TcModuleResult -> RenamedSource
tmrRenamed -> (HsGroup GhcRn -> HsValBinds GhcRn
forall p. HsGroup p -> HsValBinds p
hs_valds -> HsValBinds GhcRn
valBinds,[LImportDecl GhcRn]
_,Maybe [(LIE GhcRn, Avails)]
_,Maybe (LHsDoc GhcRn)
_)) =
            HsValBinds GhcRn -> [RecordSelectorExpr]
GenericQ [RecordSelectorExpr]
collectRecordSelectors HsValBinds GhcRn
valBinds
          rewriteRange :: PositionMapping -> RecordSelectorExpr
                            -> Maybe RecordSelectorExpr
          rewriteRange :: PositionMapping -> RecordSelectorExpr -> Maybe RecordSelectorExpr
rewriteRange PositionMapping
pm RecordSelectorExpr
recSel =
            case PositionMapping -> Range -> Maybe Range
toCurrentRange PositionMapping
pm (RecordSelectorExpr -> Range
location RecordSelectorExpr
recSel) of
                Just Range
newLoc -> RecordSelectorExpr -> Maybe RecordSelectorExpr
forall a. a -> Maybe a
Just (RecordSelectorExpr -> Maybe RecordSelectorExpr)
-> RecordSelectorExpr -> Maybe RecordSelectorExpr
forall a b. (a -> b) -> a -> b
$ RecordSelectorExpr
recSel{location = newLoc}
                Maybe Range
Nothing     -> Maybe RecordSelectorExpr
forall a. Maybe a
Nothing
          toRangeAndUnique :: (a, RecordSelectorExpr) -> (Range, (a, HsExpr GhcRn))
toRangeAndUnique (a
uid, RecordSelectorExpr Range
l (LHsExpr GhcRn -> HsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc -> HsExpr GhcRn
se) LHsExpr GhcRn
_) = (Range
l, (a
uid, HsExpr GhcRn
se))

convertRecordSelectors :: RecordSelectorExpr ->  TextEdit
convertRecordSelectors :: RecordSelectorExpr -> TextEdit
convertRecordSelectors RecordSelectorExpr{LHsExpr GhcRn
Range
location :: RecordSelectorExpr -> Range
selectorExpr :: RecordSelectorExpr -> LHsExpr GhcRn
recordExpr :: RecordSelectorExpr -> LHsExpr GhcRn
location :: Range
selectorExpr :: LHsExpr GhcRn
recordExpr :: LHsExpr GhcRn
..} =
    Range -> Text -> TextEdit
TextEdit Range
location (Text -> TextEdit) -> Text -> TextEdit
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> LHsExpr GhcRn -> Text
convertRecSel LHsExpr GhcRn
selectorExpr LHsExpr GhcRn
recordExpr

-- |Converts a record selector expression into record dot syntax, currently we
-- are using printOutputable to do it. We are also letting GHC decide when to
-- parenthesize the record expression
convertRecSel :: LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> Text
convertRecSel :: LHsExpr GhcRn -> LHsExpr GhcRn -> Text
convertRecSel LHsExpr GhcRn
se LHsExpr GhcRn
re = GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Text
forall a. Outputable a => a -> Text
printOutputable (PprPrec -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
appPrec LHsExpr GhcRn
re) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> Text
forall a. Outputable a => a -> Text
printOutputable LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
se

collectRecordSelectors :: GenericQ [RecordSelectorExpr]
-- It's important that we use everthingBut here, because if we used everything
-- we would get duplicates for every case that occurs inside a HsExpanded
-- expression. Please see the test MultilineExpanded.hs
collectRecordSelectors :: GenericQ [RecordSelectorExpr]
collectRecordSelectors = ([RecordSelectorExpr]
 -> [RecordSelectorExpr] -> [RecordSelectorExpr])
-> GenericQ ([RecordSelectorExpr], Bool)
-> GenericQ [RecordSelectorExpr]
forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r
everythingBut [RecordSelectorExpr]
-> [RecordSelectorExpr] -> [RecordSelectorExpr]
forall a. Semigroup a => a -> a -> a
(<>) (([], Bool
False) ([RecordSelectorExpr], Bool)
-> (GenLocated SrcSpanAnnA (HsExpr GhcRn)
    -> ([RecordSelectorExpr], Bool))
-> a
-> ([RecordSelectorExpr], Bool)
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` LHsExpr GhcRn -> ([RecordSelectorExpr], Bool)
GenLocated SrcSpanAnnA (HsExpr GhcRn)
-> ([RecordSelectorExpr], Bool)
getRecSels)

-- |We want to return a list here, because on the occasion that we encounter a
-- HsExpanded expression, we want to return all the results from recursing on
-- one branch, which could be multiple matches. Again see MultilineExpanded.hs
getRecSels :: LHsExpr (GhcPass 'Renamed) -> ([RecordSelectorExpr], Bool)
-- When we stumble upon an occurrence of HsExpanded, we only want to follow one
-- branch. We do this here, by explicitly returning occurrences from traversing
-- the original branch, and returning True, which keeps syb from implicitly
-- continuing to traverse.
getRecSels :: LHsExpr GhcRn -> ([RecordSelectorExpr], Bool)
getRecSels (LHsExpr GhcRn -> HsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc -> XExpr (HsExpanded HsExpr GhcRn
a HsExpr GhcRn
_)) = (HsExpr GhcRn -> [RecordSelectorExpr]
GenericQ [RecordSelectorExpr]
collectRecordSelectors HsExpr GhcRn
a, Bool
True)
#if __GLASGOW_HASKELL__ >= 903
-- applied record selection: "selector record" or "selector (record)" or
-- "selector selector2.record2"
getRecSels e :: LHsExpr GhcRn
e@(LHsExpr GhcRn -> HsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc -> HsApp XApp GhcRn
_ se :: LHsExpr GhcRn
se@(LHsExpr GhcRn -> HsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc -> HsRecSel XRecSel GhcRn
_ FieldOcc GhcRn
_) LHsExpr GhcRn
re) =
    ( [ Range -> LHsExpr GhcRn -> LHsExpr GhcRn -> RecordSelectorExpr
RecordSelectorExpr (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
realSpan') LHsExpr GhcRn
se LHsExpr GhcRn
re
      | RealSrcSpan RealSrcSpan
realSpan' Maybe BufSpan
_ <- [ GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e ] ], Bool
False )
-- Record selection where the field is being applied with the "$" operator:
-- "selector $ record"
getRecSels e :: LHsExpr GhcRn
e@(LHsExpr GhcRn -> HsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc -> OpApp XOpApp GhcRn
_ se :: LHsExpr GhcRn
se@(LHsExpr GhcRn -> HsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc -> HsRecSel XRecSel GhcRn
_ FieldOcc GhcRn
_)
                        (LHsExpr GhcRn -> HsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc -> HsVar XVar GhcRn
_ (LIdP GhcRn -> Name
GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc -> Name
d)) LHsExpr GhcRn
re) | Name
d Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
dollarName =
    ( [ Range -> LHsExpr GhcRn -> LHsExpr GhcRn -> RecordSelectorExpr
RecordSelectorExpr (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
realSpan')  LHsExpr GhcRn
se LHsExpr GhcRn
re
      | RealSrcSpan RealSrcSpan
realSpan' Maybe BufSpan
_ <- [ GenLocated SrcSpanAnnA (HsExpr GhcRn) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
e ] ], Bool
False )
#else
getRecSels e@(unLoc -> HsApp _ se@(unLoc -> HsRecFld _ _) re) =
    ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re
      | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False )
getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecFld _ _)
                        (unLoc -> HsVar _ (unLoc -> d)) re) | d == dollarName =
    ( [ RecordSelectorExpr (realSrcSpanToRange realSpan')  se re
      | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False )
#endif
getRecSels LHsExpr GhcRn
_ = ([], Bool
False)

collectRecSelResult :: MonadIO m => IdeState -> NormalizedFilePath
                        -> ExceptT PluginError m CollectRecordSelectorsResult
collectRecSelResult :: forall (m :: * -> *).
MonadIO m =>
IdeState
-> NormalizedFilePath
-> ExceptT PluginError m CollectRecordSelectorsResult
collectRecSelResult IdeState
ideState =
    String
-> IdeState
-> ExceptT PluginError Action CollectRecordSelectorsResult
-> ExceptT PluginError m CollectRecordSelectorsResult
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"overloadedRecordDot.collectRecordSelectors" IdeState
ideState
        (ExceptT PluginError Action CollectRecordSelectorsResult
 -> ExceptT PluginError m CollectRecordSelectorsResult)
-> (NormalizedFilePath
    -> ExceptT PluginError Action CollectRecordSelectorsResult)
-> NormalizedFilePath
-> ExceptT PluginError m CollectRecordSelectorsResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CollectRecordSelectors
-> NormalizedFilePath
-> ExceptT PluginError Action CollectRecordSelectorsResult
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE CollectRecordSelectors
CollectRecordSelectors