{-# 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
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
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
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)
[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
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)
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))
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
data CollectRecordsResult = CRR
{
CollectRecordsResult -> RangeMap Int
crCodeActions :: RangeMap Int
, CollectRecordsResult -> IntMap RecordInfo
crCodeActionResolve :: IntMap.IntMap RecordInfo
, CollectRecordsResult -> UniqFM Name [Name]
nameMap :: UniqFM Name [Name]
, 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
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
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
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
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)
([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)
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
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)
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)
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)