{-# 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)))

-- | Collects all 'Name's of a given source file, to be used
-- in the variable usage analysis.
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

-- `Extension` is wrapped so that we can provide an `NFData` instance
-- (without resorting to creating an orphan instance).
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` ()

-- As with `GhcExtension`, this newtype exists mostly to attach
-- an `NFData` instance to `UniqFM`.
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

-- | 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 -> 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

-- Default to leaving the element in if somehow a name can't be extracted (i.e.
-- `getName` returns `Nothing`).
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

-- 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)
-> 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)

-- 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)
  -> 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)
    -- 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) -> 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))

-- | 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 occurence, along with
-- all the occurences 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', and saves us rolling our own newtype wrapper over
-- 'Unique' (since 'Unique' doesn't have an 'Ord' instance, it can't be used
-- as 'Map' key as is). 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) -> 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