{-# LANGUAGE CPP               #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE ViewPatterns      #-}

module Ide.Plugin.ExplicitFields
  ( descriptor
  , Log
  ) where

import           Control.Lens                     ((&), (?~), (^.))
import           Control.Monad.IO.Class           (MonadIO (liftIO))
import           Control.Monad.Trans.Maybe
import           Data.Aeson                       (toJSON)
import           Data.Generics                    (GenericQ, everything,
                                                   everythingBut, extQ, mkQ)
import qualified Data.IntMap.Strict               as IntMap
import qualified Data.Map                         as Map
import           Data.Maybe                       (fromMaybe, isJust,
                                                   maybeToList)
import           Data.Text                        (Text)
import           Data.Unique                      (hashUnique, newUnique)

import           Control.Monad                    (replicateM)
import           Development.IDE                  (IdeState, Pretty (..), Range,
                                                   Recorder (..), Rules,
                                                   WithPriority (..),
                                                   defineNoDiagnostics,
                                                   realSrcSpanToRange, viaShow)
import           Development.IDE.Core.PluginUtils
import           Development.IDE.Core.RuleTypes   (TcModuleResult (..),
                                                   TypeCheck (..))
import qualified Development.IDE.Core.Shake       as Shake
import           Development.IDE.GHC.Compat       (HsConDetails (RecCon),
                                                   HsExpansion (HsExpanded),
                                                   HsExpr (XExpr),
                                                   HsRecFields (..), LPat,
                                                   Outputable, getLoc,
                                                   recDotDot, unLoc)
import           Development.IDE.GHC.Compat.Core  (Extension (NamedFieldPuns),
                                                   GhcPass,
                                                   HsExpr (RecordCon, rcon_flds),
                                                   HsRecField, LHsExpr,
                                                   LocatedA, Name, Pass (..),
                                                   Pat (..), RealSrcSpan,
                                                   UniqFM, conPatDetails,
                                                   emptyUFM, hfbPun, hfbRHS,
                                                   hs_valds, lookupUFM,
                                                   mapConPatDetail, mapLoc,
                                                   pattern RealSrcSpan,
                                                   plusUFM_C, unitUFM)
import           Development.IDE.GHC.Util         (getExtensions,
                                                   printOutputable)
import           Development.IDE.Graph            (RuleResult)
import           Development.IDE.Graph.Classes    (Hashable, NFData)
import           Development.IDE.Spans.Pragmas    (NextPragmaInfo (..),
                                                   getFirstPragma,
                                                   insertNewPragma)
import           GHC.Generics                     (Generic)
import           Ide.Logger                       (Priority (..), cmapWithPrio,
                                                   logWith, (<+>))
import           Ide.Plugin.Error                 (PluginError (PluginInternalError, PluginStaleResolve),
                                                   getNormalizedFilePathE,
                                                   handleMaybe)
import           Ide.Plugin.RangeMap              (RangeMap)
import qualified Ide.Plugin.RangeMap              as RangeMap
import           Ide.Plugin.Resolve               (mkCodeActionWithResolveAndCommand)
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 (..),
                                                   Command, TextEdit (..),
                                                   WorkspaceEdit (WorkspaceEdit),
                                                   type (|?) (InL, InR))


data Log
  = LogShake Shake.Log
  | LogCollectedRecords [RecordInfo]
  | LogRenderedRecords [TextEdit]
  | 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
    LogCollectedRecords [RecordInfo]
recs -> Doc ann
"Collected records with wildcards:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [RecordInfo] -> Doc ann
forall ann. [RecordInfo] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [RecordInfo]
recs
    LogRenderedRecords [TextEdit]
recs -> Doc ann
"Rendered records:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [TextEdit] -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow [TextEdit]
recs
    LogResolve a
msg -> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
msg

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
      ([PluginCommand IdeState]
carCommands, PluginHandlers IdeState
caHandlers) = Recorder (WithPriority Log)
-> PluginId
-> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
-> ResolveFunction IdeState Int 'Method_CodeActionResolve
-> ([PluginCommand IdeState], PluginHandlers IdeState)
forall ideState a.
FromJSON a =>
Recorder (WithPriority Log)
-> PluginId
-> PluginMethodHandler ideState 'Method_TextDocumentCodeAction
-> ResolveFunction ideState a 'Method_CodeActionResolve
-> ([PluginCommand ideState], PluginHandlers ideState)
mkCodeActionWithResolveAndCommand Recorder (WithPriority Log)
resolveRecorder PluginId
plId PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionProvider ResolveFunction IdeState Int 'Method_CodeActionResolve
codeActionResolveProvider
  in (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
"Provides a code action to make record wildcards explicit")
  { pluginHandlers = caHandlers
  , pluginCommands = carCommands
  , pluginRules = collectRecordsRule recorder *> collectNamesRule
  }

codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
codeActionProvider IdeState
ideState PluginId
_ (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
docId Range
range 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)
  CRR {RangeMap Int
crCodeActions :: RangeMap Int
crCodeActions :: CollectRecordsResult -> RangeMap Int
crCodeActions, [Extension]
enabledExtensions :: [Extension]
enabledExtensions :: CollectRecordsResult -> [Extension]
enabledExtensions} <- String
-> IdeState
-> ExceptT PluginError Action CollectRecordsResult
-> ExceptT PluginError (LspM Config) CollectRecordsResult
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"ExplicitFields.CollectRecords" IdeState
ideState (ExceptT PluginError Action CollectRecordsResult
 -> ExceptT PluginError (LspM Config) CollectRecordsResult)
-> ExceptT PluginError Action CollectRecordsResult
-> ExceptT PluginError (LspM Config) CollectRecordsResult
forall a b. (a -> b) -> a -> b
$ CollectRecords
-> NormalizedFilePath
-> ExceptT PluginError Action CollectRecordsResult
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE CollectRecords
CollectRecords NormalizedFilePath
nfp
  -- All we need to build a code action is the list of extensions, and a int to
  -- allow us to resolve it later.
  let actions :: [Command |? CodeAction]
actions = (Int -> Command |? CodeAction) -> [Int] -> [Command |? CodeAction]
forall a b. (a -> b) -> [a] -> [b]
map ([Extension] -> Int -> Command |? CodeAction
mkCodeAction [Extension]
enabledExtensions) (Range -> RangeMap Int -> [Int]
forall a. Range -> RangeMap a -> [a]
RangeMap.filterByRange Range
range RangeMap Int
crCodeActions)
  ([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
    mkCodeAction ::  [Extension] ->  Int -> Command |? CodeAction
    mkCodeAction :: [Extension] -> Int -> Command |? CodeAction
mkCodeAction  [Extension]
exts Int
uid = CodeAction -> Command |? CodeAction
forall a b. b -> a |? b
InR CodeAction
      { $sel:_title:CodeAction :: Text
_title = Text
"Expand record wildcard"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Extension
NamedFieldPuns 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
forall a. Monoid a => a
mempty
                    else Text
" (needs extension: NamedFieldPuns)"
      , $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
$ Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
uid
      }

codeActionResolveProvider :: ResolveFunction IdeState Int 'Method_CodeActionResolve
codeActionResolveProvider :: ResolveFunction IdeState Int 'Method_CodeActionResolve
codeActionResolveProvider IdeState
ideState PluginId
pId MessageParams 'Method_CodeActionResolve
ca Uri
uri Int
uid = do
  NormalizedFilePath
nfp <- Uri -> ExceptT PluginError (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
  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
ideState NormalizedFilePath
nfp
  CRR {IntMap RecordInfo
crCodeActionResolve :: IntMap RecordInfo
crCodeActionResolve :: CollectRecordsResult -> IntMap RecordInfo
crCodeActionResolve, UniqFM Name [Name]
nameMap :: UniqFM Name [Name]
nameMap :: CollectRecordsResult -> UniqFM Name [Name]
nameMap, [Extension]
enabledExtensions :: CollectRecordsResult -> [Extension]
enabledExtensions :: [Extension]
enabledExtensions} <- String
-> IdeState
-> ExceptT PluginError Action CollectRecordsResult
-> ExceptT PluginError (LspM Config) CollectRecordsResult
forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"ExplicitFields.CollectRecords" IdeState
ideState (ExceptT PluginError Action CollectRecordsResult
 -> ExceptT PluginError (LspM Config) CollectRecordsResult)
-> ExceptT PluginError Action CollectRecordsResult
-> ExceptT PluginError (LspM Config) CollectRecordsResult
forall a b. (a -> b) -> a -> b
$ CollectRecords
-> NormalizedFilePath
-> ExceptT PluginError Action CollectRecordsResult
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> ExceptT PluginError Action v
useE CollectRecords
CollectRecords NormalizedFilePath
nfp
  -- If we are unable to find the unique id in our IntMap of records, it means
  -- that this resolve is stale.
  RecordInfo
record <- PluginError
-> Maybe RecordInfo -> ExceptT PluginError (LspM Config) RecordInfo
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe PluginError
PluginStaleResolve (Maybe RecordInfo -> ExceptT PluginError (LspM Config) RecordInfo)
-> Maybe RecordInfo -> ExceptT PluginError (LspM Config) RecordInfo
forall a b. (a -> b) -> a -> b
$ Int -> IntMap RecordInfo -> Maybe RecordInfo
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
uid IntMap RecordInfo
crCodeActionResolve
  -- We should never fail to render
  TextEdit
rendered <- PluginError
-> Maybe TextEdit -> ExceptT PluginError (LspM Config) TextEdit
forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe (Text -> PluginError
PluginInternalError Text
"Failed to render") (Maybe TextEdit -> ExceptT PluginError (LspM Config) TextEdit)
-> Maybe TextEdit -> ExceptT PluginError (LspM Config) TextEdit
forall a b. (a -> b) -> a -> b
$ UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit
renderRecordInfo UniqFM Name [Name]
nameMap RecordInfo
record
  let edits :: [TextEdit]
edits = [TextEdit
rendered]
              [TextEdit] -> [TextEdit] -> [TextEdit]
forall a. Semigroup a => a -> a -> a
<> Maybe TextEdit -> [TextEdit]
forall a. Maybe a -> [a]
maybeToList ([Extension] -> NextPragmaInfo -> Maybe TextEdit
pragmaEdit [Extension]
enabledExtensions NextPragmaInfo
pragma)
  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
CodeAction
ca CodeAction -> (CodeAction -> CodeAction) -> CodeAction
forall a b. a -> (a -> b) -> b
& (Maybe WorkspaceEdit -> Identity (Maybe WorkspaceEdit))
-> CodeAction -> Identity CodeAction
forall s a. HasEdit s a => Lens' s a
Lens' CodeAction (Maybe WorkspaceEdit)
L.edit ((Maybe WorkspaceEdit -> Identity (Maybe WorkspaceEdit))
 -> CodeAction -> Identity CodeAction)
-> WorkspaceEdit -> CodeAction -> CodeAction
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [TextEdit] -> WorkspaceEdit
mkWorkspaceEdit [TextEdit]
edits
  where
    mkWorkspaceEdit ::[TextEdit] -> WorkspaceEdit
    mkWorkspaceEdit :: [TextEdit] -> WorkspaceEdit
mkWorkspaceEdit [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
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. k -> a -> Map k a
Map.singleton Uri
uri [TextEdit]
edits) Maybe
  [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a. Maybe a
Nothing Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
forall a. Maybe a
Nothing
    pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit
    pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit
pragmaEdit [Extension]
exts NextPragmaInfo
pragma = if Extension
NamedFieldPuns 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
NamedFieldPuns

collectRecordsRule :: Recorder (WithPriority Log) -> Rules ()
collectRecordsRule :: Recorder (WithPriority Log) -> Rules ()
collectRecordsRule Recorder (WithPriority Log)
recorder =
  Recorder (WithPriority Log)
-> (CollectRecords
    -> NormalizedFilePath -> Action (Maybe CollectRecordsResult))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics ((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) ((CollectRecords
  -> NormalizedFilePath -> Action (Maybe CollectRecordsResult))
 -> Rules ())
-> (CollectRecords
    -> NormalizedFilePath -> Action (Maybe CollectRecordsResult))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \CollectRecords
CollectRecords NormalizedFilePath
nfp -> MaybeT Action CollectRecordsResult
-> Action (Maybe CollectRecordsResult)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Action CollectRecordsResult
 -> Action (Maybe CollectRecordsResult))
-> MaybeT Action CollectRecordsResult
-> Action (Maybe CollectRecordsResult)
forall a b. (a -> b) -> a -> b
$ do
  TcModuleResult
tmr <- TypeCheck -> NormalizedFilePath -> MaybeT Action TcModuleResult
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action v
useMT TypeCheck
TypeCheck NormalizedFilePath
nfp
  (CNR UniqFM Name [Name]
nameMap) <- CollectNames
-> NormalizedFilePath -> MaybeT Action CollectNamesResult
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action v
useMT CollectNames
CollectNames NormalizedFilePath
nfp
  let recs :: [RecordInfo]
recs = TcModuleResult -> [RecordInfo]
getRecords TcModuleResult
tmr
  Recorder (WithPriority Log) -> Priority -> Log -> MaybeT Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug ([RecordInfo] -> Log
LogCollectedRecords [RecordInfo]
recs)
  -- We want a list of unique numbers to link our the original code action we
  -- give out, with the actual record info that we resolve it to.
  [Int]
uniques <- IO [Int] -> MaybeT Action [Int]
forall a. IO a -> MaybeT Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Int] -> MaybeT Action [Int])
-> IO [Int] -> MaybeT 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 ([RecordInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RecordInfo]
recs) (Unique -> Int
hashUnique (Unique -> Int) -> IO Unique -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique)
  let recsWithUniques :: [(Int, RecordInfo)]
recsWithUniques = [Int] -> [RecordInfo] -> [(Int, RecordInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
uniques [RecordInfo]
recs
      -- For creating the code actions, a RangeMap of unique ids
      crCodeActions :: RangeMap Int
crCodeActions = [(Range, Int)] -> RangeMap Int
forall a. [(Range, a)] -> RangeMap a
RangeMap.fromList' ((Int, RecordInfo) -> (Range, Int)
forall {b}. (b, RecordInfo) -> (Range, b)
toRangeAndUnique ((Int, RecordInfo) -> (Range, Int))
-> [(Int, RecordInfo)] -> [(Range, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, RecordInfo)]
recsWithUniques)
      -- For resolving the code actions, a IntMap which links the unique id to
      -- the relevant record info.
      crCodeActionResolve :: IntMap RecordInfo
crCodeActionResolve = [(Int, RecordInfo)] -> IntMap RecordInfo
forall a. [(Int, a)] -> IntMap a
IntMap.fromList [(Int, RecordInfo)]
recsWithUniques
      enabledExtensions :: [Extension]
enabledExtensions = TcModuleResult -> [Extension]
getEnabledExtensions TcModuleResult
tmr
  CollectRecordsResult -> MaybeT Action CollectRecordsResult
forall a. a -> MaybeT Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CRR {RangeMap Int
crCodeActions :: RangeMap Int
crCodeActions :: RangeMap Int
crCodeActions, IntMap RecordInfo
crCodeActionResolve :: IntMap RecordInfo
crCodeActionResolve :: IntMap RecordInfo
crCodeActionResolve, UniqFM Name [Name]
nameMap :: UniqFM Name [Name]
nameMap :: UniqFM Name [Name]
nameMap, [Extension]
enabledExtensions :: [Extension]
enabledExtensions :: [Extension]
enabledExtensions}
  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
    toRangeAndUnique :: (b, RecordInfo) -> (Range, b)
toRangeAndUnique (b
uid, RecordInfo
recordInfo) = (RecordInfo -> Range
recordInfoToRange RecordInfo
recordInfo, b
uid)

getRecords :: TcModuleResult -> [RecordInfo]
getRecords :: TcModuleResult -> [RecordInfo]
getRecords (TcModuleResult -> RenamedSource
tmrRenamed -> (HsGroup (GhcPass 'Renamed) -> HsValBinds (GhcPass 'Renamed)
forall p. HsGroup p -> HsValBinds p
hs_valds -> HsValBinds (GhcPass 'Renamed)
valBinds,[LImportDecl (GhcPass 'Renamed)]
_,Maybe [(LIE (GhcPass 'Renamed), Avails)]
_,Maybe (LHsDoc (GhcPass 'Renamed))
_)) =
  HsValBinds (GhcPass 'Renamed) -> [RecordInfo]
GenericQ [RecordInfo]
collectRecords HsValBinds (GhcPass 'Renamed)
valBinds

collectNamesRule :: Rules ()
collectNamesRule :: Rules ()
collectNamesRule = Recorder (WithPriority Log)
-> (CollectNames
    -> NormalizedFilePath -> Action (Maybe CollectNamesResult))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics Recorder (WithPriority Log)
forall a. Monoid a => a
mempty ((CollectNames
  -> NormalizedFilePath -> Action (Maybe CollectNamesResult))
 -> Rules ())
-> (CollectNames
    -> NormalizedFilePath -> Action (Maybe CollectNamesResult))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \CollectNames
CollectNames NormalizedFilePath
nfp -> MaybeT Action CollectNamesResult
-> Action (Maybe CollectNamesResult)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Action CollectNamesResult
 -> Action (Maybe CollectNamesResult))
-> MaybeT Action CollectNamesResult
-> Action (Maybe CollectNamesResult)
forall a b. (a -> b) -> a -> b
$ do
  TcModuleResult
tmr <- TypeCheck -> NormalizedFilePath -> MaybeT Action TcModuleResult
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action v
useMT TypeCheck
TypeCheck NormalizedFilePath
nfp
  CollectNamesResult -> MaybeT Action CollectNamesResult
forall a. a -> MaybeT Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UniqFM Name [Name] -> CollectNamesResult
CNR (TcModuleResult -> UniqFM Name [Name]
getNames TcModuleResult
tmr))

-- | Collects all 'Name's of a given source file, to be used
-- in the variable usage analysis.
getNames :: TcModuleResult -> UniqFM Name [Name]
getNames :: TcModuleResult -> UniqFM Name [Name]
getNames (TcModuleResult -> RenamedSource
tmrRenamed -> (HsGroup (GhcPass 'Renamed)
group,[LImportDecl (GhcPass 'Renamed)]
_,Maybe [(LIE (GhcPass 'Renamed), Avails)]
_,Maybe (LHsDoc (GhcPass 'Renamed))
_)) = HsGroup (GhcPass 'Renamed) -> UniqFM Name [Name]
GenericQ (UniqFM Name [Name])
collectNames HsGroup (GhcPass 'Renamed)
group

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

instance Hashable CollectRecords
instance NFData CollectRecords

-- |The result of our map, this record includes everything we need to provide
-- code actions and resolve them later
data CollectRecordsResult = CRR
  { -- |For providing the code action we need the unique id (Int) in a RangeMap
    CollectRecordsResult -> RangeMap Int
crCodeActions       :: RangeMap Int
    -- |For resolving the code action we need to link the unique id we
    -- previously gave out with the record info that we use to make the edit
    -- with.
  , CollectRecordsResult -> IntMap RecordInfo
crCodeActionResolve :: IntMap.IntMap RecordInfo
    -- |The name map allows us to prune unused record fields (some of the time)
  , CollectRecordsResult -> UniqFM Name [Name]
nameMap             :: UniqFM Name [Name]
    -- |We need to make sure NamedFieldPuns is enabled, if it's not we need to
    -- add that to the text edit. (In addition we use it in creating the code
    -- action title)
  , CollectRecordsResult -> [Extension]
enabledExtensions   :: [Extension]
  }
  deriving ((forall x. CollectRecordsResult -> Rep CollectRecordsResult x)
-> (forall x. Rep CollectRecordsResult x -> CollectRecordsResult)
-> Generic CollectRecordsResult
forall x. Rep CollectRecordsResult x -> CollectRecordsResult
forall x. CollectRecordsResult -> Rep CollectRecordsResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CollectRecordsResult -> Rep CollectRecordsResult x
from :: forall x. CollectRecordsResult -> Rep CollectRecordsResult x
$cto :: forall x. Rep CollectRecordsResult x -> CollectRecordsResult
to :: forall x. Rep CollectRecordsResult x -> CollectRecordsResult
Generic)

instance NFData CollectRecordsResult
instance NFData RecordInfo

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

type instance RuleResult CollectRecords = CollectRecordsResult

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

instance Hashable CollectNames
instance NFData CollectNames

data CollectNamesResult = CNR (UniqFM Name [Name])
  deriving ((forall x. CollectNamesResult -> Rep CollectNamesResult x)
-> (forall x. Rep CollectNamesResult x -> CollectNamesResult)
-> Generic CollectNamesResult
forall x. Rep CollectNamesResult x -> CollectNamesResult
forall x. CollectNamesResult -> Rep CollectNamesResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CollectNamesResult -> Rep CollectNamesResult x
from :: forall x. CollectNamesResult -> Rep CollectNamesResult x
$cto :: forall x. Rep CollectNamesResult x -> CollectNamesResult
to :: forall x. Rep CollectNamesResult x -> CollectNamesResult
Generic)

instance NFData CollectNamesResult

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

type instance RuleResult CollectNames = CollectNamesResult

data RecordInfo
  = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed))
  | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed))
  deriving ((forall x. RecordInfo -> Rep RecordInfo x)
-> (forall x. Rep RecordInfo x -> RecordInfo) -> Generic RecordInfo
forall x. Rep RecordInfo x -> RecordInfo
forall x. RecordInfo -> Rep RecordInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RecordInfo -> Rep RecordInfo x
from :: forall x. RecordInfo -> Rep RecordInfo x
$cto :: forall x. Rep RecordInfo x -> RecordInfo
to :: forall x. Rep RecordInfo x -> RecordInfo
Generic)

instance Pretty RecordInfo where
  pretty :: forall ann. RecordInfo -> Doc ann
pretty (RecordInfoPat RealSrcSpan
ss Pat (GhcPass 'Renamed)
p) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (RealSrcSpan -> Text
forall a. Outputable a => a -> Text
printOutputable RealSrcSpan
ss) 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 (Pat (GhcPass 'Renamed) -> Text
forall a. Outputable a => a -> Text
printOutputable Pat (GhcPass 'Renamed)
p)
  pretty (RecordInfoCon RealSrcSpan
ss HsExpr (GhcPass 'Renamed)
e) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (RealSrcSpan -> Text
forall a. Outputable a => a -> Text
printOutputable RealSrcSpan
ss) 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 (HsExpr (GhcPass 'Renamed) -> Text
forall a. Outputable a => a -> Text
printOutputable HsExpr (GhcPass 'Renamed)
e)

recordInfoToRange :: RecordInfo -> Range
recordInfoToRange :: RecordInfo -> Range
recordInfoToRange (RecordInfoPat RealSrcSpan
ss Pat (GhcPass 'Renamed)
_) = RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
ss
recordInfoToRange (RecordInfoCon RealSrcSpan
ss HsExpr (GhcPass 'Renamed)
_) = RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
ss

renderRecordInfo :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit
renderRecordInfo :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit
renderRecordInfo UniqFM Name [Name]
names (RecordInfoPat RealSrcSpan
ss Pat (GhcPass 'Renamed)
pat) = Range -> Text -> TextEdit
TextEdit (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
ss) (Text -> TextEdit) -> Maybe Text -> Maybe TextEdit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Outputable (Pat (GhcPass 'Renamed)) =>
UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text
UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text
showRecordPat UniqFM Name [Name]
names Pat (GhcPass 'Renamed)
pat
renderRecordInfo UniqFM Name [Name]
_ (RecordInfoCon RealSrcSpan
ss HsExpr (GhcPass 'Renamed)
expr) = Range -> Text -> TextEdit
TextEdit (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
ss) (Text -> TextEdit) -> Maybe Text -> Maybe TextEdit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr (GhcPass 'Renamed) -> Maybe Text
forall (c :: Pass).
Outputable (HsExpr (GhcPass c)) =>
HsExpr (GhcPass c) -> Maybe Text
showRecordCon HsExpr (GhcPass 'Renamed)
expr

-- | Checks if a 'Name' is referenced in the given map of names. The
-- 'hasNonBindingOcc' check is necessary in order to make sure that only the
-- references at the use-sites are considered (i.e. the binding occurence
-- is excluded). For more information regarding the structure of the map,
-- refer to the documentation of 'collectNames'.
referencedIn :: Name -> UniqFM Name [Name] -> Bool
referencedIn :: Name -> UniqFM Name [Name] -> Bool
referencedIn Name
name UniqFM Name [Name]
names = Bool -> ([Name] -> Bool) -> Maybe [Name] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True [Name] -> Bool
hasNonBindingOcc (Maybe [Name] -> Bool) -> Maybe [Name] -> Bool
forall a b. (a -> b) -> a -> b
$ UniqFM Name [Name] -> Name -> Maybe [Name]
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Name [Name]
names Name
name
  where
    hasNonBindingOcc :: [Name] -> Bool
    hasNonBindingOcc :: [Name] -> Bool
hasNonBindingOcc = (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool) -> ([Name] -> Int) -> [Name] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length

-- Default to leaving the element in if somehow a name can't be extracted (i.e.
-- `getName` returns `Nothing`).
filterReferenced :: (a -> Maybe Name) -> UniqFM Name [Name] -> [a] -> [a]
filterReferenced :: forall a. (a -> Maybe Name) -> UniqFM Name [Name] -> [a] -> [a]
filterReferenced a -> Maybe Name
getName UniqFM Name [Name]
names = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\a
x -> Bool -> (Name -> Bool) -> Maybe Name -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Name -> UniqFM Name [Name] -> Bool
`referencedIn` UniqFM Name [Name]
names) (a -> Maybe Name
getName a
x))

preprocessRecordPat
  :: p ~ GhcPass 'Renamed
  => UniqFM Name [Name]
  -> HsRecFields p (LPat p)
  -> HsRecFields p (LPat p)
preprocessRecordPat :: forall p.
(p ~ GhcPass 'Renamed) =>
UniqFM Name [Name]
-> HsRecFields p (LPat p) -> HsRecFields p (LPat p)
preprocessRecordPat = (LocatedA
   (HsRecField p (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))))
 -> Maybe Name)
-> UniqFM Name [Name]
-> HsRecFields p (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
-> HsRecFields p (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
forall p (c :: Pass) arg.
(p ~ GhcPass c) =>
(LocatedA (HsRecField p arg) -> Maybe Name)
-> UniqFM Name [Name] -> HsRecFields p arg -> HsRecFields p arg
preprocessRecord (HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Renamed)))
  (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
-> Maybe (IdP (GhcPass 'Renamed))
HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Renamed)))
  (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
-> Maybe Name
forall {p} {l} {lhs} {l}.
(XRec p (IdP p) ~ GenLocated l (IdP p)) =>
HsFieldBind lhs (GenLocated l (Pat p)) -> Maybe (IdP p)
getFieldName (HsFieldBind
   (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Renamed)))
   (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
 -> Maybe Name)
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Renamed)))
         (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))))
    -> HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Renamed)))
         (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Renamed)))
        (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))))
-> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Renamed)))
     (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))))
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Renamed)))
     (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
forall l e. GenLocated l e -> e
unLoc)
  where
    getFieldName :: HsFieldBind lhs (GenLocated l (Pat p)) -> Maybe (IdP p)
getFieldName HsFieldBind lhs (GenLocated l (Pat p))
x = case GenLocated l (Pat p) -> Pat p
forall l e. GenLocated l e -> e
unLoc (HsFieldBind lhs (GenLocated l (Pat p)) -> GenLocated l (Pat p)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind lhs (GenLocated l (Pat p))
x) of
      VarPat XVarPat p
_ XRec p (IdP p)
x' -> IdP p -> Maybe (IdP p)
forall a. a -> Maybe a
Just (IdP p -> Maybe (IdP p)) -> IdP p -> Maybe (IdP p)
forall a b. (a -> b) -> a -> b
$ GenLocated l (IdP p) -> IdP p
forall l e. GenLocated l e -> e
unLoc XRec p (IdP p)
GenLocated l (IdP p)
x'
      Pat p
_           -> Maybe (IdP p)
forall a. Maybe a
Nothing

-- No need to check the name usage in the record construction case
preprocessRecordCon :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg
preprocessRecordCon :: forall (c :: Pass) arg.
HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg
preprocessRecordCon = (LocatedA (HsRecField (GhcPass c) arg) -> Maybe Name)
-> UniqFM Name [Name]
-> HsRecFields (GhcPass c) arg
-> HsRecFields (GhcPass c) arg
forall p (c :: Pass) arg.
(p ~ GhcPass c) =>
(LocatedA (HsRecField p arg) -> Maybe Name)
-> UniqFM Name [Name] -> HsRecFields p arg -> HsRecFields p arg
preprocessRecord (Maybe Name
-> LocatedA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)
-> Maybe Name
forall a b. a -> b -> a
const Maybe Name
forall a. Maybe a
Nothing) UniqFM Name [Name]
forall key elt. UniqFM key elt
emptyUFM

-- This function does two things:
-- 1) Tweak the AST type so that the pretty-printed record is in the
--    expanded form
-- 2) Determine the unused record fields so that they are filtered out
--    of the final output
--
-- Regarding first point:
-- We make use of the `Outputable` instances on AST types to pretty-print
-- the renamed and expanded records back into source form, to be substituted
-- with the original record later. However, `Outputable` instance of
-- `HsRecFields` does smart things to print the records that originally had
-- wildcards in their original form (i.e. with dots, without field names),
-- even after the wildcard is removed by the renamer pass. This is undesirable,
-- as we want to print the records in their fully expanded form.
-- Here `rec_dotdot` is set to `Nothing` so that fields are printed without
-- such post-processing.
preprocessRecord
  :: p ~ GhcPass c
  => (LocatedA (HsRecField p arg) -> Maybe Name)
  -> UniqFM Name [Name]
  -> HsRecFields p arg
  -> HsRecFields p arg
preprocessRecord :: forall p (c :: Pass) arg.
(p ~ GhcPass c) =>
(LocatedA (HsRecField p arg) -> Maybe Name)
-> UniqFM Name [Name] -> HsRecFields p arg -> HsRecFields p arg
preprocessRecord LocatedA (HsRecField p arg) -> Maybe Name
getName UniqFM Name [Name]
names HsRecFields p arg
flds = HsRecFields p arg
flds { rec_dotdot = Nothing , rec_flds = rec_flds' }
  where
    no_pun_count :: Int
no_pun_count = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe ([GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HsRecFields p arg -> [XRec p (HsRecField p arg)]
forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds HsRecFields p arg
flds)) (HsRecFields (GhcPass c) arg -> Maybe Int
forall (p :: Pass) arg. HsRecFields (GhcPass p) arg -> Maybe Int
recDotDot HsRecFields p arg
HsRecFields (GhcPass c) arg
flds)
    -- Field binds of the explicit form (e.g. `{ a = a' }`) should be
    -- left as is, hence the split.
    ([GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
no_puns, [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
puns) = Int
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
-> ([GenLocated
       SrcSpanAnnA
       (HsFieldBind
          (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)],
    [GenLocated
       SrcSpanAnnA
       (HsFieldBind
          (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
no_pun_count (HsRecFields p arg -> [XRec p (HsRecField p arg)]
forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds HsRecFields p arg
flds)
    -- `hsRecPun` is set to `True` in order to pretty-print the fields as field
    -- puns (since there is similar mechanism in the `Outputable` instance as
    -- explained above).
    puns' :: [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
puns' = (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)
 -> GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
forall a b. (a -> b) -> [a] -> [b]
map ((HsFieldBind
   (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg
 -> HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)
forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc (\HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg
fld -> HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg
fld { hfbPun = True })) [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
puns
    -- Unused fields are filtered out so that they don't end up in the expanded
    -- form.
    punsUsed :: [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
punsUsed = (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)
 -> Maybe Name)
-> UniqFM Name [Name]
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
forall a. (a -> Maybe Name) -> UniqFM Name [Name] -> [a] -> [a]
filterReferenced LocatedA (HsRecField p arg) -> Maybe Name
GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)
-> Maybe Name
getName UniqFM Name [Name]
names [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
puns'
    rec_flds' :: [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
rec_flds' = [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
no_puns [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
forall a. Semigroup a => a -> a -> a
<> [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass c))) arg)]
punsUsed

showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text
showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) =>
UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text
showRecordPat UniqFM Name [Name]
names = (Pat (GhcPass 'Renamed) -> Text)
-> Maybe (Pat (GhcPass 'Renamed)) -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat (GhcPass 'Renamed) -> Text
forall a. Outputable a => a -> Text
printOutputable (Maybe (Pat (GhcPass 'Renamed)) -> Maybe Text)
-> (Pat (GhcPass 'Renamed) -> Maybe (Pat (GhcPass 'Renamed)))
-> Pat (GhcPass 'Renamed)
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsConPatDetails (GhcPass 'Renamed)
 -> Maybe (HsConPatDetails (GhcPass 'Renamed)))
-> Pat (GhcPass 'Renamed) -> Maybe (Pat (GhcPass 'Renamed))
forall p.
(HsConPatDetails p -> Maybe (HsConPatDetails p))
-> Pat p -> Maybe (Pat p)
mapConPatDetail (\case
  RecCon HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed))
flds -> HsConPatDetails (GhcPass 'Renamed)
-> Maybe (HsConPatDetails (GhcPass 'Renamed))
forall a. a -> Maybe a
Just (HsConPatDetails (GhcPass 'Renamed)
 -> Maybe (HsConPatDetails (GhcPass 'Renamed)))
-> HsConPatDetails (GhcPass 'Renamed)
-> Maybe (HsConPatDetails (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ HsRecFields
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
-> HsConDetails
     (HsConPatTyArg (GhcPass 'Renamed))
     (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
     (HsRecFields
        (GhcPass 'Renamed)
        (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))))
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (UniqFM Name [Name]
-> HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed))
-> HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed))
forall p.
(p ~ GhcPass 'Renamed) =>
UniqFM Name [Name]
-> HsRecFields p (LPat p) -> HsRecFields p (LPat p)
preprocessRecordPat UniqFM Name [Name]
names HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed))
flds)
  HsConPatDetails (GhcPass 'Renamed)
_           -> Maybe (HsConPatDetails (GhcPass 'Renamed))
Maybe
  (HsConDetails
     (HsConPatTyArg (GhcPass 'Renamed))
     (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
     (HsRecFields
        (GhcPass 'Renamed)
        (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))))
forall a. Maybe a
Nothing)

showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text
showRecordCon :: forall (c :: Pass).
Outputable (HsExpr (GhcPass c)) =>
HsExpr (GhcPass c) -> Maybe Text
showRecordCon expr :: HsExpr (GhcPass c)
expr@(RecordCon XRecordCon (GhcPass c)
_ XRec (GhcPass c) (ConLikeP (GhcPass c))
_ HsRecordBinds (GhcPass c)
flds) =
  Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ HsExpr (GhcPass c) -> Text
forall a. Outputable a => a -> Text
printOutputable (HsExpr (GhcPass c) -> Text) -> HsExpr (GhcPass c) -> Text
forall a b. (a -> b) -> a -> b
$
    HsExpr (GhcPass c)
expr { rcon_flds = preprocessRecordCon flds }
showRecordCon HsExpr (GhcPass c)
_ = Maybe Text
forall a. Maybe a
Nothing

collectRecords :: GenericQ [RecordInfo]
collectRecords :: GenericQ [RecordInfo]
collectRecords = ([RecordInfo] -> [RecordInfo] -> [RecordInfo])
-> GenericQ ([RecordInfo], Bool) -> GenericQ [RecordInfo]
forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r
everythingBut [RecordInfo] -> [RecordInfo] -> [RecordInfo]
forall a. Semigroup a => a -> a -> a
(<>) (([], Bool
False) ([RecordInfo], Bool)
-> (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
    -> ([RecordInfo], Bool))
-> a
-> ([RecordInfo], Bool)
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` LPat (GhcPass 'Renamed) -> ([RecordInfo], Bool)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
-> ([RecordInfo], Bool)
getRecPatterns (a -> ([RecordInfo], Bool))
-> (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
    -> ([RecordInfo], Bool))
-> a
-> ([RecordInfo], Bool)
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> ([RecordInfo], Bool)
getRecCons)

-- | Collect 'Name's into a map, indexed by the names' unique identifiers.
-- The 'Eq' instance of 'Name's makes use of their unique identifiers, hence
-- any 'Name' referring to the same entity is considered equal. In effect,
-- each individual list of names contains the binding occurrence, along with
-- all the occurrences at the use-sites (if there are any).
--
-- @UniqFM Name [Name]@ is morally the same as @Map Unique [Name]@.
-- Using 'UniqFM' gains us a bit of performance (in theory) since it
-- internally uses 'IntMap'. More information regarding 'UniqFM' can be found in
-- the GHC source.
collectNames :: GenericQ (UniqFM Name [Name])
collectNames :: GenericQ (UniqFM Name [Name])
collectNames = (UniqFM Name [Name] -> UniqFM Name [Name] -> UniqFM Name [Name])
-> GenericQ (UniqFM Name [Name]) -> GenericQ (UniqFM Name [Name])
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything (([Name] -> [Name] -> [Name])
-> UniqFM Name [Name] -> UniqFM Name [Name] -> UniqFM Name [Name]
forall elt key.
(elt -> elt -> elt)
-> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
plusUFM_C [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
(<>)) (UniqFM Name [Name]
forall key elt. UniqFM key elt
emptyUFM UniqFM Name [Name]
-> (Name -> UniqFM Name [Name]) -> a -> UniqFM Name [Name]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` (\Name
x -> Name -> [Name] -> UniqFM Name [Name]
forall key elt. Uniquable key => key -> elt -> UniqFM key elt
unitUFM Name
x [Name
x]))

getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool)
-- When we stumble upon an occurrence of HsExpanded, we only want to follow a
-- single 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. In addition, we have to return a list,
-- because there is a possibility that there were be more than one result per
-- branch

getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool)
getRecCons (LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc -> XExpr (HsExpanded HsExpr (GhcPass 'Renamed)
a HsExpr (GhcPass 'Renamed)
_)) = (HsExpr (GhcPass 'Renamed) -> [RecordInfo]
GenericQ [RecordInfo]
collectRecords HsExpr (GhcPass 'Renamed)
a, Bool
True)
getRecCons e :: LHsExpr (GhcPass 'Renamed)
e@(LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc -> RecordCon XRecordCon (GhcPass 'Renamed)
_ XRec (GhcPass 'Renamed) (ConLikeP (GhcPass 'Renamed))
_ HsRecordBinds (GhcPass 'Renamed)
flds)
  | Maybe (GenLocated SrcSpan RecFieldsDotDot) -> Bool
forall a. Maybe a -> Bool
isJust (HsRecFields
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> Maybe (XRec (GhcPass 'Renamed) RecFieldsDotDot)
forall p arg. HsRecFields p arg -> Maybe (XRec p RecFieldsDotDot)
rec_dotdot HsRecordBinds (GhcPass 'Renamed)
HsRecFields
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
flds) = (LHsExpr (GhcPass 'Renamed) -> [RecordInfo]
mkRecInfo LHsExpr (GhcPass 'Renamed)
e, Bool
False)
  where
    mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> [RecordInfo]
    mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> [RecordInfo]
mkRecInfo LHsExpr (GhcPass 'Renamed)
expr =
      [ RealSrcSpan -> HsExpr (GhcPass 'Renamed) -> RecordInfo
RecordInfoCon RealSrcSpan
realSpan' (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr) | RealSrcSpan RealSrcSpan
realSpan' Maybe BufSpan
_ <- [ GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
expr ]]
getRecCons LHsExpr (GhcPass 'Renamed)
_ = ([], Bool
False)

getRecPatterns :: LPat (GhcPass 'Renamed) -> ([RecordInfo], Bool)
getRecPatterns :: LPat (GhcPass 'Renamed) -> ([RecordInfo], Bool)
getRecPatterns conPat :: LPat (GhcPass 'Renamed)
conPat@(Pat (GhcPass 'Renamed)
-> Maybe (HsConPatDetails (GhcPass 'Renamed))
forall p. Pat p -> Maybe (HsConPatDetails p)
conPatDetails (Pat (GhcPass 'Renamed)
 -> Maybe (HsConPatDetails (GhcPass 'Renamed)))
-> (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
    -> Pat (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
-> Maybe (HsConPatDetails (GhcPass 'Renamed))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
-> Pat (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc -> Just (RecCon HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed))
flds))
  | Maybe (GenLocated SrcSpan RecFieldsDotDot) -> Bool
forall a. Maybe a -> Bool
isJust (HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed))
-> Maybe (XRec (GhcPass 'Renamed) RecFieldsDotDot)
forall p arg. HsRecFields p arg -> Maybe (XRec p RecFieldsDotDot)
rec_dotdot HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed))
flds) = (LPat (GhcPass 'Renamed) -> [RecordInfo]
mkRecInfo LPat (GhcPass 'Renamed)
conPat, Bool
False)
  where
    mkRecInfo :: LPat (GhcPass 'Renamed) -> [RecordInfo]
    mkRecInfo :: LPat (GhcPass 'Renamed) -> [RecordInfo]
mkRecInfo LPat (GhcPass 'Renamed)
pat =
      [ RealSrcSpan -> Pat (GhcPass 'Renamed) -> RecordInfo
RecordInfoPat RealSrcSpan
realSpan' (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
-> Pat (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc LPat (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
pat) | RealSrcSpan RealSrcSpan
realSpan' Maybe BufSpan
_ <- [ GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LPat (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
pat ]]
getRecPatterns LPat (GhcPass 'Renamed)
_ = ([], Bool
False)