hls-class-plugin 1.1.1.0 → 1.1.1.1
raw patch · 9 files changed
+140/−40 lines, 9 filesdep ~ghcidedep ~hls-test-utilsPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghcide, hls-test-utils
API changes (from Hackage documentation)
Files
- hls-class-plugin.cabal +3/−2
- src/Ide/Plugin/Class/CodeAction.hs +48/−23
- src/Ide/Plugin/Class/CodeLens.hs +13/−1
- test/Main.hs +34/−14
- test/testdata/AllMethodsRequired.hs +9/−0
- test/testdata/MinimalDefinitionMeet.hs +6/−0
- test/testdata/T1.all.expected.hs +7/−0
- test/testdata/TH.hs +8/−0
- test/testdata/THDef.hs +12/−0
hls-class-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-class-plugin-version: 1.1.1.0+version: 1.1.1.1 synopsis: Class/instance management plugin for Haskell Language Server @@ -39,7 +39,7 @@ , deepseq , extra , ghc- , ghcide ^>=1.9+ , ghcide ^>=1.9 || ^>= 1.10 , ghc-boot-th , hls-graph , hls-plugin-api ^>=1.6@@ -77,3 +77,4 @@ , hls-test-utils ^>=1.5 , lens , lsp-types+ , text
src/Ide/Plugin/Class/CodeAction.hs view
@@ -13,8 +13,10 @@ import Control.Monad.Trans.Except (ExceptT, throwE) import Control.Monad.Trans.Maybe import Data.Aeson+import Data.Bifunctor (second) import Data.Either.Extra (rights) import Data.List+import Data.List.Extra (nubOrdOn) import qualified Data.Map.Strict as Map import Data.Maybe (isNothing, listToMaybe, mapMaybe)@@ -113,30 +115,31 @@ logWith recorder Info (LogImplementedMethods cls implemented) pure $ concatMap mkAction- $ fmap (filter (\(bind, _) -> bind `notElem` implemented))- $ minDefToMethodGroups range sigs- $ classMinimalDef cls+ $ nubOrdOn snd+ $ filter ((/=) mempty . snd)+ $ fmap (second (filter (\(bind, _) -> bind `notElem` implemented)))+ $ mkMethodGroups range sigs cls where range = diag ^. J.range - mkAction :: [(T.Text, T.Text)] -> [Command |? CodeAction]- mkAction methodGroup+ mkMethodGroups :: Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]+ mkMethodGroups range sigs cls = minimalDef <> [allClassMethods]+ where+ minimalDef = minDefToMethodGroups range sigs $ classMinimalDef cls+ allClassMethods = ("all missing methods", makeMethodDefinitions range sigs)++ mkAction :: MethodGroup -> [Command |? CodeAction]+ mkAction (name, methods) = [ mkCodeAction title $ mkLspCommand plId codeActionCommandId title- (Just $ mkCmdParams methodGroup False)+ (Just $ mkCmdParams methods False) , mkCodeAction titleWithSig $ mkLspCommand plId codeActionCommandId titleWithSig- (Just $ mkCmdParams methodGroup True)+ (Just $ mkCmdParams methods 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)"+ title = "Add placeholders for " <> name+ titleWithSig = title <> " with signature(s)" mkCmdParams methodGroup withSig = [toJSON (AddMinimalMethodsParams uri range (List methodGroup) withSig)]@@ -211,15 +214,37 @@ isInstanceValBind (ValBind InstanceBind _ _) = True isInstanceValBind _ = False --- Return (name text, signature text)-minDefToMethodGroups :: Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [[(T.Text, T.Text)]]-minDefToMethodGroups range sigs = go+type MethodSignature = T.Text+type MethodName = T.Text+type MethodDefinition = (MethodName, MethodSignature)+type MethodGroup = (T.Text, [MethodDefinition])++makeMethodDefinition :: InstanceBindTypeSig -> MethodDefinition+makeMethodDefinition sig = (name, signature) 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))- ]]+ name = T.drop (T.length bindingPrefix) (printOutputable (bindName sig))+ signature = bindRendered sig++makeMethodDefinitions :: Range -> [InstanceBindTypeSig] -> [MethodDefinition]+makeMethodDefinitions range sigs =+ [ makeMethodDefinition sig+ | sig <- sigs+ , inRange range (getSrcSpan $ bindName sig)+ ]++signatureToName :: InstanceBindTypeSig -> T.Text+signatureToName sig = T.drop (T.length bindingPrefix) (printOutputable (bindName sig))++-- Return [groupName text, [(methodName text, signature text)]]+minDefToMethodGroups :: Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [MethodGroup]+minDefToMethodGroups range sigs minDef = makeMethodGroup <$> go minDef+ where+ makeMethodGroup methodDefinitions =+ let name = mconcat $ intersperse "," $ (\x -> "'" <> x <> "'") . fst <$> methodDefinitions+ in (name, methodDefinitions)++ go (Var mn) = pure $ makeMethodDefinitions range $ filter ((==) (printOutputable mn) . signatureToName) sigs go (Or ms) = concatMap (go . unLoc) ms go (And ms) = foldr (liftA2 (<>)) [[]] (fmap (go . unLoc) ms) go (Parens m) = go (unLoc m)+
src/Ide/Plugin/Class/CodeLens.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-overlapping-patterns #-} module Ide.Plugin.Class.CodeLens where@@ -90,7 +91,18 @@ getBindSpanWithoutSig ClsInstDecl{..} = let bindNames = mapMaybe go (bagToList cid_binds) go (L l bind) = case bind of- FunBind{..} -> Just $ L l fun_id+ FunBind{..}+ -- `Generated` tagged for Template Haskell,+ -- here we filter out nonsence generated bindings+ -- that are nonsense for displaying code lenses.+ --+ -- See https://github.com/haskell/haskell-language-server/issues/3319+#if MIN_VERSION_ghc(9,5,0)+ | not $ isGenerated (mg_ext fun_matches)+#else+ | not $ isGenerated (mg_origin fun_matches)+#endif+ -> Just $ L l fun_id _ -> Nothing -- Existed signatures' name sigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs
test/Main.hs view
@@ -12,6 +12,7 @@ import Control.Lens (Prism', prism', (^.), (^..), (^?)) import Control.Monad (void) import Data.Maybe+import qualified Data.Text as T import qualified Ide.Plugin.Class as Class import qualified Language.LSP.Types.Lens as J import System.FilePath@@ -31,23 +32,21 @@ codeActionTests :: TestTree codeActionTests = testGroup "code actions"- [ testCase "Produces addMinimalMethodPlaceholders code actions for one instance" $ do- runSessionWithServer classPlugin 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)"- ]+ [ expectCodeActionsAvailable "Produces addMinimalMethodPlaceholders code actions for one instance" "T1"+ [ "Add placeholders for '=='"+ , "Add placeholders for '==' with signature(s)"+ , "Add placeholders for '/='"+ , "Add placeholders for '/=' with signature(s)"+ , "Add placeholders for all missing methods"+ , "Add placeholders for all missing methods with signature(s)"+ ] , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do executeCodeAction eqAction , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ \(_:_:neAction:_) -> do executeCodeAction neAction- , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:fmapAction:_) -> do+ , goldenWithClass "Creates a placeholder for both '==' and '/='" "T1" "all" $ \(_:_:_:_:allMethodsAction:_) -> do+ executeCodeAction allMethodsAction+ , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:_:_:fmapAction:_) -> do executeCodeAction fmapAction , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do executeCodeAction mmAction@@ -70,6 +69,11 @@ executeCodeAction eqWithSig , goldenWithClass "Only insert pragma once" "InsertPragmaOnce" "" $ \(_:multi:_) -> do executeCodeAction multi+ , expectCodeActionsAvailable "No code action available when minimal requirements meet" "MinimalDefinitionMeet" []+ , expectCodeActionsAvailable "Add placeholders for all missing methods is unavailable when all methods are required" "AllMethodsRequired"+ [ "Add placeholders for 'f','g'"+ , "Add placeholders for 'f','g' with signature(s)"+ ] ] codeLensTests :: TestTree@@ -84,6 +88,11 @@ [ "(==) :: B -> B -> Bool" , "(==) :: A -> A -> Bool" ]+ , testCase "No lens for TH" $ do+ runSessionWithServer classPlugin testDataDir $ do+ doc <- openDoc "TH.hs" "haskell"+ lens <- getCodeLenses doc+ liftIO $ length lens @?= 0 , goldenCodeLens "Apply code lens" "CodeLensSimple" 1 , goldenCodeLens "Apply code lens for local class" "LocalClassDefine" 0 , goldenCodeLens "Apply code lens on the same line" "Inline" 0@@ -99,7 +108,6 @@ InR action -> Just action _ -> Nothing - goldenCodeLens :: TestName -> FilePath -> Int -> TestTree goldenCodeLens title path idx = goldenWithHaskellDoc classPlugin title testDataDir path "expected" "hs" $ \doc -> do@@ -114,6 +122,18 @@ actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc act actions void $ skipManyTill anyMessage (getDocumentEdit doc)++expectCodeActionsAvailable :: TestName -> FilePath -> [T.Text] -> TestTree+expectCodeActionsAvailable title path actionTitles =+ testCase title $ do+ runSessionWithServer classPlugin testDataDir $ do+ doc <- openDoc (path <.> "hs") "haskell"+ _ <- waitForDiagnosticsFromSource doc "typecheck"+ caResults <- getAllCodeActions doc+ liftIO $ map (^? _CACodeAction . J.title) caResults+ @?= expectedActions+ where+ expectedActions = Just <$> actionTitles testDataDir :: FilePath testDataDir = "test" </> "testdata"
+ test/testdata/AllMethodsRequired.hs view
@@ -0,0 +1,9 @@+module AllMethodsRequired where++class Test a where+ f :: a+ g :: a+ {-# MINIMAL f,g #-}++instance Test [a] where+
+ test/testdata/MinimalDefinitionMeet.hs view
@@ -0,0 +1,6 @@+module MinimalDefinitionMeet where++data X = X++instance Eq X where+ (==) = _
+ test/testdata/T1.all.expected.hs view
@@ -0,0 +1,7 @@+module T1 where++data X = X++instance Eq X where+ (==) = _+ (/=) = _
+ test/testdata/TH.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}++module TH where++import THDef++gen ''Bool True+gen ''Char 'a'
+ test/testdata/THDef.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}++module THDef where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax++class F a where+ f :: a++gen :: Lift t => Name -> t -> Q [Dec]+gen ty v = [d| instance F $(conT ty) where f = v |]