{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# 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.Except (ExceptT)
import Data.Functor ((<&>))
import Data.Generics (GenericQ, everything, extQ,
mkQ)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (isJust, listToMaybe,
maybeToList)
import Data.Text (Text)
import Development.IDE (IdeState, NormalizedFilePath,
Pretty (..), Recorder (..),
Rules, WithPriority (..),
realSrcSpanToRange)
import Development.IDE.Core.Rules (runAction)
import Development.IDE.Core.RuleTypes (TcModuleResult (..),
TypeCheck (..))
import Development.IDE.Core.Shake (define, use)
import qualified Development.IDE.Core.Shake as Shake
import Development.IDE.GHC.Compat (HsConDetails (RecCon),
HsRecFields (..), LPat,
Outputable, getLoc, 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, ufmToIntMap,
unitUFM)
import Development.IDE.GHC.Util (getExtensions,
printOutputable)
import Development.IDE.Graph (RuleResult)
import Development.IDE.Graph.Classes (Hashable, NFData (rnf))
import Development.IDE.Spans.Pragmas (NextPragmaInfo (..),
getFirstPragma,
insertNewPragma)
import Development.IDE.Types.Logger (Priority (..), cmapWithPrio,
logWith, (<+>))
import GHC.Generics (Generic)
import Ide.Plugin.RangeMap (RangeMap)
import qualified Ide.Plugin.RangeMap as RangeMap
import Ide.PluginUtils (getNormalizedFilePath,
handleMaybeM, pluginResponse)
import Ide.Types (PluginDescriptor (..),
PluginId (..),
PluginMethodHandler,
defaultPluginDescriptor,
mkPluginHandler)
import Language.LSP.Types (CodeAction (..),
CodeActionKind (CodeActionRefactorRewrite),
CodeActionParams (..),
Command, List (..),
Method (..), SMethod (..),
TextEdit (..),
WorkspaceEdit (WorkspaceEdit),
fromNormalizedUri,
normalizedFilePathToUri,
type (|?) (InR))
import qualified Language.LSP.Types.Lens as L
data Log
= LogShake Shake.Log
| LogCollectedRecords [RecordInfo]
| LogRenderedRecords [RenderedRecordInfo]
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 [RenderedRecordInfo]
recs -> Doc ann
"Rendered records:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty [RenderedRecordInfo]
recs
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor :: Recorder (WithPriority Log)
-> PluginId -> PluginDescriptor IdeState
descriptor Recorder (WithPriority Log)
recorder PluginId
plId = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId)
{ pluginHandlers :: PluginHandlers IdeState
pluginHandlers = forall (m :: Method 'FromClient 'Request) ideState.
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentCodeAction
STextDocumentCodeAction PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider
, 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 'TextDocumentCodeAction
codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
codeActionProvider IdeState
ideState PluginId
pId (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
docId Range
range CodeActionContext
_) = forall (m :: * -> *) a.
Monad m =>
ExceptT String m a -> m (Either ResponseError a)
pluginResponse forall a b. (a -> b) -> a -> b
$ do
NormalizedFilePath
nfp <- forall (m :: * -> *).
Monad m =>
Uri -> ExceptT String m NormalizedFilePath
getNormalizedFilePath (TextDocumentIdentifier
docId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri)
NextPragmaInfo
pragma <- forall (m :: * -> *).
MonadIO m =>
PluginId
-> IdeState
-> NormalizedFilePath
-> ExceptT String m NextPragmaInfo
getFirstPragma PluginId
pId IdeState
ideState NormalizedFilePath
nfp
CRR RangeMap RenderedRecordInfo
recMap (forall a b. (a -> b) -> [a] -> [b]
map GhcExtension -> Extension
unExt -> [Extension]
exts) <- forall (m :: * -> *).
MonadIO m =>
IdeState
-> NormalizedFilePath -> ExceptT String m CollectRecordsResult
collectRecords' IdeState
ideState NormalizedFilePath
nfp
let actions :: [Command |? CodeAction]
actions = forall a b. (a -> b) -> [a] -> [b]
map (NormalizedFilePath
-> [Extension]
-> NextPragmaInfo
-> RenderedRecordInfo
-> Command |? CodeAction
mkCodeAction NormalizedFilePath
nfp [Extension]
exts NextPragmaInfo
pragma) (forall a. Range -> RangeMap a -> [a]
RangeMap.filterByRange Range
range RangeMap RenderedRecordInfo
recMap)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> List a
List [Command |? CodeAction]
actions
where
mkCodeAction :: NormalizedFilePath -> [Extension] -> NextPragmaInfo -> RenderedRecordInfo -> Command |? CodeAction
mkCodeAction :: NormalizedFilePath
-> [Extension]
-> NextPragmaInfo
-> RenderedRecordInfo
-> Command |? CodeAction
mkCodeAction NormalizedFilePath
nfp [Extension]
exts NextPragmaInfo
pragma RenderedRecordInfo
rec = forall a b. b -> a |? b
InR CodeAction
{ $sel:_title:CodeAction :: Text
_title = [Extension] -> Text
mkCodeActionTitle [Extension]
exts
, $sel:_kind:CodeAction :: Maybe CodeActionKind
_kind = forall a. a -> Maybe a
Just CodeActionKind
CodeActionRefactorRewrite
, $sel:_diagnostics:CodeAction :: Maybe (List Diagnostic)
_diagnostics = forall a. Maybe a
Nothing
, $sel:_isPreferred:CodeAction :: Maybe Bool
_isPreferred = forall a. Maybe a
Nothing
, $sel:_disabled:CodeAction :: Maybe Reason
_disabled = forall a. Maybe a
Nothing
, $sel:_edit:CodeAction :: Maybe WorkspaceEdit
_edit = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
mkWorkspaceEdit NormalizedFilePath
nfp [TextEdit]
edits
, $sel:_command:CodeAction :: Maybe Command
_command = forall a. Maybe a
Nothing
, $sel:_xdata:CodeAction :: Maybe Value
_xdata = forall a. Maybe a
Nothing
}
where
edits :: [TextEdit]
edits = RenderedRecordInfo -> TextEdit
mkTextEdit RenderedRecordInfo
rec forall a. a -> [a] -> [a]
: forall a. Maybe a -> [a]
maybeToList Maybe TextEdit
pragmaEdit
mkTextEdit :: RenderedRecordInfo -> TextEdit
mkTextEdit :: RenderedRecordInfo -> TextEdit
mkTextEdit (RenderedRecordInfo RealSrcSpan
ss Text
r) = Range -> Text -> TextEdit
TextEdit (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
ss) Text
r
pragmaEdit :: Maybe TextEdit
pragmaEdit :: Maybe TextEdit
pragmaEdit = 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
mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
mkWorkspaceEdit NormalizedFilePath
nfp [TextEdit]
edits = Maybe WorkspaceEditMap
-> Maybe (List DocumentChange)
-> Maybe ChangeAnnotationMap
-> WorkspaceEdit
WorkspaceEdit Maybe WorkspaceEditMap
changes forall a. Maybe a
Nothing forall a. Maybe a
Nothing
where
changes :: Maybe WorkspaceEditMap
changes = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton (NormalizedUri -> Uri
fromNormalizedUri (NormalizedFilePath -> NormalizedUri
normalizedFilePathToUri NormalizedFilePath
nfp)) (forall a. [a] -> List a
List [TextEdit]
edits)
mkCodeActionTitle :: [Extension] -> Text
mkCodeActionTitle :: [Extension] -> Text
mkCodeActionTitle [Extension]
exts =
if Extension
NamedFieldPuns forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Extension]
exts
then Text
title
else Text
title forall a. Semigroup a => a -> a -> a
<> Text
" (needs extension: NamedFieldPuns)"
where
title :: Text
title = Text
"Expand record wildcard"
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 (IdeResult v)) -> Rules ()
define (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 k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
nfp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe TcModuleResult
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. Maybe a
Nothing)
Just TcModuleResult
tmr -> do
let exts :: [GhcExtension]
exts = TcModuleResult -> [GhcExtension]
getEnabledExtensions TcModuleResult
tmr
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)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use CollectNames
CollectNames NormalizedFilePath
nfp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe CollectNamesResult
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. Maybe a
Nothing)
Just (CNR NameMap
names) -> do
let renderedRecs :: Maybe [RenderedRecordInfo]
renderedRecs = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (NameMap -> RecordInfo -> Maybe RenderedRecordInfo
renderRecordInfo NameMap
names) [RecordInfo]
recs
recMap :: Maybe (RangeMap RenderedRecordInfo)
recMap = forall a. (a -> Range) -> [a] -> RangeMap a
RangeMap.fromList (RealSrcSpan -> Range
realSrcSpanToRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderedRecordInfo -> RealSrcSpan
renderedSrcSpan) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [RenderedRecordInfo]
renderedRecs
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug ([RenderedRecordInfo] -> Log
LogRenderedRecords (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Maybe [RenderedRecordInfo]
renderedRecs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], RangeMap RenderedRecordInfo
-> [GhcExtension] -> CollectRecordsResult
CRR forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RangeMap RenderedRecordInfo)
recMap forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> Maybe a
Just [GhcExtension]
exts)
where
getEnabledExtensions :: TcModuleResult -> [GhcExtension]
getEnabledExtensions :: TcModuleResult -> [GhcExtension]
getEnabledExtensions = forall a b. (a -> b) -> [a] -> [b]
map Extension -> GhcExtension
GhcExtension forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> [Extension]
getExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcModuleResult -> ParsedModule
tmrParsed
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 (IdeResult v)) -> Rules ()
define forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ \CollectNames
CollectNames NormalizedFilePath
nfp ->
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
nfp forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Maybe TcModuleResult
Nothing -> ([], forall a. Maybe a
Nothing)
Just TcModuleResult
tmr -> ([], forall a. a -> Maybe a
Just (NameMap -> CollectNamesResult
CNR (TcModuleResult -> NameMap
getNames TcModuleResult
tmr)))
getNames :: TcModuleResult -> NameMap
getNames :: TcModuleResult -> NameMap
getNames (TcModuleResult -> RenamedSource
tmrRenamed -> (HsGroup (GhcPass 'Renamed)
group,[LImportDecl (GhcPass 'Renamed)]
_,Maybe [(LIE (GhcPass 'Renamed), Avails)]
_,Maybe LHsDocString
_)) = UniqFM Name [Name] -> NameMap
NameMap (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 RenderedRecordInfo
recordInfos :: RangeMap RenderedRecordInfo
, CollectRecordsResult -> [GhcExtension]
enabledExtensions :: [GhcExtension]
}
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 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 NameMap
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
newtype GhcExtension = GhcExtension { GhcExtension -> Extension
unExt :: Extension }
instance NFData GhcExtension where
rnf :: GhcExtension -> ()
rnf GhcExtension
x = GhcExtension
x seq :: forall a b. a -> b -> b
`seq` ()
newtype NameMap = NameMap (UniqFM Name [Name])
instance NFData NameMap where
rnf :: NameMap -> ()
rnf (NameMap (forall key elt. UniqFM key elt -> IntMap elt
ufmToIntMap -> IntMap [Name]
m)) = forall a. NFData a => a -> ()
rnf IntMap [Name]
m
data RecordInfo
= RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed))
| RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed))
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)
data RenderedRecordInfo = RenderedRecordInfo
{ RenderedRecordInfo -> RealSrcSpan
renderedSrcSpan :: RealSrcSpan
, RenderedRecordInfo -> Text
renderedRecord :: Text
}
deriving (forall x. Rep RenderedRecordInfo x -> RenderedRecordInfo
forall x. RenderedRecordInfo -> Rep RenderedRecordInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RenderedRecordInfo x -> RenderedRecordInfo
$cfrom :: forall x. RenderedRecordInfo -> Rep RenderedRecordInfo x
Generic)
instance Pretty RenderedRecordInfo where
pretty :: forall ann. RenderedRecordInfo -> Doc ann
pretty (RenderedRecordInfo RealSrcSpan
ss Text
r) = 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 Text
r
instance NFData RenderedRecordInfo
renderRecordInfo :: NameMap -> RecordInfo -> Maybe RenderedRecordInfo
renderRecordInfo :: NameMap -> RecordInfo -> Maybe RenderedRecordInfo
renderRecordInfo NameMap
names (RecordInfoPat RealSrcSpan
ss Pat (GhcPass 'Renamed)
pat) = RealSrcSpan -> Text -> RenderedRecordInfo
RenderedRecordInfo RealSrcSpan
ss forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Outputable (Pat (GhcPass 'Renamed)) =>
NameMap -> Pat (GhcPass 'Renamed) -> Maybe Text
showRecordPat NameMap
names Pat (GhcPass 'Renamed)
pat
renderRecordInfo NameMap
_ (RecordInfoCon RealSrcSpan
ss HsExpr (GhcPass 'Renamed)
expr) = RealSrcSpan -> Text -> RenderedRecordInfo
RenderedRecordInfo 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 -> NameMap -> Bool
referencedIn :: Name -> NameMap -> Bool
referencedIn Name
name (NameMap 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) -> NameMap -> [a] -> [a]
filterReferenced :: forall a. (a -> Maybe Name) -> NameMap -> [a] -> [a]
filterReferenced a -> Maybe Name
getName NameMap
names = forall a. (a -> Bool) -> [a] -> [a]
filter (\a
x -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Name -> NameMap -> Bool
`referencedIn` NameMap
names) (a -> Maybe Name
getName a
x))
preprocessRecordPat
:: p ~ GhcPass 'Renamed
=> NameMap
-> HsRecFields p (LPat p)
-> HsRecFields p (LPat p)
preprocessRecordPat :: forall p.
(p ~ GhcPass 'Renamed) =>
NameMap -> HsRecFields p (LPat p) -> HsRecFields p (LPat p)
preprocessRecordPat = forall p (c :: Pass) arg.
(p ~ GhcPass c) =>
(LocatedA (HsRecField p arg) -> Maybe Name)
-> NameMap -> 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)
-> NameMap -> HsRecFields p arg -> HsRecFields p arg
preprocessRecord (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (UniqFM Name [Name] -> NameMap
NameMap forall key elt. UniqFM key elt
emptyUFM)
preprocessRecord
:: p ~ GhcPass c
=> (LocatedA (HsRecField p arg) -> Maybe Name)
-> NameMap
-> HsRecFields p arg
-> HsRecFields p arg
preprocessRecord :: forall p (c :: Pass) arg.
(p ~ GhcPass c) =>
(LocatedA (HsRecField p arg) -> Maybe Name)
-> NameMap -> HsRecFields p arg -> HsRecFields p arg
preprocessRecord GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) arg) -> Maybe Name
getName NameMap
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 b a. b -> (a -> b) -> Maybe a -> b
maybe (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 l e. GenLocated l e -> e
unLoc (forall p arg. HsRecFields p arg -> Maybe (Located Int)
rec_dotdot 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) -> NameMap -> [a] -> [a]
filterReferenced GenLocated SrcSpanAnnA (HsRecField' (FieldOcc p) arg) -> Maybe Name
getName NameMap
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)) => NameMap -> Pat (GhcPass 'Renamed) -> Maybe Text
showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) =>
NameMap -> Pat (GhcPass 'Renamed) -> Maybe Text
showRecordPat NameMap
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) =>
NameMap -> HsRecFields p (LPat p) -> HsRecFields p (LPat p)
preprocessRecordPat NameMap
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 -> GenericQ r
everything forall a. Semigroup a => a -> a -> a
(<>) (forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Maybe a
Nothing forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` LPat (GhcPass 'Renamed) -> Maybe RecordInfo
getRecPatterns forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo
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) -> Maybe RecordInfo
getRecCons :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo
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) -> Maybe RecordInfo
mkRecInfo LHsExpr (GhcPass 'Renamed)
e
where
mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo
mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo
mkRecInfo LHsExpr (GhcPass 'Renamed)
expr = forall a. [a] -> Maybe a
listToMaybe
[ 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)
_ = forall a. Maybe a
Nothing
getRecPatterns :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo
getRecPatterns :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo
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) -> Maybe RecordInfo
mkRecInfo LPat (GhcPass 'Renamed)
conPat
where
mkRecInfo :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo
mkRecInfo :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo
mkRecInfo LPat (GhcPass 'Renamed)
pat = forall a. [a] -> Maybe a
listToMaybe
[ 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)
_ = forall a. Maybe a
Nothing
collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectRecordsResult
collectRecords' :: forall (m :: * -> *).
MonadIO m =>
IdeState
-> NormalizedFilePath -> ExceptT String m CollectRecordsResult
collectRecords' IdeState
ideState =
forall (m :: * -> *) e b.
Monad m =>
e -> m (Maybe b) -> ExceptT e m b
handleMaybeM String
"Unable to TypeCheck"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> IdeState -> Action a -> IO a
runAction String
"ExplicitFields" IdeState
ideState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use CollectRecords
CollectRecords