diff --git a/hls-explicit-record-fields-plugin.cabal b/hls-explicit-record-fields-plugin.cabal --- a/hls-explicit-record-fields-plugin.cabal +++ b/hls-explicit-record-fields-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hls-explicit-record-fields-plugin -version: 2.1.0.0 +version: 2.2.0.0 synopsis: Explicit record fields plugin for Haskell Language Server description: Please see the README on GitHub at @@ -19,6 +19,11 @@ type: git location: https://github.com/haskell/haskell-language-server +flag pedantic + description: Enable -Werror + default: False + manual: True + common warnings ghc-options: -Wall @@ -29,8 +34,9 @@ -- other-extensions: build-depends: , base >=4.12 && <5 - , ghcide == 2.1.0.0 - , hls-plugin-api == 2.1.0.0 + , ghc + , ghcide == 2.2.0.0 + , hls-plugin-api == 2.2.0.0 , lsp , lens , hls-graph @@ -40,9 +46,14 @@ , ghc-boot-th , unordered-containers , containers + , aeson hs-source-dirs: src default-language: Haskell2010 + if flag(pedantic) + ghc-options: -Werror + -Wwarn=incomplete-record-updates + test-suite tests import: warnings default-language: Haskell2010 diff --git a/src/Ide/Plugin/ExplicitFields.hs b/src/Ide/Plugin/ExplicitFields.hs --- a/src/Ide/Plugin/ExplicitFields.hs +++ b/src/Ide/Plugin/ExplicitFields.hs @@ -1,38 +1,43 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# 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.Except (ExceptT, runExceptT) -import Data.Functor ((<&>)) -import Data.Generics (GenericQ, everything, extQ, - mkQ) +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, - listToMaybe, maybeToList) + maybeToList) import Data.Text (Text) -import Development.IDE (IdeState, NormalizedFilePath, - Pretty (..), Recorder (..), - Rules, WithPriority (..), - realSrcSpanToRange) +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 Development.IDE.Core.Shake (define, use) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (HsConDetails (RecCon), HsRecFields (..), LPat, @@ -49,134 +54,147 @@ hs_valds, lookupUFM, mapConPatDetail, mapLoc, pattern RealSrcSpan, - plusUFM_C, ufmToIntMap, - unitUFM) + plusUFM_C, unitUFM) import Development.IDE.GHC.Util (getExtensions, printOutputable) import Development.IDE.Graph (RuleResult) -import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) +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, - getNormalizedFilePathE) +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, - defaultPluginDescriptor, - mkPluginHandler) + ResolveFunction, + defaultPluginDescriptor) import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message (Method (..), SMethod (..)) +import Language.LSP.Protocol.Message (Method (..)) import Language.LSP.Protocol.Types (CodeAction (..), CodeActionKind (CodeActionKind_RefactorRewrite), CodeActionParams (..), Command, TextEdit (..), WorkspaceEdit (WorkspaceEdit), - fromNormalizedUri, - normalizedFilePathToUri, type (|?) (InL, InR)) +#if MIN_VERSION_ghc(9,0,0) +import Development.IDE.GHC.Compat (HsExpansion (HsExpanded), + HsExpr (XExpr)) +#endif data Log = LogShake Shake.Log | LogCollectedRecords [RecordInfo] - | LogRenderedRecords [RenderedRecordInfo] + | LogRenderedRecords [TextEdit] + | forall a. (Pretty a) => LogResolve a + instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog LogCollectedRecords recs -> "Collected records with wildcards:" <+> pretty recs - LogRenderedRecords recs -> "Rendered records:" <+> pretty recs + LogRenderedRecords recs -> "Rendered records:" <+> viaShow recs + LogResolve msg -> pretty msg descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider +descriptor recorder plId = + let resolveRecorder = cmapWithPrio LogResolve recorder + (carCommands, caHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider codeActionResolveProvider + in (defaultPluginDescriptor plId) + { pluginHandlers = caHandlers + , pluginCommands = carCommands , pluginRules = collectRecordsRule recorder *> collectNamesRule } codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction -codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = do +codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do nfp <- getNormalizedFilePathE (docId ^. L.uri) - pragma <- getFirstPragma pId ideState nfp - CRR recMap exts <- collectRecords' ideState nfp - let actions = map (mkCodeAction nfp exts pragma) (RangeMap.filterByRange range recMap) + CRR {crCodeActions, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp + -- All we need to build a code action is the list of extensions, and a int to + -- allow us to resolve it later. + let actions = map (mkCodeAction enabledExtensions) (RangeMap.filterByRange range crCodeActions) pure $ InL actions - where - mkCodeAction :: NormalizedFilePath -> [Extension] -> NextPragmaInfo -> RenderedRecordInfo -> Command |? CodeAction - mkCodeAction nfp exts pragma rec = InR CodeAction - { _title = mkCodeActionTitle exts + mkCodeAction :: [Extension] -> Int -> Command |? CodeAction + mkCodeAction exts uid = InR CodeAction + { _title = "Expand record wildcard" + <> if NamedFieldPuns `elem` exts + then mempty + else " (needs extension: NamedFieldPuns)" , _kind = Just CodeActionKind_RefactorRewrite , _diagnostics = Nothing , _isPreferred = Nothing , _disabled = Nothing - , _edit = Just $ mkWorkspaceEdit nfp edits + , _edit = Nothing , _command = Nothing - , _data_ = Nothing + , _data_ = Just $ toJSON uid } - where - edits = mkTextEdit rec : maybeToList pragmaEdit - mkTextEdit :: RenderedRecordInfo -> TextEdit - mkTextEdit (RenderedRecordInfo ss r) = TextEdit (realSrcSpanToRange ss) r - - pragmaEdit :: Maybe TextEdit - pragmaEdit = if NamedFieldPuns `elem` exts - then Nothing - else Just $ insertNewPragma pragma NamedFieldPuns - - mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit - mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing - where - changes = Just $ Map.singleton (fromNormalizedUri (normalizedFilePathToUri nfp)) edits - - mkCodeActionTitle :: [Extension] -> Text - mkCodeActionTitle exts = - if NamedFieldPuns `elem` exts - then title - else title <> " (needs extension: NamedFieldPuns)" - where - title = "Expand record wildcard" +codeActionResolveProvider :: ResolveFunction IdeState Int 'Method_CodeActionResolve +codeActionResolveProvider ideState pId ca uri uid = do + nfp <- getNormalizedFilePathE uri + pragma <- getFirstPragma pId ideState nfp + CRR {crCodeActionResolve, nameMap, enabledExtensions} <- runActionE "ExplicitFields.CollectRecords" ideState $ useE CollectRecords nfp + -- If we are unable to find the unique id in our IntMap of records, it means + -- that this resolve is stale. + record <- handleMaybe PluginStaleResolve $ IntMap.lookup uid crCodeActionResolve + -- We should never fail to render + rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfo nameMap record + let edits = [rendered] + <> maybeToList (pragmaEdit enabledExtensions pragma) + pure $ ca & L.edit ?~ mkWorkspaceEdit edits + where + mkWorkspaceEdit ::[TextEdit] -> WorkspaceEdit + mkWorkspaceEdit edits = WorkspaceEdit (Just $ Map.singleton uri edits) Nothing Nothing + pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit + pragmaEdit exts pragma = if NamedFieldPuns `elem` exts + then Nothing + else Just $ insertNewPragma pragma NamedFieldPuns collectRecordsRule :: Recorder (WithPriority Log) -> Rules () -collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> - use TypeCheck nfp >>= \case - Nothing -> pure ([], Nothing) - Just tmr -> do - let exts = getEnabledExtensions tmr - recs = getRecords tmr - logWith recorder Debug (LogCollectedRecords recs) - use CollectNames nfp >>= \case - Nothing -> pure ([], Nothing) - Just (CNR names) -> do - let renderedRecs = traverse (renderRecordInfo names) recs - recMap = RangeMap.fromList (realSrcSpanToRange . renderedSrcSpan) <$> renderedRecs - logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) - pure ([], CRR <$> recMap <*> Just exts) - +collectRecordsRule recorder = + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> runMaybeT $ do + tmr <- useMT TypeCheck nfp + (CNR nameMap) <- useMT CollectNames nfp + let recs = getRecords tmr + logWith recorder Debug (LogCollectedRecords recs) + -- We want a list of unique numbers to link our the original code action we + -- give out, with the actual record info that we resolve it to. + uniques <- liftIO $ replicateM (length recs) (hashUnique <$> newUnique) + let recsWithUniques = zip uniques recs + -- For creating the code actions, a RangeMap of unique ids + crCodeActions = RangeMap.fromList' (toRangeAndUnique <$> recsWithUniques) + -- For resolving the code actions, a IntMap which links the unique id to + -- the relevant record info. + crCodeActionResolve = IntMap.fromList recsWithUniques + enabledExtensions = getEnabledExtensions tmr + pure CRR {crCodeActions, crCodeActionResolve, nameMap, enabledExtensions} where getEnabledExtensions :: TcModuleResult -> [Extension] getEnabledExtensions = getExtensions . tmrParsed + toRangeAndUnique (uid, recordInfo) = (recordInfoToRange recordInfo, uid) getRecords :: TcModuleResult -> [RecordInfo] getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds collectNamesRule :: Rules () -collectNamesRule = define mempty $ \CollectNames nfp -> - use TypeCheck nfp <&> \case - Nothing -> ([], Nothing) - Just tmr -> ([], Just (CNR (getNames tmr))) +collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ do + tmr <- useMT TypeCheck nfp + pure (CNR (getNames tmr)) -- | Collects all 'Name's of a given source file, to be used -- in the variable usage analysis. -getNames :: TcModuleResult -> NameMap -getNames (tmrRenamed -> (group,_,_,_)) = NameMap (collectNames group) +getNames :: TcModuleResult -> UniqFM Name [Name] +getNames (tmrRenamed -> (group,_,_,_)) = collectNames group data CollectRecords = CollectRecords deriving (Eq, Show, Generic) @@ -184,13 +202,26 @@ instance Hashable CollectRecords instance NFData CollectRecords +-- |The result of our map, this record includes everything we need to provide +-- code actions and resolve them later data CollectRecordsResult = CRR - { recordInfos :: RangeMap RenderedRecordInfo - , enabledExtensions :: [Extension] + { -- |For providing the code action we need the unique id (Int) in a RangeMap + crCodeActions :: RangeMap Int + -- |For resolving the code action we need to link the unique id we + -- previously gave out with the record info that we use to make the edit + -- with. + , crCodeActionResolve :: IntMap.IntMap RecordInfo + -- |The name map allows us to prune unused record fields (some of the time) + , nameMap :: UniqFM Name [Name] + -- |We need to make sure NamedFieldPuns is enabled, if it's not we need to + -- add that to the text edit. (In addition we use it in creating the code + -- action title) + , enabledExtensions :: [Extension] } deriving (Generic) instance NFData CollectRecordsResult +instance NFData RecordInfo instance Show CollectRecordsResult where show _ = "" @@ -203,7 +234,7 @@ instance Hashable CollectNames instance NFData CollectNames -data CollectNamesResult = CNR NameMap +data CollectNamesResult = CNR (UniqFM Name [Name]) deriving (Generic) instance NFData CollectNamesResult @@ -213,55 +244,42 @@ type instance RuleResult CollectNames = CollectNamesResult --- As with `GhcExtension`, this newtype exists mostly to attach --- an `NFData` instance to `UniqFM`.(without resorting to creating an orphan instance). -newtype NameMap = NameMap (UniqFM Name [Name]) - -instance NFData NameMap where - rnf (NameMap (ufmToIntMap -> m)) = rnf m - data RecordInfo = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed)) | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed)) + deriving (Generic) instance Pretty RecordInfo where pretty (RecordInfoPat ss p) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable p) pretty (RecordInfoCon ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e) -data RenderedRecordInfo = RenderedRecordInfo - { renderedSrcSpan :: RealSrcSpan - , renderedRecord :: Text - } - deriving (Generic) - -instance Pretty RenderedRecordInfo where - pretty (RenderedRecordInfo ss r) = pretty (printOutputable ss) <> ":" <+> pretty r - -instance NFData RenderedRecordInfo +recordInfoToRange :: RecordInfo -> Range +recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss +recordInfoToRange (RecordInfoCon ss _) = realSrcSpanToRange ss -renderRecordInfo :: NameMap -> RecordInfo -> Maybe RenderedRecordInfo -renderRecordInfo names (RecordInfoPat ss pat) = RenderedRecordInfo ss <$> showRecordPat names pat -renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecordCon expr +renderRecordInfo :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit +renderRecordInfo names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat +renderRecordInfo _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon 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 names) = maybe True hasNonBindingOcc $ lookupUFM names name +referencedIn :: Name -> UniqFM Name [Name] -> Bool +referencedIn name names = maybe True hasNonBindingOcc $ lookupUFM names name where hasNonBindingOcc :: [Name] -> Bool hasNonBindingOcc = (> 1) . 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 :: (a -> Maybe Name) -> UniqFM Name [Name] -> [a] -> [a] filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) (getName x)) preprocessRecordPat :: p ~ GhcPass 'Renamed - => NameMap + => UniqFM Name [Name] -> HsRecFields p (LPat p) -> HsRecFields p (LPat p) preprocessRecordPat = preprocessRecord (getFieldName . unLoc) @@ -272,7 +290,7 @@ -- No need to check the name usage in the record construction case preprocessRecordCon :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg -preprocessRecordCon = preprocessRecord (const Nothing) (NameMap emptyUFM) +preprocessRecordCon = preprocessRecord (const Nothing) emptyUFM -- This function does two things: -- 1) Tweak the AST type so that the pretty-printed record is in the @@ -293,7 +311,7 @@ preprocessRecord :: p ~ GhcPass c => (LocatedA (HsRecField p arg) -> Maybe Name) - -> NameMap + -> UniqFM Name [Name] -> HsRecFields p arg -> HsRecFields p arg preprocessRecord getName names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } @@ -311,7 +329,7 @@ punsUsed = filterReferenced getName names puns' rec_flds' = no_puns <> punsUsed -showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => NameMap -> Pat (GhcPass 'Renamed) -> Maybe Text +showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text showRecordPat names = fmap printOutputable . mapConPatDetail (\case RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) _ -> Nothing) @@ -323,42 +341,48 @@ showRecordCon _ = Nothing collectRecords :: GenericQ [RecordInfo] -collectRecords = everything (<>) (maybeToList . (Nothing `mkQ` getRecPatterns `extQ` getRecCons)) +collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` 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). +-- each individual list of names contains the binding occurrence, along with +-- all the occurrences at the use-sites (if there are any). -- -- @UniqFM Name [Name]@ is morally the same as @Map Unique [Name]@. -- Using 'UniqFM' gains us a bit of performance (in theory) since it --- internally uses 'IntMap', 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 +-- internally uses 'IntMap'. More information regarding 'UniqFM' can be found in -- the GHC source. collectNames :: GenericQ (UniqFM Name [Name]) collectNames = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM x [x])) -getRecCons :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo +getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool) +-- When we stumble upon an occurrence of HsExpanded, we only want to follow a +-- single branch. We do this here, by explicitly returning occurrences from +-- traversing the original branch, and returning True, which keeps syb from +-- implicitly continuing to traverse. In addition, we have to return a list, +-- because there is a possibility that there were be more than one result per +-- branch + +#if MIN_VERSION_ghc(9,0,0) +getRecCons (unLoc -> XExpr (HsExpanded a _)) = (collectRecords a, True) +#endif + getRecCons e@(unLoc -> RecordCon _ _ flds) - | isJust (rec_dotdot flds) = mkRecInfo e + | isJust (rec_dotdot flds) = (mkRecInfo e, False) where - mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo - mkRecInfo expr = listToMaybe + mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> [RecordInfo] + mkRecInfo expr = [ RecordInfoCon realSpan' (unLoc expr) | RealSrcSpan realSpan' _ <- [ getLoc expr ]] -getRecCons _ = Nothing +getRecCons _ = ([], False) -getRecPatterns :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo +getRecPatterns :: LPat (GhcPass 'Renamed) -> ([RecordInfo], Bool) getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) - | isJust (rec_dotdot flds) = mkRecInfo conPat + | isJust (rec_dotdot flds) = (mkRecInfo conPat, False) where - mkRecInfo :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo - mkRecInfo pat = listToMaybe + mkRecInfo :: LPat (GhcPass 'Renamed) -> [RecordInfo] + mkRecInfo pat = [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]] -getRecPatterns _ = Nothing +getRecPatterns _ = ([], False) -collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT PluginError m CollectRecordsResult -collectRecords' ideState = runActionE "ExplicitFields" ideState - . useE CollectRecords diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -11,7 +11,6 @@ import System.FilePath ((<.>), ()) import Test.Hls - main :: IO () main = defaultTestRunner test @@ -27,6 +26,8 @@ , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 , mkTest "Mixed" "Mixed" 14 10 14 37 , mkTest "Construction" "Construction" 16 5 16 15 + , mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20 + , mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22 , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 , mkTestNoAction "Puns" "Puns" 12 10 12 31 , mkTestNoAction "Infix" "Infix" 11 11 11 31 @@ -36,23 +37,27 @@ mkTestNoAction :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree mkTestNoAction title fp x1 y1 x2 y2 = testCase title $ - runSessionWithServer plugin (testDataDir "noop") $ do + runSessionWithServer def plugin (testDataDir "noop") $ do doc <- openDoc (fp <.> "hs") "haskell" actions <- getExplicitFieldsActions doc x1 y1 x2 y2 liftIO $ actions @?= [] -mkTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree -mkTest title fp x1 y1 x2 y2 = - goldenWithHaskellDoc plugin title testDataDir fp "expected" "hs" $ \doc -> do - (act:_) <- getExplicitFieldsActions doc x1 y1 x2 y2 +mkTestWithCount :: Int -> TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree +mkTestWithCount cnt title fp x1 y1 x2 y2 = + goldenWithHaskellAndCaps def codeActionResolveCaps plugin title testDataDir fp "expected" "hs" $ \doc -> do + acts@(act:_) <- getExplicitFieldsActions doc x1 y1 x2 y2 + liftIO $ length acts @?= cnt executeCodeAction act +mkTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree +mkTest = mkTestWithCount 1 + getExplicitFieldsActions :: TextDocumentIdentifier -> UInt -> UInt -> UInt -> UInt -> Session [CodeAction] getExplicitFieldsActions doc x1 y1 x2 y2 = - findExplicitFieldsAction <$> getCodeActions doc range + findExplicitFieldsAction <$> getAndResolveCodeActions doc range where range = Range (Position x1 y1) (Position x2 y2) diff --git a/test/testdata/HsExpanded1.expected.hs b/test/testdata/HsExpanded1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/HsExpanded1.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NamedFieldPuns #-} + +module HsExpanded1 where +import Prelude + +ifThenElse :: Int -> Int -> Int -> Int +ifThenElse x y z = x + y + z + +data MyRec = MyRec + { foo :: Int } + +myRecExample = MyRec 5 + +convertMe :: Int +convertMe = + if (let MyRec {foo} = myRecExample + in foo) then 1 else 2 diff --git a/test/testdata/HsExpanded1.hs b/test/testdata/HsExpanded1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/HsExpanded1.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NamedFieldPuns #-} + +module HsExpanded1 where +import Prelude + +ifThenElse :: Int -> Int -> Int -> Int +ifThenElse x y z = x + y + z + +data MyRec = MyRec + { foo :: Int } + +myRecExample = MyRec 5 + +convertMe :: Int +convertMe = + if (let MyRec {..} = myRecExample + in foo) then 1 else 2 diff --git a/test/testdata/HsExpanded2.expected.hs b/test/testdata/HsExpanded2.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/HsExpanded2.expected.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NamedFieldPuns #-} + +module HsExpanded2 where +import Prelude + +ifThenElse :: Int -> Int -> Int -> Int +ifThenElse x y z = x + y + z + +data MyRec = MyRec + { foo :: Int } + +data YourRec = YourRec + { bar :: Int } + +myRecExample = MyRec 5 + +yourRecExample = YourRec 3 + +convertMe :: Int +convertMe = + if (let MyRec {..} = myRecExample + YourRec {bar} = yourRecExample + in bar) then 1 else 2 diff --git a/test/testdata/HsExpanded2.hs b/test/testdata/HsExpanded2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/HsExpanded2.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NamedFieldPuns #-} + +module HsExpanded2 where +import Prelude + +ifThenElse :: Int -> Int -> Int -> Int +ifThenElse x y z = x + y + z + +data MyRec = MyRec + { foo :: Int } + +data YourRec = YourRec + { bar :: Int } + +myRecExample = MyRec 5 + +yourRecExample = YourRec 3 + +convertMe :: Int +convertMe = + if (let MyRec {..} = myRecExample + YourRec {..} = yourRecExample + in bar) then 1 else 2