{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE PatternSynonyms           #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeOperators             #-}
{-# 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),
                                                   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))

import           Development.IDE.GHC.Compat       (HsExpansion (HsExpanded),
                                                   HsExpr (XExpr))

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 -> forall a ann. Pretty a => a -> Doc ann
pretty Log
shakeLog
    LogCollectedRecords [RecordInfo]
recs -> Doc ann
"Collected records with wildcards:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [RecordInfo]
recs
    LogRenderedRecords [TextEdit]
recs -> Doc ann
"Rendered records:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow [TextEdit]
recs
    LogResolve a
msg -> 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 = forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio forall a. Pretty a => a -> Log
LogResolve Recorder (WithPriority Log)
recorder
      ([PluginCommand IdeState]
carCommands, PluginHandlers IdeState
caHandlers) = 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 (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
  { pluginHandlers :: PluginHandlers IdeState
pluginHandlers = PluginHandlers IdeState
caHandlers
  , pluginCommands :: [PluginCommand IdeState]
pluginCommands = [PluginCommand IdeState]
carCommands
  , pluginRules :: Rules ()
pluginRules = Recorder (WithPriority Log) -> Rules ()
collectRecordsRule Recorder (WithPriority Log)
recorder forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Rules ()
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 <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE (TextDocumentIdentifier
docId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri)
  CRR {RangeMap Int
crCodeActions :: CollectRecordsResult -> RangeMap Int
crCodeActions :: RangeMap Int
crCodeActions, [Extension]
enabledExtensions :: CollectRecordsResult -> [Extension]
enabledExtensions :: [Extension]
enabledExtensions} <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"ExplicitFields.CollectRecords" IdeState
ideState forall a b. (a -> b) -> a -> b
$ 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 = forall a b. (a -> b) -> [a] -> [b]
map ([Extension] -> Int -> Command |? CodeAction
mkCodeAction [Extension]
enabledExtensions) (forall a. Range -> RangeMap a -> [a]
RangeMap.filterByRange Range
range RangeMap Int
crCodeActions)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 = forall a b. b -> a |? b
InR CodeAction
      { $sel:_title:CodeAction :: Text
_title = Text
"Expand record wildcard"
                  forall a. Semigroup a => a -> a -> a
<> if Extension
NamedFieldPuns forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Extension]
exts
                    then forall a. Monoid a => a
mempty
                    else Text
" (needs extension: NamedFieldPuns)"
      , $sel:_kind:CodeAction :: Maybe CodeActionKind
_kind = forall a. a -> Maybe a
Just CodeActionKind
CodeActionKind_RefactorRewrite
      , $sel:_diagnostics:CodeAction :: Maybe [Diagnostic]
_diagnostics = forall a. Maybe a
Nothing
      , $sel:_isPreferred:CodeAction :: Maybe Bool
_isPreferred = forall a. Maybe a
Nothing
      , $sel:_disabled:CodeAction :: Maybe (Rec (("reason" .== Text) .+ Empty))
_disabled = forall a. Maybe a
Nothing
      , $sel:_edit:CodeAction :: Maybe WorkspaceEdit
_edit = forall a. Maybe a
Nothing
      , $sel:_command:CodeAction :: Maybe Command
_command = forall a. Maybe a
Nothing
      , $sel:_data_:CodeAction :: Maybe Value
_data_ = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT PluginError m NormalizedFilePath
getNormalizedFilePathE Uri
uri
  NextPragmaInfo
pragma <- forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT PluginError m NextPragmaInfo
getFirstPragma PluginId
pId IdeState
ideState NormalizedFilePath
nfp
  CRR {IntMap RecordInfo
crCodeActionResolve :: CollectRecordsResult -> IntMap RecordInfo
crCodeActionResolve :: IntMap RecordInfo
crCodeActionResolve, UniqFM Name [Name]
nameMap :: CollectRecordsResult -> UniqFM Name [Name]
nameMap :: UniqFM Name [Name]
nameMap, [Extension]
enabledExtensions :: [Extension]
enabledExtensions :: CollectRecordsResult -> [Extension]
enabledExtensions} <- forall (m :: * -> *) e a.
MonadIO m =>
String -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE String
"ExplicitFields.CollectRecords" IdeState
ideState forall a b. (a -> b) -> a -> b
$ 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 <- forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe PluginError
PluginStaleResolve forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
uid IntMap RecordInfo
crCodeActionResolve
  -- We should never fail to render
  TextEdit
rendered <- forall (m :: * -> *) e b. Monad m => e -> Maybe b -> ExceptT e m b
handleMaybe (Text -> PluginError
PluginInternalError Text
"Failed to render") 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]
              forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> [a]
maybeToList ([Extension] -> NextPragmaInfo -> Maybe TextEdit
pragmaEdit [Extension]
enabledExtensions NextPragmaInfo
pragma)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MessageParams 'Method_CodeActionResolve
ca forall a b. a -> (a -> b) -> b
& forall s a. HasEdit s a => Lens' s a
L.edit 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 (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Uri
uri [TextEdit]
edits) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit
    pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit
pragmaEdit [Extension]
exts NextPragmaInfo
pragma = if Extension
NamedFieldPuns forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Extension]
exts
                      then forall a. Maybe a
Nothing
                      else forall a. a -> Maybe a
Just 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 =
  forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \CollectRecords
CollectRecords NormalizedFilePath
nfp -> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
  TcModuleResult
tmr <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action v
useMT TypeCheck
TypeCheck NormalizedFilePath
nfp
  (CNR UniqFM Name [Name]
nameMap) <- 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
  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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [RecordInfo]
recs) (Unique -> Int
hashUnique forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique)
  let recsWithUniques :: [(Int, RecordInfo)]
recsWithUniques = 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 = forall a. [(Range, a)] -> RangeMap a
RangeMap.fromList' (forall {b}. (b, RecordInfo) -> (Range, b)
toRangeAndUnique 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 = forall a. [(Int, a)] -> IntMap a
IntMap.fromList [(Int, RecordInfo)]
recsWithUniques
      enabledExtensions :: [Extension]
enabledExtensions = TcModuleResult -> [Extension]
getEnabledExtensions TcModuleResult
tmr
  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 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 -> (forall p. HsGroup p -> HsValBinds p
hs_valds -> HsValBinds (GhcPass 'Renamed)
valBinds,[LImportDecl (GhcPass 'Renamed)]
_,Maybe [(LIE (GhcPass 'Renamed), Avails)]
_,Maybe LHsDocString
_)) =
  GenericQ [RecordInfo]
collectRecords HsValBinds (GhcPass 'Renamed)
valBinds

collectNamesRule :: Rules ()
collectNamesRule :: Rules ()
collectNamesRule = forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules ()
defineNoDiagnostics forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ \CollectNames
CollectNames NormalizedFilePath
nfp -> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
  TcModuleResult
tmr <- forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> MaybeT Action v
useMT TypeCheck
TypeCheck NormalizedFilePath
nfp
  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 LHsDocString
_)) = GenericQ (UniqFM Name [Name])
collectNames HsGroup (GhcPass 'Renamed)
group

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

instance Hashable CollectNames
instance NFData CollectNames

data CollectNamesResult = CNR (UniqFM Name [Name])
  deriving (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
$cto :: forall x. Rep CollectNamesResult x -> CollectNamesResult
$cfrom :: forall x. CollectNamesResult -> Rep CollectNamesResult x
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. 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
$cto :: forall x. Rep RecordInfo x -> RecordInfo
$cfrom :: forall x. RecordInfo -> Rep RecordInfo x
Generic)

instance Pretty RecordInfo where
  pretty :: forall ann. RecordInfo -> Doc ann
pretty (RecordInfoPat RealSrcSpan
ss Pat (GhcPass 'Renamed)
p) = forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Outputable a => a -> Text
printOutputable RealSrcSpan
ss) forall a. Semigroup a => a -> a -> a
<> Doc ann
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Outputable a => a -> Text
printOutputable Pat (GhcPass 'Renamed)
p)
  pretty (RecordInfoCon RealSrcSpan
ss HsExpr (GhcPass 'Renamed)
e) = forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Outputable a => a -> Text
printOutputable RealSrcSpan
ss) forall a. Semigroup a => a -> a -> a
<> Doc ann
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Outputable (Pat (GhcPass 'Renamed)) =>
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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True [Name] -> Bool
hasNonBindingOcc forall a b. (a -> b) -> a -> b
$ 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 = (forall a. Ord a => a -> a -> Bool
> Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (\a
x -> 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 = forall p (c :: Pass) arg.
(p ~ GhcPass c) =>
(LocatedA (HsRecField p arg) -> Maybe Name)
-> UniqFM Name [Name] -> HsRecFields p arg -> HsRecFields p arg
preprocessRecord (forall {p} {l} {id} {l}.
(XRec p (IdP p) ~ GenLocated l (IdP p)) =>
HsRecField' id (GenLocated l (Pat p)) -> Maybe (IdP p)
getFieldName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
  where
    getFieldName :: HsRecField' id (GenLocated l (Pat p)) -> Maybe (IdP p)
getFieldName HsRecField' id (GenLocated l (Pat p))
x = case forall l e. GenLocated l e -> e
unLoc (forall id arg. HsRecField' id arg -> arg
hfbRHS HsRecField' id (GenLocated l (Pat p))
x) of
      VarPat XVarPat p
_ XRec p (IdP p)
x' -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec p (IdP p)
x'
      Pat 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 = forall p (c :: Pass) arg.
(p ~ GhcPass c) =>
(LocatedA (HsRecField p arg) -> Maybe Name)
-> UniqFM Name [Name] -> HsRecFields p arg -> HsRecFields p arg
preprocessRecord (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) 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 GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) arg) -> Maybe Name
getName UniqFM Name [Name]
names HsRecFields p arg
flds = HsRecFields p arg
flds { rec_dotdot :: Maybe (Located Int)
rec_dotdot = forall a. Maybe a
Nothing , rec_flds :: [LHsRecField p arg]
rec_flds = [GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) arg)]
rec_flds' }
  where
    no_pun_count :: Int
no_pun_count = forall a. a -> Maybe a -> a
fromMaybe (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds HsRecFields p arg
flds)) (forall (p :: Pass) arg. HsRecFields (GhcPass p) arg -> Maybe Int
recDotDot HsRecFields p arg
flds)
    -- Field binds of the explicit form (e.g. `{ a = a' }`) should be
    -- left as is, hence the split.
    ([GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) arg)]
no_puns, [GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) arg)]
puns) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
no_pun_count (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 (HsRecField' (FieldOcc p) arg)]
puns' = forall a b. (a -> b) -> [a] -> [b]
map (forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc (\HsRecField' (FieldOcc p) arg
fld -> HsRecField' (FieldOcc p) arg
fld { hfbPun :: Bool
hfbPun = Bool
True })) [GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) arg)]
puns
    -- Unused fields are filtered out so that they don't end up in the expanded
    -- form.
    punsUsed :: [GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) arg)]
punsUsed = forall a. (a -> Maybe Name) -> UniqFM Name [Name] -> [a] -> [a]
filterReferenced GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) arg) -> Maybe Name
getName UniqFM Name [Name]
names [GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) arg)]
puns'
    rec_flds' :: [GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) arg)]
rec_flds' = [GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) arg)]
no_puns forall a. Semigroup a => a -> a -> a
<> [GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Outputable a => a -> Text
printOutputable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p.
(HsConPatDetails p -> Maybe (HsConPatDetails p))
-> Pat p -> Maybe (Pat p)
mapConPatDetail (\case
  RecCon HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed))
flds -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (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)
_           -> 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) =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> Text
printOutputable forall a b. (a -> b) -> a -> b
$
    HsExpr (GhcPass c)
expr { rcon_flds :: HsRecordBinds (GhcPass c)
rcon_flds = forall (c :: Pass) arg.
HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg
preprocessRecordCon HsRecordBinds (GhcPass c)
flds }
showRecordCon HsExpr (GhcPass c)
_ = forall a. Maybe a
Nothing

collectRecords :: GenericQ [RecordInfo]
collectRecords :: GenericQ [RecordInfo]
collectRecords = forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r
everythingBut forall a. Semigroup a => a -> a -> a
(<>) (([], Bool
False) forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` LPat (GhcPass 'Renamed) -> ([RecordInfo], Bool)
getRecPatterns forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` LHsExpr (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 = forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything (forall elt key.
(elt -> elt -> elt)
-> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
plusUFM_C forall a. Semigroup a => a -> a -> a
(<>)) (forall key elt. UniqFM key elt
emptyUFM forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` (\Name
x -> 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 (forall l e. GenLocated l e -> e
unLoc -> XExpr (HsExpanded HsExpr (GhcPass 'Renamed)
a HsExpr (GhcPass 'Renamed)
_)) = (GenericQ [RecordInfo]
collectRecords HsExpr (GhcPass 'Renamed)
a, Bool
True)
getRecCons e :: LHsExpr (GhcPass 'Renamed)
e@(forall l e. GenLocated l e -> e
unLoc -> RecordCon XRecordCon (GhcPass 'Renamed)
_ XRec (GhcPass 'Renamed) (ConLikeP (GhcPass 'Renamed))
_ HsRecordBinds (GhcPass 'Renamed)
flds)
  | forall a. Maybe a -> Bool
isJust (forall p arg. HsRecFields p arg -> Maybe (Located Int)
rec_dotdot HsRecordBinds (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' (forall l e. GenLocated l e -> e
unLoc LHsExpr (GhcPass 'Renamed)
expr) | RealSrcSpan RealSrcSpan
realSpan' Maybe BufSpan
_ <- [ forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr (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@(forall p. Pat p -> Maybe (HsConPatDetails p)
conPatDetails forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc -> Just (RecCon HsRecFields (GhcPass 'Renamed) (LPat (GhcPass 'Renamed))
flds))
  | forall a. Maybe a -> Bool
isJust (forall p arg. HsRecFields p arg -> Maybe (Located Int)
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' (forall l e. GenLocated l e -> e
unLoc LPat (GhcPass 'Renamed)
pat) | RealSrcSpan RealSrcSpan
realSpan' Maybe BufSpan
_ <- [ forall a. HasSrcSpan a => a -> SrcSpan
getLoc LPat (GhcPass 'Renamed)
pat ]]
getRecPatterns LPat (GhcPass 'Renamed)
_ = ([], Bool
False)