|
| 1 | +{-# LANGUAGE DataKinds #-} |
| 2 | +{-# LANGUAGE DeriveGeneric #-} |
| 3 | +{-# LANGUAGE FlexibleContexts #-} |
| 4 | +{-# LANGUAGE LambdaCase #-} |
| 5 | +{-# LANGUAGE OverloadedStrings #-} |
| 6 | +{-# LANGUAGE PatternSynonyms #-} |
| 7 | +{-# LANGUAGE TypeFamilies #-} |
| 8 | +{-# LANGUAGE TypeOperators #-} |
| 9 | +{-# LANGUAGE ViewPatterns #-} |
| 10 | + |
| 11 | +module Ide.Plugin.OverloadedRecordDot |
| 12 | + ( descriptor |
| 13 | + , Log |
| 14 | + ) where |
| 15 | + |
| 16 | +-- based off of Berk Okzuturk's hls-explicit-records-fields-plugin |
| 17 | + |
| 18 | +import Control.Lens ((^.)) |
| 19 | +import Control.Monad.IO.Class (MonadIO, liftIO) |
| 20 | +import Control.Monad.Trans.Except (ExceptT) |
| 21 | +import Data.Generics (GenericQ, everything, mkQ) |
| 22 | +import qualified Data.HashMap.Strict as HashMap |
| 23 | +import Data.Maybe (listToMaybe, maybeToList) |
| 24 | +import Data.Text (Text) |
| 25 | +import Development.IDE (IdeState, NormalizedFilePath, |
| 26 | + Pretty (..), Range, |
| 27 | + Recorder (..), Rules, |
| 28 | + WithPriority (..), |
| 29 | + realSrcSpanToRange) |
| 30 | +import Development.IDE.Core.Rules (runAction) |
| 31 | +import Development.IDE.Core.RuleTypes (TcModuleResult (..), |
| 32 | + TypeCheck (..)) |
| 33 | +import Development.IDE.Core.Shake (define, use) |
| 34 | +import qualified Development.IDE.Core.Shake as Shake |
| 35 | +import Development.IDE.GHC.Compat (HsExpr (HsApp, HsPar, HsRecSel, HsVar, OpApp), |
| 36 | + Outputable, getLoc, unLoc) |
| 37 | +import Development.IDE.GHC.Compat.Core (Extension (OverloadedRecordDot), |
| 38 | + GhcPass, LHsExpr, Pass (..), |
| 39 | + RealSrcSpan, hs_valds, |
| 40 | + pattern RealSrcSpan) |
| 41 | +import Development.IDE.GHC.Util (getExtensions, |
| 42 | + printOutputable) |
| 43 | +import Development.IDE.Graph (RuleResult) |
| 44 | +import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) |
| 45 | +import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), |
| 46 | + getFirstPragma, |
| 47 | + insertNewPragma) |
| 48 | +import Development.IDE.Types.Logger (Priority (..), cmapWithPrio, |
| 49 | + logWith, (<+>)) |
| 50 | +import GHC.Generics (Generic) |
| 51 | +import Ide.Plugin.RangeMap (RangeMap) |
| 52 | +import qualified Ide.Plugin.RangeMap as RangeMap |
| 53 | +import Ide.PluginUtils (getNormalizedFilePath, |
| 54 | + handleMaybeM, pluginResponse) |
| 55 | +import Ide.Types (PluginDescriptor (..), |
| 56 | + PluginId (..), |
| 57 | + PluginMethodHandler, |
| 58 | + defaultPluginDescriptor, |
| 59 | + mkPluginHandler) |
| 60 | +import Language.LSP.Types (CodeAction (..), |
| 61 | + CodeActionKind (CodeActionRefactorRewrite), |
| 62 | + CodeActionParams (..), |
| 63 | + Command, List (..), |
| 64 | + Method (..), SMethod (..), |
| 65 | + TextEdit (..), |
| 66 | + WorkspaceEdit (WorkspaceEdit), |
| 67 | + fromNormalizedUri, |
| 68 | + normalizedFilePathToUri, |
| 69 | + type (|?) (InR)) |
| 70 | +import qualified Language.LSP.Types.Lens as L |
| 71 | + |
| 72 | +data Log |
| 73 | + = LogShake Shake.Log |
| 74 | + | LogCollectedRecordSelectors [RecordSelectors] |
| 75 | + | LogRenderedRecordSelectors [ConvertedRecordSelector] |
| 76 | + |
| 77 | +instance Pretty Log where |
| 78 | + pretty = \case |
| 79 | + LogShake shakeLog -> pretty shakeLog |
| 80 | + LogCollectedRecordSelectors recs -> "Collected record selectors:" <+> pretty recs |
| 81 | + LogRenderedRecordSelectors recs -> "Rendered record selectors:" <+> pretty recs |
| 82 | + |
| 83 | +data CollectRecordSelectors = CollectRecordSelectors |
| 84 | + deriving (Eq, Show, Generic) |
| 85 | + |
| 86 | +instance Hashable CollectRecordSelectors |
| 87 | +instance NFData CollectRecordSelectors |
| 88 | + |
| 89 | +data CollectConvertedRecordSelectorsResult = CCRSR |
| 90 | + { recordInfos :: RangeMap ConvertedRecordSelector |
| 91 | + , enabledExtensions :: [GhcExtension] |
| 92 | + } |
| 93 | + deriving (Generic) |
| 94 | + |
| 95 | +instance NFData CollectConvertedRecordSelectorsResult |
| 96 | + |
| 97 | +instance Show CollectConvertedRecordSelectorsResult where |
| 98 | + show _ = "<CollectRecordsResult>" |
| 99 | + |
| 100 | +type instance RuleResult CollectRecordSelectors = CollectConvertedRecordSelectorsResult |
| 101 | + |
| 102 | +-- `Extension` is wrapped so that we can provide an `NFData` instance |
| 103 | +-- (without resorting to creating an orphan instance). |
| 104 | +newtype GhcExtension = GhcExtension { unExt :: Extension } |
| 105 | + |
| 106 | +instance NFData GhcExtension where |
| 107 | + rnf x = x `seq` () |
| 108 | + |
| 109 | +data RecordSelectors |
| 110 | + = RecordSelectors RealSrcSpan (HsExpr (GhcPass 'Renamed)) |
| 111 | + |
| 112 | +instance Pretty RecordSelectors where |
| 113 | + pretty (RecordSelectors ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e) |
| 114 | + |
| 115 | +data ConvertedRecordSelector = ConvertedRecordSelector |
| 116 | + { range :: Range |
| 117 | + , convertedDotRecord :: Text |
| 118 | + } |
| 119 | + deriving (Generic) |
| 120 | + |
| 121 | +instance Pretty ConvertedRecordSelector where |
| 122 | + pretty (ConvertedRecordSelector r cdr) = pretty (show r) <> ":" <+> pretty cdr |
| 123 | + |
| 124 | +instance NFData ConvertedRecordSelector |
| 125 | + |
| 126 | +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState |
| 127 | +descriptor recorder plId = (defaultPluginDescriptor plId) |
| 128 | + { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider |
| 129 | + , pluginRules = collectConvRecSelsRule recorder |
| 130 | + } |
| 131 | + |
| 132 | +codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction |
| 133 | +codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = pluginResponse $ do |
| 134 | + nfp <- getNormalizedFilePath (caDocId ^. L.uri) |
| 135 | + pragma <- getFirstPragma pId ideState nfp |
| 136 | + CCRSR crsMap (map unExt -> exts) <- collectConvRecSels' ideState nfp |
| 137 | + let actions = map (mkCodeAction nfp exts pragma) (RangeMap.filterByRange caRange crsMap) |
| 138 | + pure $ List actions |
| 139 | + where |
| 140 | + mkCodeAction :: NormalizedFilePath -> [Extension] -> NextPragmaInfo -> ConvertedRecordSelector -> Command |? CodeAction |
| 141 | + mkCodeAction nfp exts pragma crs = InR CodeAction |
| 142 | + { _title = mkCodeActionTitle exts |
| 143 | + , _kind = Just CodeActionRefactorRewrite |
| 144 | + , _diagnostics = Nothing |
| 145 | + , _isPreferred = Nothing |
| 146 | + , _disabled = Nothing |
| 147 | + , _edit = Just $ mkWorkspaceEdit nfp edits |
| 148 | + , _command = Nothing |
| 149 | + , _xdata = Nothing |
| 150 | + } |
| 151 | + where |
| 152 | + edits = mkTextEdit crs : maybeToList pragmaEdit |
| 153 | + |
| 154 | + mkTextEdit :: ConvertedRecordSelector -> TextEdit |
| 155 | + mkTextEdit (ConvertedRecordSelector r cdr) = TextEdit r cdr |
| 156 | + |
| 157 | + pragmaEdit :: Maybe TextEdit |
| 158 | + pragmaEdit = if OverloadedRecordDot `elem` exts |
| 159 | + then Nothing |
| 160 | + else Just $ insertNewPragma pragma OverloadedRecordDot |
| 161 | + |
| 162 | + mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit |
| 163 | + mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing |
| 164 | + where |
| 165 | + changes = Just $ HashMap.singleton (fromNormalizedUri (normalizedFilePathToUri nfp)) (List edits) |
| 166 | + |
| 167 | + mkCodeActionTitle :: [Extension] -> Text |
| 168 | + mkCodeActionTitle exts = |
| 169 | + if OverloadedRecordDot `elem` exts |
| 170 | + then title |
| 171 | + else title <> " (needs extension: OverloadedRecordDot)" |
| 172 | + where |
| 173 | + title = "Convert to record dot syntax" |
| 174 | + |
| 175 | +collectConvRecSelsRule :: Recorder (WithPriority Log) -> Rules () |
| 176 | +collectConvRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectRecordSelectors nfp -> |
| 177 | + use TypeCheck nfp >>= \case |
| 178 | + Nothing -> pure ([], Nothing) |
| 179 | + Just tmr -> do |
| 180 | + let exts = getEnabledExtensions tmr |
| 181 | + recSels = getRecordSelectors tmr |
| 182 | + logWith recorder Debug (LogCollectedRecordSelectors recSels) |
| 183 | + let convertedRecordSelectors = traverse convertRecordSelectors recSels |
| 184 | + crsMap = RangeMap.fromList range <$> convertedRecordSelectors |
| 185 | + logWith recorder Debug (LogRenderedRecordSelectors (concat convertedRecordSelectors)) |
| 186 | + pure ([], CCRSR <$> crsMap <*> Just exts) |
| 187 | + where |
| 188 | + getEnabledExtensions :: TcModuleResult -> [GhcExtension] |
| 189 | + getEnabledExtensions = map GhcExtension . getExtensions . tmrParsed |
| 190 | + |
| 191 | +getRecordSelectors :: TcModuleResult -> [RecordSelectors] |
| 192 | +getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = |
| 193 | + collectRecordSelectors valBinds |
| 194 | + |
| 195 | +convertRecordSelectors :: RecordSelectors -> Maybe ConvertedRecordSelector |
| 196 | +convertRecordSelectors (RecordSelectors ss expr) = ConvertedRecordSelector (realSrcSpanToRange ss) <$> convertRecSel expr |
| 197 | + |
| 198 | +convertRecSel :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text |
| 199 | +convertRecSel (HsApp _ s@(unLoc -> HsRecSel _ _) r@(unLoc -> HsVar _ _)) = |
| 200 | + Just $ printOutputable r <> "." <> printOutputable s |
| 201 | +convertRecSel (HsApp _ s@(unLoc -> HsRecSel _ _) r@(unLoc -> HsPar _ _ _ _)) = |
| 202 | + Just $ printOutputable r <> "." <> printOutputable s |
| 203 | +convertRecSel ( OpApp _ s@(unLoc -> HsRecSel _ _) _ r) = |
| 204 | + Just $ "(" <> printOutputable r <> ")." <> printOutputable s |
| 205 | +convertRecSel _ = Nothing |
| 206 | + |
| 207 | +collectRecordSelectors :: GenericQ [RecordSelectors] |
| 208 | +collectRecordSelectors = everything (<>) (maybeToList . (Nothing `mkQ` getRecSels)) |
| 209 | + |
| 210 | +getRecSels :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordSelectors |
| 211 | +-- standard record selection: "field record" |
| 212 | +getRecSels e@(unLoc -> HsApp _ (unLoc -> HsRecSel _ _) (unLoc -> HsVar _ _)) = |
| 213 | + listToMaybe [ RecordSelectors realSpan' (unLoc e) | RealSrcSpan realSpan' _ <- [ getLoc e ]] |
| 214 | +-- Record selection where the field is being applied to a parenthesised expression: "field (record)" |
| 215 | +getRecSels e@(unLoc -> HsApp _ (unLoc -> HsRecSel _ _) (unLoc -> HsPar _ _ _ _)) = |
| 216 | + listToMaybe [ RecordSelectors realSpan' (unLoc e) | RealSrcSpan realSpan' _ <- [ getLoc e ]] |
| 217 | +-- Record selection where the field is being applied with the "$" operator: "field $ record" |
| 218 | +getRecSels e@(unLoc -> OpApp _ (unLoc -> HsRecSel _ _) (unLoc -> HsVar _ (unLoc -> d)) _) |
| 219 | + | printOutputable d == "$" = listToMaybe [ RecordSelectors realSpan' (unLoc e) | RealSrcSpan realSpan' _ <- [ getLoc e ]] |
| 220 | +getRecSels _ = Nothing |
| 221 | + |
| 222 | +collectConvRecSels' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectConvertedRecordSelectorsResult |
| 223 | +collectConvRecSels' ideState = |
| 224 | + handleMaybeM "Unable to TypeCheck" |
| 225 | + . liftIO |
| 226 | + . runAction "overloadedRecordDot.collectRecordSelectors" ideState |
| 227 | + . use CollectRecordSelectors |
| 228 | + |
0 commit comments