diff --git a/hls-class-plugin.cabal b/hls-class-plugin.cabal --- a/hls-class-plugin.cabal +++ b/hls-class-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-class-plugin -version: 1.0.3.0 +version: 1.1.0.0 synopsis: Class/instance management plugin for Haskell Language Server @@ -21,38 +21,63 @@ test/testdata/*.hs library + if impl(ghc >= 9.3) + buildable: False + else + buildable: True exposed-modules: Ide.Plugin.Class + other-modules: Ide.Plugin.Class.CodeAction + , Ide.Plugin.Class.CodeLens + , Ide.Plugin.Class.ExactPrint + , Ide.Plugin.Class.Types + , Ide.Plugin.Class.Utils hs-source-dirs: src build-depends: , aeson , base >=4.12 && <5 , containers + , deepseq + , extra , ghc - , ghc-exactprint >= 0.6.4 - , ghcide ^>=1.7 - , hls-plugin-api ^>=1.4 + , ghcide ^>=1.8 + , ghc-boot-th + , hls-graph + , hls-plugin-api ^>=1.5 , lens , lsp , text , transformers + if impl(ghc >=9.2.1) + build-depends: ghc-exactprint ^>= 1.5 + else + build-depends: ghc-exactprint >= 0.6.4 && <1.1 + default-language: Haskell2010 default-extensions: DataKinds TypeOperators + OverloadedStrings - ghc-options: -Wno-unticked-promoted-constructors + ghc-options: -Wall -Wno-unticked-promoted-constructors -Wno-name-shadowing test-suite tests + if impl(ghc >= 9.3) + buildable: False + else + buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: + , aeson , base , filepath + , ghcide , hls-class-plugin - , hls-test-utils ^>=1.3 + , hls-plugin-api + , hls-test-utils ^>=1.4 , lens , lsp-types diff --git a/src/Ide/Plugin/Class.hs b/src/Ide/Plugin/Class.hs --- a/src/Ide/Plugin/Class.hs +++ b/src/Ide/Plugin/Class.hs @@ -1,255 +1,24 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.Class - ( descriptor - ) where +module Ide.Plugin.Class (descriptor, Log(..)) where -import Control.Applicative -import Control.Lens hiding (List, use) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import Data.Aeson -import Data.Char -import Data.List -import qualified Data.Map.Strict as Map -import Data.Maybe -import qualified Data.Text as T -import qualified Data.Set as Set -import Development.IDE hiding (pluginHandlers) -import Development.IDE.Core.PositionMapping (fromCurrentRange, - toCurrentRange) -import Development.IDE.GHC.Compat as Compat hiding (locA) -import Development.IDE.GHC.Compat.Util -import Development.IDE.Spans.AtPoint -import qualified GHC.Generics as Generics -import Ide.PluginUtils +import Development.IDE (IdeState, Recorder, WithPriority) +import Ide.Plugin.Class.CodeAction +import Ide.Plugin.Class.CodeLens +import Ide.Plugin.Class.Types import Ide.Types -import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Parsers (parseDecl) -import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, Parens) -import Language.Haskell.GHC.ExactPrint.Utils (rs) -import Language.LSP.Server import Language.LSP.Types -import qualified Language.LSP.Types.Lens as J -#if MIN_VERSION_ghc(9,2,0) -import GHC.Hs (AnnsModule(AnnsModule)) -import GHC.Parser.Annotation -#endif - -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginCommands = commands - , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction - } +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginCommands = commands plId + , pluginRules = rules recorder + , pluginHandlers = mkPluginHandler STextDocumentCodeAction (codeAction recorder) + <> mkPluginHandler STextDocumentCodeLens codeLens + } -commands :: [PluginCommand IdeState] -commands - = [ PluginCommand "addMinimalMethodPlaceholders" "add placeholders for minimal methods" addMethodPlaceholders +commands :: PluginId -> [PluginCommand IdeState] +commands plId + = [ PluginCommand codeActionCommandId + "add placeholders for minimal methods" (addMethodPlaceholders plId) + , PluginCommand typeLensCommandId + "add type signatures for instance methods" codeLensCommandHandler ] - --- | Parameter for the addMethods PluginCommand. -data AddMinimalMethodsParams = AddMinimalMethodsParams - { uri :: Uri - , range :: Range - , methodGroup :: List T.Text - } - deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) - -addMethodPlaceholders :: CommandFunction IdeState AddMinimalMethodsParams -addMethodPlaceholders state AddMinimalMethodsParams{..} = do - caps <- getClientCapabilities - medit <- liftIO $ runMaybeT $ do - docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri - pm <- MaybeT . runAction "classplugin" state $ use GetParsedModule docPath - (hsc_dflags . hscEnv -> df) <- MaybeT . runAction "classplugin" state $ use GhcSessionDeps docPath - (old, new) <- makeEditText pm df - pure (workspaceEdit caps old new) - - forM_ medit $ \edit -> - sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - pure (Right Null) - where - indent = 2 - - workspaceEdit caps old new - = diffText caps (uri, old) new IncludeDeletions - - toMethodName n - | Just (h, _) <- T.uncons n - , not (isAlpha h || h == '_') - = "(" <> n <> ")" - | otherwise - = n - -#if MIN_VERSION_ghc(9,2,0) - makeEditText pm df = do - List mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup - let ps = makeDeltaAst $ pm_parsed_source pm - old = T.pack $ exactPrint ps - (ps', _, _) = runTransform (addMethodDecls ps mDecls) - new = T.pack $ exactPrint ps' - pure (old, new) - - makeMethodDecl df mName = - either (const Nothing) Just . parseDecl df (T.unpack mName) . T.unpack - $ toMethodName mName <> " = _" - - addMethodDecls ps mDecls = do - allDecls <- hsDecls ps - let (before, ((L l inst): after)) = break (containRange range . getLoc) allDecls - replaceDecls ps (before ++ (L l (addWhere inst)): (map newLine mDecls ++ after)) - where - -- Add `where` keyword for `instance X where` if `where` is missing. - -- - -- The `where` in ghc-9.2 is now stored in the instance declaration - -- directly. More precisely, giving an `HsDecl GhcPs`, we have: - -- InstD --> ClsInstD --> ClsInstDecl --> XCClsInstDecl --> (EpAnn [AddEpAnn], AnnSortKey), - -- here `AnnEpAnn` keeps the track of Anns. - -- - -- See the link for the original definition: - -- https://hackage.haskell.org/package/ghc-9.2.1/docs/Language-Haskell-Syntax-Extension.html#t:XCClsInstDecl - addWhere (InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) = - let ((EpAnn entry anns comments), key) = cid_ext - in InstD xInstD (ClsInstD ext decl { - cid_ext = (EpAnn - entry - (AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) : anns) - comments - , key) - }) - addWhere decl = decl - - newLine (L l e) = - let dp = deltaPos 1 (indent + 1) -- Not sure why there need one more space - in L (noAnnSrcSpanDP (locA l) dp <> l) e - -#else - makeEditText pm df = do - List (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup - let ps = pm_parsed_source pm - anns = relativiseApiAnns ps (pm_annotations pm) - old = T.pack $ exactPrint ps anns - (ps', (anns', _), _) = runTransform (mergeAnns (mergeAnnList mAnns) anns) (addMethodDecls ps mDecls) - new = T.pack $ exactPrint ps' anns' - pure (old, new) - - makeMethodDecl df mName = - case parseDecl df (T.unpack mName) . T.unpack $ toMethodName mName <> " = _" of - Right (ann, d) -> Just (setPrecedingLines d 1 indent ann, d) - Left _ -> Nothing - - addMethodDecls ps mDecls = do - d <- findInstDecl ps - newSpan <- uniqueSrcSpanT - let - annKey = mkAnnKey d - newAnnKey = AnnKey (rs newSpan) (CN "HsValBinds") - addWhere mkds@(Map.lookup annKey -> Just ann) - = Map.insert newAnnKey ann2 mkds2 - where - ann1 = ann - { annsDP = annsDP ann ++ [(G AnnWhere, DP (0, 1))] - , annCapturedSpan = Just newAnnKey - , annSortKey = Just (fmap (rs . getLoc) mDecls) - } - mkds2 = Map.insert annKey ann1 mkds - ann2 = annNone - { annEntryDelta = DP (1, indent) - } - addWhere _ = panic "Ide.Plugin.Class.addMethodPlaceholder" - modifyAnnsT addWhere - modifyAnnsT (captureOrderAnnKey newAnnKey mDecls) - foldM (insertAfter d) ps (reverse mDecls) - - findInstDecl :: ParsedSource -> Transform (LHsDecl GhcPs) - findInstDecl ps = head . filter (containRange range . getLoc) <$> hsDecls ps -#endif - --- | --- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is --- sensitive to the format of diagnostic messages from GHC. -codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction -codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fromMaybe errorResult) . runMaybeT $ do - docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri - actions <- join <$> mapM (mkActions docPath) methodDiags - pure . Right . List $ actions - where - errorResult = Right (List []) - uri = docId ^. J.uri - List diags = context ^. J.diagnostics - - ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags - methodDiags = filter (\d -> isClassMethodWarning (d ^. J.message)) ghcDiags - - mkActions docPath diag = do - ident <- findClassIdentifier docPath range - cls <- findClassFromIdentifier docPath ident - lift . traverse mkAction . minDefToMethodGroups . classMinimalDef $ cls - where - range = diag ^. J.range - - mkAction methodGroup - = pure $ mkCodeAction title $ mkLspCommand plId "addMinimalMethodPlaceholders" title (Just cmdParams) - where - title = mkTitle methodGroup - cmdParams = mkCmdParams methodGroup - - mkTitle methodGroup - = "Add placeholders for " - <> mconcat (intersperse ", " (fmap (\m -> "'" <> m <> "'") methodGroup)) - - mkCmdParams methodGroup = [toJSON (AddMinimalMethodsParams uri range (List methodGroup))] - - mkCodeAction title cmd - = InR - $ CodeAction title (Just CodeActionQuickFix) (Just (List [])) Nothing Nothing Nothing (Just cmd) Nothing - - findClassIdentifier docPath range = do - (hieAstResult, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath - case hieAstResult of - HAR {hieAst = hf} -> - pure - $ head . head - $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1) - ( (Map.keys . Map.filter isClassNodeIdentifier . Compat.getNodeIds) - <=< nodeChildren - ) - - findClassFromIdentifier docPath (Right name) = do - (hscEnv -> hscenv, _) <- MaybeT . runAction "classplugin" state $ useWithStale GhcSessionDeps docPath - (tmrTypechecked -> thisMod, _) <- MaybeT . runAction "classplugin" state $ useWithStale TypeCheck docPath - MaybeT . fmap snd . initTcWithGbl hscenv thisMod ghostSpan $ do - tcthing <- tcLookup name - case tcthing of - AGlobal (AConLike (RealDataCon con)) - | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls - _ -> panic "Ide.Plugin.Class.findClassFromIdentifier" - findClassFromIdentifier _ (Left _) = panic "Ide.Plugin.Class.findClassIdentifier" - -ghostSpan :: RealSrcSpan -ghostSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "") 1 1 - -containRange :: Range -> SrcSpan -> Bool -containRange range x = isInsideSrcSpan (range ^. J.start) x || isInsideSrcSpan (range ^. J.end) x - -isClassNodeIdentifier :: IdentifierDetails a -> Bool -isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` (identInfo ident) - -isClassMethodWarning :: T.Text -> Bool -isClassMethodWarning = T.isPrefixOf "• No explicit implementation for" - -minDefToMethodGroups :: BooleanFormula Name -> [[T.Text]] -minDefToMethodGroups = go - where - go (Var mn) = [[T.pack . occNameString . occName $ mn]] - go (Or ms) = concatMap (go . unLoc) ms - go (And ms) = foldr (liftA2 (<>)) [[]] (fmap (go . unLoc) ms) - go (Parens m) = go (unLoc m) diff --git a/src/Ide/Plugin/Class/CodeAction.hs b/src/Ide/Plugin/Class/CodeAction.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Class/CodeAction.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Class.CodeAction where + +import Control.Applicative (liftA2) +import Control.Lens hiding (List, use) +import Control.Monad.Extra +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT, throwE) +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Either.Extra (rights) +import Data.List +import qualified Data.Map.Strict as Map +import Data.Maybe (isNothing, listToMaybe, + mapMaybe) +import qualified Data.Set as Set +import qualified Data.Text as T +import Development.IDE +import Development.IDE.Core.PositionMapping (fromCurrentRange) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util +import Development.IDE.Spans.AtPoint (pointCommand) +import GHC.LanguageExtensions.Type +import Ide.Plugin.Class.ExactPrint +import Ide.Plugin.Class.Types +import Ide.Plugin.Class.Utils +import qualified Ide.Plugin.Config +import Ide.PluginUtils +import Ide.Types +import Language.LSP.Server +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as J + +addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams +addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do + caps <- getClientCapabilities + pluginResponse $ do + nfp <- getNormalizedFilePath uri + pm <- handleMaybeM "Unable to GetParsedModule" + $ liftIO + $ runAction "classplugin.addMethodPlaceholders.GetParsedModule" state + $ use GetParsedModule nfp + (hsc_dflags . hscEnv -> df) <- handleMaybeM "Unable to GhcSessionDeps" + $ liftIO + $ runAction "classplugin.addMethodPlaceholders.GhcSessionDeps" state + $ use GhcSessionDeps nfp + (old, new) <- handleMaybeM "Unable to makeEditText" + $ liftIO $ runMaybeT + $ makeEditText pm df param + pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs + let edit = + if withSig + then mergeEdit (workspaceEdit caps old new) pragmaInsertion + else workspaceEdit caps old new + + void $ lift $ sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + + pure Null + where + toTextDocunemtEdit edit = + TextDocumentEdit (VersionedTextDocumentIdentifier uri (Just 0)) (List [InL edit]) + + mergeEdit :: WorkspaceEdit -> [TextEdit] -> WorkspaceEdit + mergeEdit WorkspaceEdit{..} edits = WorkspaceEdit + { _documentChanges = + (\(List x) -> List $ x ++ map (InL . toTextDocunemtEdit) edits) + <$> _documentChanges + , .. + } + + workspaceEdit caps old new + = diffText caps (uri, old) new IncludeDeletions + +-- | +-- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is +-- sensitive to the format of diagnostic messages from GHC. +codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeAction +codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginResponse $ do + nfp <- getNormalizedFilePath uri + actions <- join <$> mapM (mkActions nfp) methodDiags + pure $ List actions + where + uri = docId ^. J.uri + List diags = context ^. J.diagnostics + + ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags + methodDiags = filter (\d -> isClassMethodWarning (d ^. J.message)) ghcDiags + + mkActions + :: NormalizedFilePath + -> Diagnostic + -> ExceptT String (LspT Ide.Plugin.Config.Config IO) [Command |? CodeAction] + mkActions docPath diag = do + (HAR {hieAst = ast}, pmap) <- handleMaybeM "Unable to GetHieAst" + . liftIO + . runAction "classplugin.findClassIdentifier.GetHieAst" state + $ useWithStale GetHieAst docPath + instancePosition <- handleMaybe "No range" $ + fromCurrentRange pmap range ^? _Just . J.start + & fmap (J.character -~ 1) + ident <- findClassIdentifier ast instancePosition + cls <- findClassFromIdentifier docPath ident + InstanceBindTypeSigsResult sigs <- handleMaybeM "Unable to GetInstanceBindTypeSigs" + $ liftIO + $ runAction "classplugin.codeAction.GetInstanceBindTypeSigs" state + $ use GetInstanceBindTypeSigs docPath + implemented <- findImplementedMethods ast instancePosition + logWith recorder Info (LogImplementedMethods cls implemented) + pure + $ concatMap mkAction + $ fmap (filter (\(bind, _) -> bind `notElem` implemented)) + $ minDefToMethodGroups range sigs + $ classMinimalDef cls + where + range = diag ^. J.range + + mkAction :: [(T.Text, T.Text)] -> [Command |? CodeAction] + mkAction methodGroup + = [ mkCodeAction title + $ mkLspCommand plId codeActionCommandId title + (Just $ mkCmdParams methodGroup False) + , mkCodeAction titleWithSig + $ mkLspCommand plId codeActionCommandId titleWithSig + (Just $ mkCmdParams methodGroup True) + ] + where + title = mkTitle $ fst <$> methodGroup + titleWithSig = mkTitleWithSig $ fst <$> methodGroup + + mkTitle methodGroup + = "Add placeholders for " + <> mconcat (intersperse ", " (fmap (\m -> "'" <> m <> "'") methodGroup)) + + mkTitleWithSig methodGroup = mkTitle methodGroup <> " with signature(s)" + + mkCmdParams methodGroup withSig = + [toJSON (AddMinimalMethodsParams uri range (List methodGroup) withSig)] + + mkCodeAction title cmd + = InR + $ CodeAction + title + (Just CodeActionQuickFix) + (Just (List [])) + Nothing + Nothing + Nothing + (Just cmd) + Nothing + + findClassIdentifier hf instancePosition = + handleMaybe "No Identifier found" + $ listToMaybe + $ mapMaybe listToMaybe + $ pointCommand hf instancePosition + ( (Map.keys . Map.filter isClassNodeIdentifier . getNodeIds) + <=< nodeChildren + ) + + findImplementedMethods + :: HieASTs a + -> Position + -> ExceptT String (LspT Ide.Plugin.Config.Config IO) [T.Text] + findImplementedMethods asts instancePosition = do + pure + $ concat + $ pointCommand asts instancePosition + $ map (T.pack . getOccString) . rights . findInstanceValBindIdentifiers + + -- | Recurses through the given AST to find identifiers which are + -- 'InstanceValBind's. + findInstanceValBindIdentifiers :: HieAST a -> [Identifier] + findInstanceValBindIdentifiers ast = + let valBindIds = Map.keys + . Map.filter (any isInstanceValBind . identInfo) + $ getNodeIds ast + in valBindIds <> concatMap findInstanceValBindIdentifiers (nodeChildren ast) + + findClassFromIdentifier docPath (Right name) = do + (hscEnv -> hscenv, _) <- handleMaybeM "Unable to GhcSessionDeps" + . liftIO + . runAction "classplugin.findClassFromIdentifier.GhcSessionDeps" state + $ useWithStale GhcSessionDeps docPath + (tmrTypechecked -> thisMod, _) <- handleMaybeM "Unable to TypeCheck" + . liftIO + . runAction "classplugin.findClassFromIdentifier.TypeCheck" state + $ useWithStale TypeCheck docPath + handleMaybeM "Error in TcEnv" + . liftIO + . fmap snd + . initTcWithGbl hscenv thisMod ghostSpan $ do + tcthing <- tcLookup name + case tcthing of + AGlobal (AConLike (RealDataCon con)) + | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls + _ -> fail "Ide.Plugin.Class.findClassFromIdentifier" + findClassFromIdentifier _ (Left _) = throwE "Ide.Plugin.Class.findClassIdentifier" + +isClassNodeIdentifier :: IdentifierDetails a -> Bool +isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` identInfo ident + +isClassMethodWarning :: T.Text -> Bool +isClassMethodWarning = T.isPrefixOf "• No explicit implementation for" + +isInstanceValBind :: ContextInfo -> Bool +isInstanceValBind (ValBind InstanceBind _ _) = True +isInstanceValBind _ = False + +-- Return (name text, signature text) +minDefToMethodGroups :: Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [[(T.Text, T.Text)]] +minDefToMethodGroups range sigs = go + where + go (Var mn) = [[ (T.pack . occNameString . occName $ mn, bindRendered sig) + | sig <- sigs + , inRange range (getSrcSpan $ bindName sig) + , printOutputable mn == T.drop (T.length bindingPrefix) (printOutputable (bindName sig)) + ]] + go (Or ms) = concatMap (go . unLoc) ms + go (And ms) = foldr (liftA2 (<>)) [[]] (fmap (go . unLoc) ms) + go (Parens m) = go (unLoc m) diff --git a/src/Ide/Plugin/Class/CodeLens.hs b/src/Ide/Plugin/Class/CodeLens.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Class/CodeLens.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} + +module Ide.Plugin.Class.CodeLens where + +import Control.Lens ((^.)) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson +import Data.Maybe (mapMaybe, maybeToList) +import qualified Data.Text as T +import Development.IDE +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util +import GHC.LanguageExtensions.Type +import Ide.Plugin.Class.Types +import Ide.Plugin.Class.Utils +import Ide.PluginUtils +import Ide.Types +import Language.LSP.Server (sendRequest) +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as J + +codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens +codeLens state plId CodeLensParams{..} = pluginResponse $ do + nfp <- getNormalizedFilePath uri + tmr <- handleMaybeM "Unable to typecheck" + $ liftIO + $ runAction "classplugin.TypeCheck" state + $ use TypeCheck nfp + + -- All instance binds + InstanceBindTypeSigsResult allBinds <- + handleMaybeM "Unable to get InstanceBindTypeSigsResult" + $ liftIO + $ runAction "classplugin.GetInstanceBindTypeSigs" state + $ use GetInstanceBindTypeSigs nfp + + pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs + + let (hsGroup, _, _, _) = tmrRenamed tmr + tycls = hs_tyclds hsGroup + -- declared instance methods without signatures + bindInfos = [ bind + | instds <- map group_instds tycls -- class instance decls + , instd <- instds + , inst <- maybeToList $ getClsInstD (unLoc instd) + , bind <- getBindSpanWithoutSig inst + ] + targetSigs = matchBind bindInfos allBinds + makeLens (range, title) = + generateLens plId range title + $ workspaceEdit pragmaInsertion + $ makeEdit range title + codeLens = makeLens <$> mapMaybe getRangeWithSig targetSigs + + pure $ List codeLens + where + uri = _textDocument ^. J.uri + + -- Match Binds with their signatures + -- We try to give every `InstanceBindTypeSig` a `SrcSpan`, + -- hence we can display signatures for `InstanceBindTypeSig` with span later. + matchBind :: [BindInfo] -> [InstanceBindTypeSig] -> [InstanceBindTypeSig] + matchBind existedBinds allBindWithSigs = + [foldl go bindSig existedBinds | bindSig <- allBindWithSigs] + where + -- | The `bindDefSpan` of the bind is `Nothing` before, + -- we update it with the span where binding occurs. + -- Hence, we can infer the place to display the signature later. + update :: InstanceBindTypeSig -> SrcSpan -> InstanceBindTypeSig + update bind sp = bind {bindDefSpan = Just sp} + + go :: InstanceBindTypeSig -> BindInfo -> InstanceBindTypeSig + go bindSig bind = case (srcSpanToRange . bindNameSpan) bind of + Nothing -> bindSig + Just range -> + if inRange range (getSrcSpan $ bindName bindSig) + then update bindSig (bindSpan bind) + else bindSig + + getClsInstD (ClsInstD _ d) = Just d + getClsInstD _ = Nothing + + getSigName (ClassOpSig _ _ sigNames _) = Just $ map unLoc sigNames + getSigName _ = Nothing + + getBindSpanWithoutSig :: ClsInstDecl GhcRn -> [BindInfo] + getBindSpanWithoutSig ClsInstDecl{..} = + let bindNames = mapMaybe go (bagToList cid_binds) + go (L l bind) = case bind of + FunBind{..} -> Just $ L l fun_id + _ -> Nothing + -- Existed signatures' name + sigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs + toBindInfo (L l (L l' _)) = BindInfo + (locA l) -- bindSpan + (locA l') -- bindNameSpan + in toBindInfo <$> filter (\(L _ name) -> unLoc name `notElem` sigNames) bindNames + getBindSpanWithoutSig _ = [] + + -- Get bind definition range with its rendered signature text + getRangeWithSig :: InstanceBindTypeSig -> Maybe (Range, T.Text) + getRangeWithSig bind = do + span <- bindDefSpan bind + range <- srcSpanToRange span + pure (range, bindRendered bind) + + workspaceEdit pragmaInsertion edits = + WorkspaceEdit + (pure [(uri, List $ edits ++ pragmaInsertion)]) + Nothing + Nothing + + generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens + generateLens plId range title edit = + let cmd = mkLspCommand plId typeLensCommandId title (Just [toJSON edit]) + in CodeLens range (Just cmd) Nothing + + makeEdit :: Range -> T.Text -> [TextEdit] + makeEdit range bind = + let startPos = range ^. J.start + insertChar = startPos ^. J.character + insertRange = Range startPos startPos + in [TextEdit insertRange (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")] + +codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit +codeLensCommandHandler _ wedit = do + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return $ Right Null diff --git a/src/Ide/Plugin/Class/ExactPrint.hs b/src/Ide/Plugin/Class/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Class/ExactPrint.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Class.ExactPrint where + +import Control.Monad.Trans.Maybe +import qualified Data.Text as T +import Development.IDE.GHC.Compat +import Ide.Plugin.Class.Types +import Ide.Plugin.Class.Utils +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Parsers +import Language.LSP.Types + +#if MIN_VERSION_ghc(9,2,0) +import Data.Either.Extra (eitherToMaybe) +import GHC.Parser.Annotation +#else +import Control.Monad (foldM) +import qualified Data.Map.Strict as Map +import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) +import Language.Haskell.GHC.ExactPrint.Utils (rs) +#endif + +makeEditText :: Monad m => ParsedModule -> DynFlags -> AddMinimalMethodsParams -> MaybeT m (T.Text, T.Text) +-- addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> TransformT Identity (Located HsModule) +#if MIN_VERSION_ghc(9,2,0) +makeEditText pm df AddMinimalMethodsParams{..} = do + List mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup + let ps = makeDeltaAst $ pm_parsed_source pm + old = T.pack $ exactPrint ps + (ps', _, _) = runTransform (addMethodDecls ps mDecls range withSig) + new = T.pack $ exactPrint ps' + pure (old, new) + +makeMethodDecl :: DynFlags -> (T.Text, T.Text) -> Maybe (LHsDecl GhcPs, LHsDecl GhcPs) +makeMethodDecl df (mName, sig) = do + name <- eitherToMaybe $ parseDecl df (T.unpack mName) . T.unpack $ toMethodName mName <> " = _" + sig' <- eitherToMaybe $ parseDecl df (T.unpack sig) $ T.unpack sig + pure (name, sig') + +addMethodDecls ps mDecls range withSig + | withSig = go (concatMap (\(decl, sig) -> [sig, decl]) mDecls) + | otherwise = go (map fst mDecls) + where + go inserting = do + allDecls <- hsDecls ps + let (before, ((L l inst): after)) = break (inRange range . getLoc) allDecls + replaceDecls ps (before ++ (L l (addWhere inst)): (map newLine inserting ++ after)) + -- Add `where` keyword for `instance X where` if `where` is missing. + -- + -- The `where` in ghc-9.2 is now stored in the instance declaration + -- directly. More precisely, giving an `HsDecl GhcPs`, we have: + -- InstD --> ClsInstD --> ClsInstDecl --> XCClsInstDecl --> (EpAnn [AddEpAnn], AnnSortKey), + -- here `AnnEpAnn` keeps the track of Anns. + -- + -- See the link for the original definition: + -- https://hackage.haskell.org/package/ghc-9.2.1/docs/Language-Haskell-Syntax-Extension.html#t:XCClsInstDecl + addWhere (InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) = + let (EpAnn entry anns comments, key) = cid_ext + in InstD xInstD (ClsInstD ext decl { + cid_ext = (EpAnn + entry + (AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) : anns) + comments + , key) + }) + addWhere decl = decl + + newLine (L l e) = + let dp = deltaPos 1 defaultIndent + in L (noAnnSrcSpanDP (getLoc l) dp <> l) e + +#else + +makeEditText pm df AddMinimalMethodsParams{..} = do + List (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup + let ps = pm_parsed_source pm + anns = relativiseApiAnns ps (pm_annotations pm) + old = T.pack $ exactPrint ps anns + (ps', (anns', _), _) = runTransform (mergeAnns (mergeAnnList mAnns) anns) (addMethodDecls ps mDecls range withSig) + new = T.pack $ exactPrint ps' anns' + pure (old, new) + +makeMethodDecl :: DynFlags -> (T.Text, T.Text) -> Maybe (Anns, (LHsDecl GhcPs, LHsDecl GhcPs)) +makeMethodDecl df (mName, sig) = do + (nameAnn, name) <- case parseDecl df (T.unpack mName) . T.unpack $ toMethodName mName <> " = _" of + Right (ann, d) -> Just (setPrecedingLines d 1 defaultIndent ann, d) + Left _ -> Nothing + (sigAnn, sig) <- case parseDecl df (T.unpack sig) $ T.unpack sig of + Right (ann, d) -> Just (setPrecedingLines d 1 defaultIndent ann, d) + Left _ -> Nothing + pure (mergeAnnList [nameAnn, sigAnn], (name, sig)) + +addMethodDecls ps mDecls range withSig = do + d <- findInstDecl ps range + newSpan <- uniqueSrcSpanT + let decls = if withSig then concatMap (\(decl, sig) -> [sig, decl]) mDecls else map fst mDecls + annKey = mkAnnKey d + newAnnKey = AnnKey (rs newSpan) (CN "HsValBinds") + addWhere mkds@(Map.lookup annKey -> Just ann) = Map.insert newAnnKey ann2 mkds2 + where + ann1 = ann + { annsDP = annsDP ann ++ [(G AnnWhere, DP (0, 1))] + , annCapturedSpan = Just newAnnKey + , annSortKey = Just (fmap (rs . getLoc) decls) + } + mkds2 = Map.insert annKey ann1 mkds + ann2 = annNone + { annEntryDelta = DP (1, defaultIndent) + } + addWhere _ = panic "Ide.Plugin.Class.addMethodPlaceholder" + modifyAnnsT addWhere + modifyAnnsT (captureOrderAnnKey newAnnKey decls) + foldM (insertAfter d) ps (reverse decls) + +findInstDecl :: ParsedSource -> Range -> Transform (LHsDecl GhcPs) +findInstDecl ps range = head . filter (inRange range . getLoc) <$> hsDecls ps +#endif diff --git a/src/Ide/Plugin/Class/Types.hs b/src/Ide/Plugin/Class/Types.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Class/Types.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Class.Types where + +import Control.DeepSeq (rwhnf) +import Control.Monad.Extra (whenMaybe) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson +import Data.Maybe (catMaybes) +import qualified Data.Text as T +import Development.IDE +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat hiding ((<+>)) +import Development.IDE.Graph.Classes +import GHC.Generics +import Ide.Plugin.Class.Utils +import Ide.Types + +typeLensCommandId :: CommandId +typeLensCommandId = "classplugin.typelens" + +codeActionCommandId :: CommandId +codeActionCommandId = "classplugin.codeaction" + +-- | Default indent size for inserting +defaultIndent :: Int +defaultIndent = 2 + +data AddMinimalMethodsParams = AddMinimalMethodsParams + { uri :: Uri + , range :: Range + , methodGroup :: List (T.Text, T.Text) + -- ^ (name text, signature text) + , withSig :: Bool + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +data GetInstanceBindTypeSigs = GetInstanceBindTypeSigs + deriving (Generic, Show, Eq, Ord, Hashable, NFData) + +data InstanceBindTypeSig = InstanceBindTypeSig + { bindName :: Name + , bindRendered :: T.Text + , bindDefSpan :: Maybe SrcSpan + -- ^SrcSpan for the bind definition + } + +newtype InstanceBindTypeSigsResult = + InstanceBindTypeSigsResult [InstanceBindTypeSig] + +instance Show InstanceBindTypeSigsResult where + show _ = "" + +instance NFData InstanceBindTypeSigsResult where + rnf = rwhnf + +type instance RuleResult GetInstanceBindTypeSigs = InstanceBindTypeSigsResult + +data Log + = LogImplementedMethods Class [T.Text] + | LogShake Shake.Log + +instance Pretty Log where + pretty = \case + LogImplementedMethods cls methods -> + pretty ("Detected implmented methods for class" :: String) + <+> pretty (show (getOccString cls) <> ":") -- 'show' is used here to add quotes around the class name + <+> pretty methods + LogShake log -> pretty log + +data BindInfo = BindInfo + { bindSpan :: SrcSpan + -- ^ SrcSpan of the whole binding + , bindNameSpan :: SrcSpan + -- ^ SrcSpan of the binding name + } + +rules :: Recorder (WithPriority Log) -> Rules () +rules recorder = do + define (cmapWithPrio LogShake recorder) $ \GetInstanceBindTypeSigs nfp -> do + tmr <- use TypeCheck nfp + hsc <- use GhcSession nfp + result <- liftIO $ instanceBindType (hscEnv <$> hsc) (tmrTypechecked <$> tmr) + pure ([], result) + where + instanceBindType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe InstanceBindTypeSigsResult) + instanceBindType (Just hsc) (Just gblEnv) = do + let binds = collectHsBindsBinders $ tcg_binds gblEnv + (_, maybe [] catMaybes -> instanceBinds) <- + initTcWithGbl hsc gblEnv ghostSpan $ traverse bindToSig binds + pure $ Just $ InstanceBindTypeSigsResult instanceBinds + where + rdrEnv = tcg_rdr_env gblEnv + showDoc ty = showSDocForUser' hsc (mkPrintUnqualifiedDefault hsc rdrEnv) (pprSigmaType ty) + + bindToSig id = do + let name = idName id + whenMaybe (isBindingName name) $ do + env <- tcInitTidyEnv + let (_, ty) = tidyOpenType env (idType id) + pure $ InstanceBindTypeSig name + (prettyBindingNameString (printOutputable name) <> " :: " <> T.pack (showDoc ty)) + Nothing + instanceBindType _ _ = pure Nothing diff --git a/src/Ide/Plugin/Class/Utils.hs b/src/Ide/Plugin/Class/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Class/Utils.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Class.Utils where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Except +import Data.Char (isAlpha) +import Data.List (isPrefixOf) +import Data.String (IsString) +import qualified Data.Text as T +import Development.IDE +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util +import Development.IDE.Spans.Pragmas (getNextPragmaInfo, + insertNewPragma) +import GHC.LanguageExtensions.Type (Extension) +import Ide.PluginUtils +import Language.LSP.Types + +-- | All instance bindings are started with `$c` +bindingPrefix :: IsString s => s +bindingPrefix = "$c" + +isBindingName :: Name -> Bool +isBindingName name = isPrefixOf bindingPrefix $ occNameString $ nameOccName name + +-- | Check if some `HasSrcSpan` value in the given range +inRange :: Range -> SrcSpan -> Bool +inRange range s = maybe False (subRange range) (srcSpanToRange s) + +ghostSpan :: RealSrcSpan +ghostSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "") 1 1 + +-- | "$cname" ==> "name" +prettyBindingNameString :: T.Text -> T.Text +prettyBindingNameString name + | T.isPrefixOf bindingPrefix name = + toMethodName $ T.drop (T.length bindingPrefix) name + | otherwise = name + +-- | Paren the name for pretty display if necessary +toMethodName :: T.Text -> T.Text +toMethodName n + | Just (h, _) <- T.uncons n + , not (isAlpha h || h == '_') + = "(" <> n <> ")" + | otherwise + = n + +insertPragmaIfNotPresent :: (MonadIO m) + => IdeState + -> NormalizedFilePath + -> Extension + -> ExceptT String m [TextEdit] +insertPragmaIfNotPresent state nfp pragma = do + (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- handleMaybeM "Unable to get GhcSession" + $ liftIO + $ runAction "classplugin.insertPragmaIfNotPresent.GhcSession" state + $ useWithStale GhcSession nfp + (_, fileContents) <- liftIO + $ runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state + $ getFileContents nfp + pm <- handleMaybeM "Unable to GetParsedModuleWithComments" + $ liftIO + $ runAction "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state + $ use GetParsedModuleWithComments nfp + let exts = (toList . extensionFlags . ms_hspp_opts . pm_mod_summary) pm + info = getNextPragmaInfo sessionDynFlags fileContents + pure [insertNewPragma info pragma | pragma `notElem` exts] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,63 +1,123 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} - {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + module Main ( main ) where -import Control.Lens (Prism', prism', (^..), (^?)) -import Control.Monad (void) -import qualified Ide.Plugin.Class as Class -import qualified Language.LSP.Types.Lens as J +import Control.Lens (Prism', prism', (^.), (^..), + (^?)) +import Control.Monad (void) +import Data.Aeson (toJSON, (.=)) +import Data.Functor.Contravariant (contramap) +import Data.Maybe +import Development.IDE.Types.Logger +import qualified Ide.Plugin.Class as Class +import Ide.Plugin.Config (PluginConfig (plcConfig)) +import qualified Ide.Plugin.Config as Plugin +import qualified Language.LSP.Types.Lens as J import System.FilePath import Test.Hls main :: IO () -main = defaultTestRunner tests +main = do + recorder <- makeDefaultStderrRecorder Nothing Debug + defaultTestRunner . tests $ contramap (fmap pretty) recorder -classPlugin :: PluginDescriptor IdeState -classPlugin = Class.descriptor "class" +classPlugin :: Recorder (WithPriority Class.Log) -> PluginDescriptor IdeState +classPlugin recorder = Class.descriptor recorder "class" -tests :: TestTree -tests = testGroup +tests :: Recorder (WithPriority Class.Log) -> TestTree +tests recorder = testGroup "class" + [codeActionTests recorder , codeLensTests recorder] + +codeActionTests :: Recorder (WithPriority Class.Log) -> TestTree +codeActionTests recorder = testGroup + "code actions" [ testCase "Produces addMinimalMethodPlaceholders code actions for one instance" $ do - runSessionWithServer classPlugin testDataDir $ do + runSessionWithServer (classPlugin recorder) testDataDir $ do doc <- openDoc "T1.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" caResults <- getAllCodeActions doc liftIO $ map (^? _CACodeAction . J.title) caResults @?= [ Just "Add placeholders for '=='" + , Just "Add placeholders for '==' with signature(s)" , Just "Add placeholders for '/='" + , Just "Add placeholders for '/=' with signature(s)" ] - , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do + , goldenWithClass recorder "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do executeCodeAction eqAction - , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ \(_:neAction:_) -> do + , goldenWithClass recorder "Creates a placeholder for '/='" "T1" "ne" $ \(_:_:neAction:_) -> do executeCodeAction neAction - , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:fmapAction:_) -> do + , goldenWithClass recorder "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:fmapAction:_) -> do executeCodeAction fmapAction - , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do + , goldenWithClass recorder "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do executeCodeAction mmAction - , goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:mmAction:_) -> do + , goldenWithClass recorder "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:_:mmAction:_) -> do executeCodeAction mmAction - , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do + , goldenWithClass recorder "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do executeCodeAction _fAction - , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do + , goldenWithClass recorder "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do executeCodeAction eqAction + , goldenWithClass recorder "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do + executeCodeAction gAction + , goldenWithClass recorder "Creates a placeholder for other two methods" "T6" "2" $ \(_:_:ghAction:_) -> do + executeCodeAction ghAction + , onlyRunForGhcVersions [GHC92] "Only ghc-9.2 enabled GHC2021 implicitly" $ + goldenWithClass recorder "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $ \(_:eqWithSig:_) -> do + executeCodeAction eqWithSig + , goldenWithClass recorder "Insert pragma if not exist" "InsertWithoutPragma" "" $ \(_:eqWithSig:_) -> do + executeCodeAction eqWithSig + , goldenWithClass recorder "Don't insert pragma if exist" "InsertWithPragma" "" $ \(_:eqWithSig:_) -> do + executeCodeAction eqWithSig + , goldenWithClass recorder "Only insert pragma once" "InsertPragmaOnce" "" $ \(_:multi:_) -> do + executeCodeAction multi ] +codeLensTests :: Recorder (WithPriority Class.Log) -> TestTree +codeLensTests recorder = testGroup + "code lens" + [ testCase "Has code lens" $ do + runSessionWithServer (classPlugin recorder) testDataDir $ do + doc <- openDoc "CodeLensSimple.hs" "haskell" + lens <- getCodeLenses doc + let titles = map (^. J.title) $ mapMaybe (^. J.command) lens + liftIO $ titles @?= + [ "(==) :: B -> B -> Bool" + , "(==) :: A -> A -> Bool" + ] + , goldenCodeLens recorder "Apply code lens" "CodeLensSimple" 1 + , goldenCodeLens recorder "Apply code lens for local class" "LocalClassDefine" 0 + , goldenCodeLens recorder "Apply code lens on the same line" "Inline" 0 + , goldenCodeLens recorder "Don't insert pragma while existing" "CodeLensWithPragma" 0 + , onlyRunForGhcVersions [GHC92] "Only ghc-9.2 enabled GHC2021 implicitly" $ + goldenCodeLens recorder "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0 + , goldenCodeLens recorder "Qualified name" "Qualified" 0 + , goldenCodeLens recorder "Type family" "TypeFamily" 0 + ] + _CACodeAction :: Prism' (Command |? CodeAction) CodeAction _CACodeAction = prism' InR $ \case InR action -> Just action _ -> Nothing -goldenWithClass :: TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree -goldenWithClass title path desc act = - goldenWithHaskellDoc classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do + +goldenCodeLens :: Recorder (WithPriority Class.Log) -> TestName -> FilePath -> Int -> TestTree +goldenCodeLens recorder title path idx = + goldenWithHaskellDoc (classPlugin recorder) title testDataDir path "expected" "hs" $ \doc -> do + lens <- getCodeLenses doc + executeCommand $ fromJust $ (lens !! idx) ^. J.command + void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + +goldenWithClass :: Recorder (WithPriority Class.Log) -> TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree +goldenWithClass recorder title path desc act = + goldenWithHaskellDoc (classPlugin recorder) title testDataDir path (desc <.> "expected") "hs" $ \doc -> do _ <- waitForDiagnosticsFromSource doc "typecheck" actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc act actions diff --git a/test/testdata/CodeLensSimple.expected.hs b/test/testdata/CodeLensSimple.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/CodeLensSimple.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE InstanceSigs #-} +module CodeLensSimple where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ + +data B +instance Eq B where + (==)= _ diff --git a/test/testdata/CodeLensSimple.hs b/test/testdata/CodeLensSimple.hs new file mode 100644 --- /dev/null +++ b/test/testdata/CodeLensSimple.hs @@ -0,0 +1,9 @@ +module CodeLensSimple where + +data A +instance Eq A where + (==) = _ + +data B +instance Eq B where + (==)= _ diff --git a/test/testdata/CodeLensWithGHC2021.expected.hs b/test/testdata/CodeLensWithGHC2021.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/CodeLensWithGHC2021.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GHC2021 #-} +module CodeLensWithGHC2021 where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ diff --git a/test/testdata/CodeLensWithGHC2021.hs b/test/testdata/CodeLensWithGHC2021.hs new file mode 100644 --- /dev/null +++ b/test/testdata/CodeLensWithGHC2021.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE GHC2021 #-} +module CodeLensWithGHC2021 where + +data A +instance Eq A where + (==) = _ diff --git a/test/testdata/CodeLensWithPragma.expected.hs b/test/testdata/CodeLensWithPragma.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/CodeLensWithPragma.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE InstanceSigs #-} +module CodeLensWithPragma where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ diff --git a/test/testdata/CodeLensWithPragma.hs b/test/testdata/CodeLensWithPragma.hs new file mode 100644 --- /dev/null +++ b/test/testdata/CodeLensWithPragma.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE InstanceSigs #-} +module CodeLensWithPragma where + +data A +instance Eq A where + (==) = _ diff --git a/test/testdata/Inline.expected.hs b/test/testdata/Inline.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Inline.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE InstanceSigs #-} +module Inline where + +data A +instance Eq A where (==) :: A -> A -> Bool + (==) = _ diff --git a/test/testdata/Inline.hs b/test/testdata/Inline.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Inline.hs @@ -0,0 +1,4 @@ +module Inline where + +data A +instance Eq A where (==) = _ diff --git a/test/testdata/InsertPragmaOnce.expected.hs b/test/testdata/InsertPragmaOnce.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/InsertPragmaOnce.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE InstanceSigs #-} +module InsertPragmaOnce where + +data A aaa +instance Applicative A where + pure :: a -> A a + pure = _ + (<*>) :: A (a -> b) -> A a -> A b + (<*>) = _ diff --git a/test/testdata/InsertPragmaOnce.hs b/test/testdata/InsertPragmaOnce.hs new file mode 100644 --- /dev/null +++ b/test/testdata/InsertPragmaOnce.hs @@ -0,0 +1,4 @@ +module InsertPragmaOnce where + +data A aaa +instance Applicative A diff --git a/test/testdata/InsertWithGHC2021Enabled.expected.hs b/test/testdata/InsertWithGHC2021Enabled.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/InsertWithGHC2021Enabled.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GHC2021#-} +module InsertWithGHC2021Enabled where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ diff --git a/test/testdata/InsertWithGHC2021Enabled.hs b/test/testdata/InsertWithGHC2021Enabled.hs new file mode 100644 --- /dev/null +++ b/test/testdata/InsertWithGHC2021Enabled.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GHC2021#-} +module InsertWithGHC2021Enabled where + +data A +instance Eq A diff --git a/test/testdata/InsertWithPragma.expected.hs b/test/testdata/InsertWithPragma.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/InsertWithPragma.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE InstanceSigs #-} +module InsertWithPragma where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ diff --git a/test/testdata/InsertWithPragma.hs b/test/testdata/InsertWithPragma.hs new file mode 100644 --- /dev/null +++ b/test/testdata/InsertWithPragma.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE InstanceSigs #-} +module InsertWithPragma where + +data A +instance Eq A diff --git a/test/testdata/InsertWithoutPragma.expected.hs b/test/testdata/InsertWithoutPragma.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/InsertWithoutPragma.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE InstanceSigs #-} +module InsertWithoutPragma where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ diff --git a/test/testdata/InsertWithoutPragma.hs b/test/testdata/InsertWithoutPragma.hs new file mode 100644 --- /dev/null +++ b/test/testdata/InsertWithoutPragma.hs @@ -0,0 +1,4 @@ +module InsertWithoutPragma where + +data A +instance Eq A diff --git a/test/testdata/LocalClassDefine.expected.hs b/test/testdata/LocalClassDefine.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LocalClassDefine.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE InstanceSigs #-} +module LocalClassDefine where + +data A +class F a where + f :: a -> Int + +instance F A where + f :: A -> Int + f = _ diff --git a/test/testdata/LocalClassDefine.hs b/test/testdata/LocalClassDefine.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LocalClassDefine.hs @@ -0,0 +1,8 @@ +module LocalClassDefine where + +data A +class F a where + f :: a -> Int + +instance F A where + f = _ diff --git a/test/testdata/Qualified.expected.hs b/test/testdata/Qualified.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Qualified.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE InstanceSigs #-} +module Qualified where +import qualified QualifiedA + +class F a where + f :: a + +instance F QualifiedA.A where + f :: QualifiedA.A + f = undefined diff --git a/test/testdata/Qualified.hs b/test/testdata/Qualified.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Qualified.hs @@ -0,0 +1,8 @@ +module Qualified where +import qualified QualifiedA + +class F a where + f :: a + +instance F QualifiedA.A where + f = undefined diff --git a/test/testdata/QualifiedA.hs b/test/testdata/QualifiedA.hs new file mode 100644 --- /dev/null +++ b/test/testdata/QualifiedA.hs @@ -0,0 +1,3 @@ +module QualifiedA where + +data A diff --git a/test/testdata/T6.1.expected.hs b/test/testdata/T6.1.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T6.1.expected.hs @@ -0,0 +1,22 @@ +module T6 where + +data X = X | Y + +class Test a where + f :: a -> a + f = h + + g :: a + + h :: a -> a + h = f + + i :: a + + {-# MINIMAL f, g, i | g, h #-} + +instance Test X where + f X = X + f Y = Y + i = undefined + g = _ diff --git a/test/testdata/T6.2.expected.hs b/test/testdata/T6.2.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T6.2.expected.hs @@ -0,0 +1,23 @@ +module T6 where + +data X = X | Y + +class Test a where + f :: a -> a + f = h + + g :: a + + h :: a -> a + h = f + + i :: a + + {-# MINIMAL f, g, i | g, h #-} + +instance Test X where + f X = X + f Y = Y + i = undefined + g = _ + h = _ diff --git a/test/testdata/T6.expected.hs b/test/testdata/T6.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T6.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GHC2021#-} +module T6 where + +data A +instance Eq A where + (==) :: A -> A -> Bool + (==) = _ diff --git a/test/testdata/T6.hs b/test/testdata/T6.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T6.hs @@ -0,0 +1,21 @@ +module T6 where + +data X = X | Y + +class Test a where + f :: a -> a + f = h + + g :: a + + h :: a -> a + h = f + + i :: a + + {-# MINIMAL f, g, i | g, h #-} + +instance Test X where + f X = X + f Y = Y + i = undefined diff --git a/test/testdata/TypeFamily.expected.hs b/test/testdata/TypeFamily.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeFamily.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE InstanceSigs #-} +module TypeFamily where + +class F a where + type Elem a + f :: Elem a -> a + +instance Eq a => F [a] where + f :: Eq a => Elem [a] -> [a] + f = _ diff --git a/test/testdata/TypeFamily.hs b/test/testdata/TypeFamily.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeFamily.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies #-} +module TypeFamily where + +class F a where + type Elem a + f :: Elem a -> a + +instance Eq a => F [a] where + f = _