diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hls-explicit-record-fields-plugin + +## 1.0.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2022, Berk Ozkutuk + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Berk Ozkutuk nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/hls-explicit-record-fields-plugin.cabal b/hls-explicit-record-fields-plugin.cabal new file mode 100644 --- /dev/null +++ b/hls-explicit-record-fields-plugin.cabal @@ -0,0 +1,59 @@ +cabal-version: 3.0 +name: hls-explicit-record-fields-plugin +version: 1.0.0.0 +synopsis: Explicit record fields plugin for Haskell Language Server +description: + Please see the README on GitHub at +license: BSD-3-Clause +license-file: LICENSE +author: Berk Ozkutuk +maintainer: berk.ozkutuk@tweag.io +-- copyright: +category: Development +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: Ide.Plugin.ExplicitFields + -- other-modules: + -- other-extensions: + build-depends: + , base >=4.12 && <5 + , ghcide ^>=1.9 + , hls-plugin-api ^>=1.6 + , lsp + , lens + , hls-graph + , text + , syb + , transformers + , ghc-boot-th + , unordered-containers + , containers + hs-source-dirs: src + default-language: Haskell2010 + +test-suite tests + import: warnings + default-language: Haskell2010 + -- other-modules: + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + , base + , filepath + , text + , hls-explicit-record-fields-plugin + , lsp-test + , hls-test-utils diff --git a/src/Ide/Plugin/ExplicitFields.hs b/src/Ide/Plugin/ExplicitFields.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/ExplicitFields.hs @@ -0,0 +1,373 @@ +{-# 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 = \case + LogShake shakeLog -> pretty shakeLog + LogCollectedRecords recs -> "Collected records with wildcards:" <+> pretty recs + LogRenderedRecords recs -> "Rendered records:" <+> pretty recs + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider + , pluginRules = collectRecordsRule recorder *> collectNamesRule + } + +codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction +codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginResponse $ do + nfp <- getNormalizedFilePath (docId ^. L.uri) + pragma <- getFirstPragma pId ideState nfp + CRR recMap (map unExt -> exts) <- collectRecords' ideState nfp + let actions = map (mkCodeAction nfp exts pragma) (RangeMap.filterByRange range recMap) + pure $ List actions + + where + mkCodeAction :: NormalizedFilePath -> [Extension] -> NextPragmaInfo -> RenderedRecordInfo -> Command |? CodeAction + mkCodeAction nfp exts pragma rec = InR CodeAction + { _title = mkCodeActionTitle exts + , _kind = Just CodeActionRefactorRewrite + , _diagnostics = Nothing + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Just $ mkWorkspaceEdit nfp edits + , _command = Nothing + , _xdata = Nothing + } + 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 $ HashMap.singleton (fromNormalizedUri (normalizedFilePathToUri nfp)) (List edits) + + mkCodeActionTitle :: [Extension] -> Text + mkCodeActionTitle exts = + if NamedFieldPuns `elem` exts + then title + else title <> " (needs extension: NamedFieldPuns)" + where + title = "Expand record wildcard" + +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) + + where + getEnabledExtensions :: TcModuleResult -> [GhcExtension] + getEnabledExtensions = map GhcExtension . getExtensions . tmrParsed + +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))) + +-- | 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) + +data CollectRecords = CollectRecords + deriving (Eq, Show, Generic) + +instance Hashable CollectRecords +instance NFData CollectRecords + +data CollectRecordsResult = CRR + { recordInfos :: RangeMap RenderedRecordInfo + , enabledExtensions :: [GhcExtension] + } + deriving (Generic) + +instance NFData CollectRecordsResult + +instance Show CollectRecordsResult where + show _ = "" + +type instance RuleResult CollectRecords = CollectRecordsResult + +data CollectNames = CollectNames + deriving (Eq, Show, Generic) + +instance Hashable CollectNames +instance NFData CollectNames + +data CollectNamesResult = CNR NameMap + deriving (Generic) + +instance NFData CollectNamesResult + +instance Show CollectNamesResult where + show _ = "" + +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 { unExt :: Extension } + +instance NFData GhcExtension where + rnf x = x `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 (ufmToIntMap -> m)) = rnf m + +data RecordInfo + = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed)) + | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed)) + +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 + +renderRecordInfo :: NameMap -> RecordInfo -> Maybe RenderedRecordInfo +renderRecordInfo names (RecordInfoPat ss pat) = RenderedRecordInfo ss <$> showRecordPat names pat +renderRecordInfo _ (RecordInfoCon ss expr) = RenderedRecordInfo 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 + 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 getName names = filter (\x -> maybe True (`referencedIn` names) (getName x)) + +preprocessRecordPat + :: p ~ GhcPass 'Renamed + => NameMap + -> HsRecFields p (LPat p) + -> HsRecFields p (LPat p) +preprocessRecordPat = preprocessRecord (getFieldName . unLoc) + where + getFieldName x = case unLoc (hfbRHS x) of + VarPat _ x' -> Just $ unLoc x' + _ -> Nothing + +-- 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) + +-- 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 getName names flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' } + where + no_pun_count = maybe (length (rec_flds flds)) unLoc (rec_dotdot flds) + -- Field binds of the explicit form (e.g. `{ a = a' }`) should be + -- left as is, hence the split. + (no_puns, puns) = splitAt no_pun_count (rec_flds 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' = map (mapLoc (\fld -> fld { hfbPun = True })) puns + -- Unused fields are filtered out so that they don't end up in the expanded + -- form. + punsUsed = filterReferenced getName names puns' + rec_flds' = no_puns <> punsUsed + +showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => NameMap -> Pat (GhcPass 'Renamed) -> Maybe Text +showRecordPat names = fmap printOutputable . mapConPatDetail (\case + RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) + _ -> Nothing) + +showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text +showRecordCon expr@(RecordCon _ _ flds) = + Just $ printOutputable $ + expr { rcon_flds = preprocessRecordCon flds } +showRecordCon _ = Nothing + +collectRecords :: GenericQ [RecordInfo] +collectRecords = everything (<>) (maybeToList . (Nothing `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). +-- +-- @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 = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM x [x])) + +getRecCons :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo +getRecCons e@(unLoc -> RecordCon _ _ flds) + | isJust (rec_dotdot flds) = mkRecInfo e + where + mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo + mkRecInfo expr = listToMaybe + [ RecordInfoCon realSpan' (unLoc expr) | RealSrcSpan realSpan' _ <- [ getLoc expr ]] +getRecCons _ = Nothing + +getRecPatterns :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo +getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) + | isJust (rec_dotdot flds) = mkRecInfo conPat + where + mkRecInfo :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo + mkRecInfo pat = listToMaybe + [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]] +getRecPatterns _ = Nothing + +collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectRecordsResult +collectRecords' ideState = + handleMaybeM "Unable to TypeCheck" + . liftIO + . runAction "ExplicitFields" ideState + . use CollectRecords + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Main ( main ) where + +import Data.Either (rights) +import qualified Data.Text as T +import qualified Ide.Plugin.ExplicitFields as ExplicitFields +import System.FilePath ((<.>), ()) +import Test.Hls + + +main :: IO () +main = defaultTestRunner test + +plugin :: PluginTestDescriptor ExplicitFields.Log +plugin = mkPluginTestDescriptor ExplicitFields.descriptor "explicit-fields" + +test :: TestTree +test = testGroup "explicit-fields" + [ mkTest "WildcardOnly" "WildcardOnly" 12 10 12 20 + , mkTest "Unused" "Unused" 12 10 12 20 + , mkTest "Unused2" "Unused2" 12 10 12 20 + , mkTest "WithPun" "WithPun" 13 10 13 25 + , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 + , mkTest "Mixed" "Mixed" 14 10 14 37 + , mkTest "Construction" "Construction" 16 5 16 15 + , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 + , mkTestNoAction "Puns" "Puns" 12 10 12 31 + , mkTestNoAction "Infix" "Infix" 11 11 11 31 + , mkTestNoAction "Prefix" "Prefix" 10 11 10 28 + ] + +mkTestNoAction :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree +mkTestNoAction title fp x1 y1 x2 y2 = + testCase title $ + runSessionWithServer 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 + executeCodeAction act + +getExplicitFieldsActions + :: TextDocumentIdentifier + -> UInt -> UInt -> UInt -> UInt + -> Session [CodeAction] +getExplicitFieldsActions doc x1 y1 x2 y2 = + findExplicitFieldsAction <$> getCodeActions doc range + where + range = Range (Position x1 y1) (Position x2 y2) + +findExplicitFieldsAction :: [a |? CodeAction] -> [CodeAction] +findExplicitFieldsAction = filter isExplicitFieldsCodeAction . rights . map toEither + +isExplicitFieldsCodeAction :: CodeAction -> Bool +isExplicitFieldsCodeAction CodeAction {_title} = + "Expand record wildcard" `T.isPrefixOf` _title + +testDataDir :: FilePath +testDataDir = "test" "testdata"