diff --git a/hls-call-hierarchy-plugin.cabal b/hls-call-hierarchy-plugin.cabal --- a/hls-call-hierarchy-plugin.cabal +++ b/hls-call-hierarchy-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-call-hierarchy-plugin -version: 2.0.0.1 +version: 2.1.0.0 synopsis: Call hierarchy plugin for Haskell Language Server description: Please see the README on GitHub at @@ -33,11 +33,11 @@ , base >=4.12 && <5 , containers , extra - , ghcide == 2.0.0.1 + , ghcide == 2.1.0.0 , hiedb - , hls-plugin-api == 2.0.0.1 + , hls-plugin-api == 2.1.0.0 , lens - , lsp >=1.2.0.1 + , lsp >=2.1.0.0 , sqlite-simple , text , unordered-containers @@ -59,7 +59,7 @@ , extra , filepath , hls-call-hierarchy-plugin - , hls-test-utils == 2.0.0.1 + , hls-test-utils == 2.1.0.0 , ghcide-test-utils , lens , lsp diff --git a/src/Ide/Plugin/CallHierarchy.hs b/src/Ide/Plugin/CallHierarchy.hs --- a/src/Ide/Plugin/CallHierarchy.hs +++ b/src/Ide/Plugin/CallHierarchy.hs @@ -3,12 +3,12 @@ import Development.IDE import qualified Ide.Plugin.CallHierarchy.Internal as X import Ide.Types -import Language.LSP.Types +import Language.LSP.Protocol.Message descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { Ide.Types.pluginHandlers = - mkPluginHandler STextDocumentPrepareCallHierarchy X.prepareCallHierarchy - <> mkPluginHandler SCallHierarchyIncomingCalls X.incomingCalls - <> mkPluginHandler SCallHierarchyOutgoingCalls X.outgoingCalls + mkPluginHandler SMethod_TextDocumentPrepareCallHierarchy X.prepareCallHierarchy + <> mkPluginHandler SMethod_CallHierarchyIncomingCalls X.incomingCalls + <> mkPluginHandler SMethod_CallHierarchyOutgoingCalls X.outgoingCalls } diff --git a/src/Ide/Plugin/CallHierarchy/Internal.hs b/src/Ide/Plugin/CallHierarchy/Internal.hs --- a/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -13,38 +13,38 @@ , outgoingCalls ) where -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Control.Monad.IO.Class -import Data.Aeson as A -import Data.List (groupBy, sortBy) -import qualified Data.Map as M +import Data.Aeson as A +import Data.List (groupBy, sortBy) +import qualified Data.Map as M import Data.Maybe -import qualified Data.Set as S -import qualified Data.Text as T +import qualified Data.Set as S +import qualified Data.Text as T import Data.Tuple.Extra import Development.IDE +import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat as Compat import Development.IDE.Spans.AtPoint -import HieDb (Symbol (Symbol)) -import qualified Ide.Plugin.CallHierarchy.Query as Q +import HieDb (Symbol (Symbol)) +import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types -import Ide.PluginUtils (getNormalizedFilePath, - handleMaybe, pluginResponse, - throwPluginError) +import Ide.Plugin.Error import Ide.Types -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L -import Text.Read (readMaybe) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Text.Read (readMaybe) -- | Render prepare call hierarchy request. -prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy -prepareCallHierarchy state _ param = pluginResponse $ do - nfp <- getNormalizedFilePath (param ^. L.textDocument ^. L.uri) +prepareCallHierarchy :: PluginMethodHandler IdeState Method_TextDocumentPrepareCallHierarchy +prepareCallHierarchy state _ param = do + nfp <- getNormalizedFilePathE (param ^. L.textDocument ^. L.uri) items <- liftIO $ runAction "CallHierarchy.prepareHierarchy" state $ prepareCallHierarchyItem nfp (param ^. L.position) - pure $ List <$> pure items + pure $ InL items prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem] prepareCallHierarchyItem nfp pos = use GetHieAst nfp >>= \case @@ -79,33 +79,33 @@ | Just (RecField RecFieldDecl _) <- recFieldInfo contexts -- ignored type span - = Just $ mkCallHierarchyItem' ident SkField ssp ssp + = Just $ mkCallHierarchyItem' ident SymbolKind_Field ssp ssp | isJust (matchBindInfo contexts) && isNothing (valBindInfo contexts) - = Just $ mkCallHierarchyItem' ident SkFunction ssp ssp + = Just $ mkCallHierarchyItem' ident SymbolKind_Function ssp ssp | Just ctx <- valBindInfo contexts = Just $ case ctx of - ValBind _ _ span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp + ValBind _ _ span -> mkCallHierarchyItem' ident SymbolKind_Function (renderSpan span) ssp _ -> mkCallHierarchyItem' ident skUnknown ssp ssp | Just ctx <- declInfo contexts = Just $ case ctx of - Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp - Decl ConDec span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp - Decl DataDec span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp - Decl FamDec span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp - Decl InstDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp - Decl SynDec span -> mkCallHierarchyItem' ident SkTypeParameter (renderSpan span) ssp + Decl ClassDec span -> mkCallHierarchyItem' ident SymbolKind_Interface (renderSpan span) ssp + Decl ConDec span -> mkCallHierarchyItem' ident SymbolKind_Constructor (renderSpan span) ssp + Decl DataDec span -> mkCallHierarchyItem' ident SymbolKind_Struct (renderSpan span) ssp + Decl FamDec span -> mkCallHierarchyItem' ident SymbolKind_Function (renderSpan span) ssp + Decl InstDec span -> mkCallHierarchyItem' ident SymbolKind_Interface (renderSpan span) ssp + Decl SynDec span -> mkCallHierarchyItem' ident SymbolKind_TypeParameter (renderSpan span) ssp _ -> mkCallHierarchyItem' ident skUnknown ssp ssp | Just (ClassTyDecl span) <- classTyDeclInfo contexts - = Just $ mkCallHierarchyItem' ident SkMethod (renderSpan span) ssp + = Just $ mkCallHierarchyItem' ident SymbolKind_Method (renderSpan span) ssp | Just (PatternBind _ _ span) <- patternBindInfo contexts - = Just $ mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp + = Just $ mkCallHierarchyItem' ident SymbolKind_Function (renderSpan span) ssp - | Just _ <- useInfo contexts = Just $ mkCallHierarchyItem' ident SkInterface ssp ssp + | Just _ <- useInfo contexts = Just $ mkCallHierarchyItem' ident SymbolKind_Interface ssp ssp | Just _ <- tyDeclInfo contexts = renderTyDecl @@ -115,7 +115,9 @@ renderSpan _ = ssp -- https://github.com/haskell/lsp/blob/e11b7c09658610f6d815d04db08a64e7cf6b4467/lsp-types/src/Language/LSP/Types/DocumentSymbol.hs#L97 - skUnknown = SkUnknown 27 -- 27 is the first unused number while ToJSON + -- There is no longer an unknown symbol, thus using SymbolKind_Function + -- as this is the call-hierarchy plugin + skUnknown = SymbolKind_Function mkCallHierarchyItem' = mkCallHierarchyItem nfp @@ -165,16 +167,13 @@ -------------- Incoming calls and outgoing calls --------------------- ---------------------------------------------------------------------- -deriving instance Ord SymbolKind -deriving instance Ord SymbolTag -deriving instance Ord CallHierarchyItem #if !MIN_VERSION_aeson(1,5,2) deriving instance Ord Value #endif -- | Render incoming calls request. -incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls -incomingCalls state pluginId param = pluginResponse $ do +incomingCalls :: PluginMethodHandler IdeState Method_CallHierarchyIncomingCalls +incomingCalls state pluginId param = do calls <- liftIO $ runAction "CallHierarchy.incomingCalls" state $ queryCalls @@ -182,14 +181,14 @@ Q.incomingCalls mkCallHierarchyIncomingCall (mergeCalls CallHierarchyIncomingCall L.from) - pure $ Just $ List calls + pure $ InL $ calls where mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall) mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall -- | Render outgoing calls request. -outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls -outgoingCalls state pluginId param = pluginResponse $ do +outgoingCalls :: PluginMethodHandler IdeState Method_CallHierarchyOutgoingCalls +outgoingCalls state pluginId param = do calls <- liftIO $ runAction "CallHierarchy.outgoingCalls" state $ queryCalls @@ -197,11 +196,10 @@ Q.outgoingCalls mkCallHierarchyOutgoingCall (mergeCalls CallHierarchyOutgoingCall L.to) - pure $ Just $ List calls + pure $ InL $ calls where mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall - -- | Merge calls from the same place mergeCalls constructor target = concatMap merge @@ -210,10 +208,10 @@ where merge [] = [] merge calls@(call:_) = - let ranges = concatMap ((\(List x) -> x) . (^. L.fromRanges)) calls - in [constructor (call ^. target) (List ranges)] + let ranges = concatMap (^. L.fromRanges) calls + in [constructor (call ^. target) ranges] -mkCallHierarchyCall :: (CallHierarchyItem -> List Range -> a) -> Vertex -> Action (Maybe a) +mkCallHierarchyCall :: (CallHierarchyItem -> [Range] -> a) -> Vertex -> Action (Maybe a) mkCallHierarchyCall mk v@Vertex{..} = do let pos = Position (fromIntegral $ sl - 1) (fromIntegral $ sc - 1) nfp = toNormalizedFilePath' hieSrc @@ -225,7 +223,7 @@ prepareCallHierarchyItem nfp pos >>= \case - [item] -> pure $ Just $ mk item (List [range]) + [item] -> pure $ Just $ mk item [range] _ -> do ShakeExtras{withHieDb} <- getShakeExtras sps <- liftIO (withHieDb (`Q.getSymbolPosition` v)) @@ -235,7 +233,7 @@ nfp (Position (fromIntegral $ psl x - 1) (fromIntegral $ psc x - 1)) case items of - [item] -> pure $ Just $ mk item (List [range]) + [item] -> pure $ Just $ mk item [range] _ -> pure Nothing _ -> pure Nothing @@ -259,10 +257,10 @@ | otherwise = pure mempty where uri = item ^. L.uri - xdata = item ^. L.xdata + xdata = item ^. L.data_ pos = item ^. (L.selectionRange . L.start) - getSymbol nfp = case item ^. L.xdata of + getSymbol nfp = case item ^. L.data_ of Just xdata -> case fromJSON xdata of A.Success (symbolStr :: String) -> maybe (getSymbolFromAst nfp pos) (pure . pure) $ readMaybe symbolStr A.Error _ -> getSymbolFromAst nfp pos diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,26 +1,27 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} module Main (main) where -import Control.Lens (set, (^.)) +import Control.Lens (set, (^.)) import Control.Monad.Extra import Data.Aeson -import Data.Functor ((<&>)) -import Data.List (sort, tails) -import qualified Data.Map as M -import qualified Data.Text as T +import Data.Functor ((<&>)) +import Data.List (sort, tails) +import qualified Data.Map as M +import qualified Data.Text as T import Development.IDE.Test import Ide.Plugin.CallHierarchy -import qualified Language.LSP.Test as Test -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Test as Test import System.Directory.Extra import System.FilePath import qualified System.IO.Extra import Test.Hls -import Test.Hls.Util (withCanonicalTempDir) +import Test.Hls.Util (withCanonicalTempDir) plugin :: PluginTestDescriptor () plugin = mkPluginTestDescriptor' descriptor "call-hierarchy" @@ -41,68 +42,68 @@ let contents = T.unlines ["a=3"] range = mkRange 0 0 0 3 selRange = mkRange 0 0 0 1 - expected = mkCallHierarchyItemV "a" SkFunction range selRange + expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange oneCaseWithCreate contents 0 0 expected , testCase "function" $ do let contents = T.unlines ["a=(+)"] range = mkRange 0 0 0 5 selRange = mkRange 0 0 0 1 - expected = mkCallHierarchyItemV "a" SkFunction range selRange + expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange oneCaseWithCreate contents 0 0 expected , testCase "datatype" $ do let contents = T.unlines ["data A=A"] range = mkRange 0 0 0 8 selRange = mkRange 0 5 0 6 - expected = mkCallHierarchyItemT "A" SkStruct range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Struct range selRange oneCaseWithCreate contents 0 5 expected , testCase "data constructor" $ do let contents = T.unlines ["data A=A"] range = mkRange 0 7 0 8 selRange = mkRange 0 7 0 8 - expected = mkCallHierarchyItemC "A" SkConstructor range selRange + expected = mkCallHierarchyItemC "A" SymbolKind_Constructor range selRange oneCaseWithCreate contents 0 7 expected -- , testCase "record" $ do -- let contents = T.unlines ["data A=A{a::Int}"] -- range = mkRange 0 9 0 10 -- selRange = mkRange 0 9 0 10 --- expected = mkCallHierarchyItemV "a" SkField range selRange +-- expected = mkCallHierarchyItemV "a" SymbolKind_Field range selRange -- oneCaseWithCreate contents 0 9 expected , testCase "type operator" $ do let contents = T.unlines ["{-# LANGUAGE TypeOperators #-}", "type (><)=Maybe"] range = mkRange 1 0 1 15 selRange = mkRange 1 5 1 9 - expected = mkCallHierarchyItemT "><" SkTypeParameter range selRange + expected = mkCallHierarchyItemT "><" SymbolKind_TypeParameter range selRange oneCaseWithCreate contents 1 5 expected , testCase "type class" $ do let contents = T.unlines ["class A a where a :: a -> Int"] range = mkRange 0 0 0 29 selRange = mkRange 0 6 0 7 - expected = mkCallHierarchyItemT "A" SkInterface range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange oneCaseWithCreate contents 0 6 expected , testCase "type class method" $ do let contents = T.unlines ["class A a where a :: a -> Int"] range = mkRange 0 16 0 29 selRange = mkRange 0 16 0 17 - expected = mkCallHierarchyItemV "a" SkMethod range selRange + expected = mkCallHierarchyItemV "a" SymbolKind_Method range selRange oneCaseWithCreate contents 0 16 expected , testCase "type class instance" $ do let contents = T.unlines ["class A a where", "instance A () where"] range = mkRange 1 9 1 10 selRange = mkRange 1 9 1 10 - expected = mkCallHierarchyItemT "A" SkInterface range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange oneCaseWithCreate contents 1 9 expected , testGroup "type family" [ testCase "1" $ do let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A"] range = mkRange 1 0 1 13 selRange = mkRange 1 12 1 13 - expected = mkCallHierarchyItemT "A" SkFunction range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange oneCaseWithCreate contents 1 12 expected , testCase "2" $ do let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A a"] range = mkRange 1 0 1 15 selRange = mkRange 1 12 1 13 - expected = mkCallHierarchyItemT "A" SkFunction range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange oneCaseWithCreate contents 1 12 expected ] , testCase "type family instance" $ do @@ -113,20 +114,20 @@ ] range = mkRange 2 14 2 23 selRange = mkRange 2 14 2 15 - expected = mkCallHierarchyItemT "A" SkInterface range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange oneCaseWithCreate contents 2 14 expected , testGroup "data family" [ testCase "1" $ do let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "data family A"] range = mkRange 1 0 1 11 selRange = mkRange 1 12 1 13 - expected = mkCallHierarchyItemT "A" SkFunction range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange oneCaseWithCreate contents 1 12 expected , testCase "2" $ do let contents = T.unlines [ "{-# LANGUAGE TypeFamilies #-}" , "data family A a"] range = mkRange 1 0 1 11 selRange = mkRange 1 12 1 13 - expected = mkCallHierarchyItemT "A" SkFunction range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange oneCaseWithCreate contents 1 12 expected ] , testCase "data family instance" $ do @@ -137,25 +138,25 @@ ] range = mkRange 2 14 2 24 selRange = mkRange 2 14 2 15 - expected = mkCallHierarchyItemT "A" SkInterface range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange oneCaseWithCreate contents 2 14 expected , testCase "pattern" $ do let contents = T.unlines ["Just x = Just 3"] range = mkRange 0 0 0 15 selRange = mkRange 0 5 0 6 - expected = mkCallHierarchyItemV "x" SkFunction range selRange + expected = mkCallHierarchyItemV "x" SymbolKind_Function range selRange oneCaseWithCreate contents 0 5 expected , testCase "pattern with type signature" $ do let contents = T.unlines ["{-# LANGUAGE ScopedTypeVariables #-}", "a :: () = ()"] range = mkRange 1 0 1 12 selRange = mkRange 1 0 1 1 - expected = mkCallHierarchyItemV "a" SkFunction range selRange + expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange oneCaseWithCreate contents 1 0 expected , testCase "type synonym" $ do let contents = T.unlines ["type A=Bool"] range = mkRange 0 0 0 11 selRange = mkRange 0 5 0 6 - expected = mkCallHierarchyItemT "A" SkTypeParameter range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_TypeParameter range selRange oneCaseWithCreate contents 0 5 expected , testCase "GADT" $ do let contents = T.unlines @@ -164,20 +165,20 @@ ] range = mkRange 1 13 1 26 selRange = mkRange 1 13 1 14 - expected = mkCallHierarchyItemC "A" SkConstructor range selRange + expected = mkCallHierarchyItemC "A" SymbolKind_Constructor range selRange oneCaseWithCreate contents 1 13 expected , testGroup "type signature" [ testCase "next line" $ do let contents = T.unlines ["a::Int", "a=3"] range = mkRange 1 0 1 3 selRange = mkRange 1 0 1 1 - expected = mkCallHierarchyItemV "a" SkFunction range selRange + expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange oneCaseWithCreate contents 0 0 expected , testCase "multi functions" $ do let contents = T.unlines [ "a,b::Int", "a=3", "b=4"] range = mkRange 2 0 2 3 selRange = mkRange 2 0 2 1 - expected = mkCallHierarchyItemV "b" SkFunction range selRange + expected = mkCallHierarchyItemV "b" SymbolKind_Function range selRange oneCaseWithCreate contents 0 2 expected ] , testCase "multi pattern" $ do @@ -187,7 +188,7 @@ ] range = mkRange 1 0 1 1 selRange = mkRange 1 0 1 1 - expected = mkCallHierarchyItemV "f" SkFunction range selRange + expected = mkCallHierarchyItemV "f" SymbolKind_Function range selRange oneCaseWithCreate contents 1 0 expected ] @@ -201,11 +202,11 @@ doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] waitForIndex (testDataDir "A.hs") [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) - let expected = [CallHierarchyIncomingCall item (List [mkRange 1 2 1 3])] + let expected = [CallHierarchyIncomingCall item [mkRange 1 2 1 3]] Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>= \case [item] -> do - let itemNoData = set L.xdata Nothing item + let itemNoData = set L.data_ Nothing item Test.incomingCalls (mkIncomingCallsParam itemNoData) >>= \res -> liftIO $ sort expected @=? sort res _ -> liftIO $ assertFailure "Not exactly one element" @@ -326,11 +327,11 @@ doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] waitForIndex (dir "A.hs") [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1) - let expected = [CallHierarchyOutgoingCall item (List [mkRange 1 2 1 3])] + let expected = [CallHierarchyOutgoingCall item [mkRange 1 2 1 3]] Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) >>= \case [item] -> do - let itemNoData = set L.xdata Nothing item + let itemNoData = set L.data_ Nothing item Test.outgoingCalls (mkOutgoingCallsParam itemNoData) >>= \res -> liftIO $ sort expected @=? sort res _ -> liftIO $ assertFailure "Not exactly one element" @@ -421,8 +422,6 @@ ] ] -deriving instance Ord CallHierarchyIncomingCall -deriving instance Ord CallHierarchyOutgoingCall incomingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir -> @@ -506,34 +505,49 @@ _ -> liftIO $ assertFailure "Not one element" closeDoc doc -oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem) -> Assertion +oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem -> Assertion) -> Assertion oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents waitForIndex (dir "A.hs") Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case - [item] -> liftIO $ item @?= expected (doc ^. L.uri) + [item] -> liftIO $ expected (doc ^. L.uri) item res -> liftIO $ assertFailure "Not one element" closeDoc doc -mkCallHierarchyItem' :: String -> T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -mkCallHierarchyItem' prefix name kind range selRange uri = - CallHierarchyItem name kind Nothing (Just "Main") uri range selRange (Just v) +mkCallHierarchyItem' :: String -> T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -> Assertion +mkCallHierarchyItem' prefix name kind range selRange uri c@(CallHierarchyItem name' kind' tags' detail' uri' range' selRange' xdata') = do + assertHierarchyItem name name' + assertHierarchyItem kind kind' + assertHierarchyItem tags tags' + assertHierarchyItem detail detail' + assertHierarchyItem uri uri' + assertHierarchyItem range range' + assertHierarchyItem selRange selRange' + case xdata' of + Nothing -> assertFailure ("In " ++ show c ++ ", got Nothing for data but wanted " ++ show xdata) + Just v -> case fromJSON v of + Success v -> assertBool ("In " ++ show c ++ " wanted data prefix: " ++ show xdata) (xdata `T.isPrefixOf` v) + Error err -> assertFailure ("In " ++ show c ++ " wanted data prefix: " ++ show xdata ++ " but json parsing failed with " ++ show err) where - v = toJSON $ prefix <> ":" <> T.unpack name <> ":Main:main" + tags = Nothing + detail = Just "Main" + assertHierarchyItem :: forall a. (Eq a, Show a) => a -> a -> Assertion + assertHierarchyItem = assertEqual ("In " ++ show c ++ ", got unexpected value for field") + xdata = T.pack prefix <> ":" <> name <> ":Main:main" mkCallHierarchyItemC, mkCallHierarchyItemT, mkCallHierarchyItemV :: - T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem + T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -> Assertion mkCallHierarchyItemC = mkCallHierarchyItem' "c" mkCallHierarchyItemT = mkCallHierarchyItem' "t" mkCallHierarchyItemV = mkCallHierarchyItem' "v" mkCallHierarchyIncomingCall :: (CallHierarchyItem, Range) -> CallHierarchyIncomingCall -mkCallHierarchyIncomingCall (item, range) = CallHierarchyIncomingCall item (List [range]) +mkCallHierarchyIncomingCall (item, range) = CallHierarchyIncomingCall item [range] mkCallHierarchyOutgoingCall :: (CallHierarchyItem, Range) -> CallHierarchyOutgoingCall -mkCallHierarchyOutgoingCall (item, range) = CallHierarchyOutgoingCall item (List [range]) +mkCallHierarchyOutgoingCall (item, range) = CallHierarchyOutgoingCall item [range] testDataDir :: FilePath testDataDir = "test" "testdata"