From 2a49384fcdfd7e8e2e6089d04921f91dd264667e Mon Sep 17 00:00:00 2001 From: fendor Date: Thu, 29 Aug 2019 12:07:15 +0200 Subject: [PATCH 1/5] Add different Contexts for Module, import etc... --- haskell-ide-engine.cabal | 2 + hie-plugin-api/Haskell/Ide/Engine/Context.hs | 36 +++++- src/Haskell/Ide/Engine/LSP/Completions.hs | 1 + test/testdata/context/ExampleContext.hs | 8 ++ test/testdata/context/Foo/Bar.hs | 3 + test/unit/ContextSpec.hs | 112 +++++++++++++++++++ 6 files changed, 161 insertions(+), 1 deletion(-) create mode 100644 test/testdata/context/ExampleContext.hs create mode 100644 test/testdata/context/Foo/Bar.hs create mode 100644 test/unit/ContextSpec.hs diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 2d9968975..405e7b3f8 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -177,6 +177,7 @@ test-suite unit-test main-is: Main.hs other-modules: ApplyRefactPluginSpec CodeActionsSpec + ContextSpec DiffSpec ExtensibleStateSpec GhcModPluginSpec @@ -196,6 +197,7 @@ test-suite unit-test , directory , filepath , free + , ghc , haskell-ide-engine , haskell-lsp-types >= 0.15.0.0 , hie-test-utils diff --git a/hie-plugin-api/Haskell/Ide/Engine/Context.hs b/hie-plugin-api/Haskell/Ide/Engine/Context.hs index 410410f7f..959c00809 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Context.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE LambdaCase #-} module Haskell.Ide.Engine.Context where import Data.Generics +import Data.List (find) import Language.Haskell.LSP.Types import GHC import qualified GhcModCore as GM (GhcPs) -- for GHC 8.2.2 @@ -13,13 +15,37 @@ import Haskell.Ide.Engine.PluginUtils -- smarter code completion data Context = TypeContext | ValueContext + | ModuleContext String + | ImportContext String + | ExportContext deriving (Show, Eq) -- | Generates a map of where the context is a type and where the context is a value -- i.e. where are the value decls and the type decls getContext :: Position -> ParsedModule -> Maybe Context -getContext pos pm = everything join (Nothing `mkQ` go `extQ` goInline) decl +getContext pos pm + | Just (L (RealSrcSpan r) modName) <- moduleHeader + , pos `isInsideRange` r + = Just (ModuleContext (moduleNameString modName)) + + | Just (L (RealSrcSpan r) _) <- exportList + , pos `isInsideRange` r + = Just ExportContext + + | Just ctx <- everything join (Nothing `mkQ` go `extQ` goInline) decl + = Just ctx + + | Just (L _ impDecl) <- importRegion + = Just (ImportContext (moduleNameString $ unLoc $ ideclName impDecl)) + + | otherwise + = Nothing + where decl = hsmodDecls $ unLoc $ pm_parsed_source pm + moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm + exportList = hsmodExports $ unLoc $ pm_parsed_source pm + imports = hsmodImports $ unLoc $ pm_parsed_source pm + go :: LHsDecl GM.GhcPs -> Maybe Context go (L (RealSrcSpan r) (SigD {})) | pos `isInsideRange` r = Just TypeContext @@ -37,3 +63,11 @@ getContext pos pm = everything join (Nothing `mkQ` go `extQ` goInline) decl join (Just x) _ = Just x p `isInsideRange` r = sp <= p && p <= ep where (sp, ep) = unpackRealSrcSpan r + + importRegion = find + (\case + (L (RealSrcSpan r) _) -> pos `isInsideRange` r + _ -> False + ) + imports + diff --git a/src/Haskell/Ide/Engine/LSP/Completions.hs b/src/Haskell/Ide/Engine/LSP/Completions.hs index b9471b595..0eebb396e 100644 --- a/src/Haskell/Ide/Engine/LSP/Completions.hs +++ b/src/Haskell/Ide/Engine/LSP/Completions.hs @@ -373,6 +373,7 @@ getCompletions uri prefixInfo (WithSnippets withSnippets) = ctxCompls' = case context of TypeContext -> filter isTypeCompl compls ValueContext -> filter (not . isTypeCompl) compls + _ -> [] -- Add whether the text to insert has backticks ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls' diff --git a/test/testdata/context/ExampleContext.hs b/test/testdata/context/ExampleContext.hs new file mode 100644 index 000000000..bd2e983d6 --- /dev/null +++ b/test/testdata/context/ExampleContext.hs @@ -0,0 +1,8 @@ +module ExampleContext (foo) where + +import Data.List +import Control.Monad + +foo :: Int -> Int +foo xs = xs + 1 + diff --git a/test/testdata/context/Foo/Bar.hs b/test/testdata/context/Foo/Bar.hs new file mode 100644 index 000000000..0d6044ee8 --- /dev/null +++ b/test/testdata/context/Foo/Bar.hs @@ -0,0 +1,3 @@ +module Foo.Bar where + + diff --git a/test/unit/ContextSpec.hs b/test/unit/ContextSpec.hs new file mode 100644 index 000000000..69583d68b --- /dev/null +++ b/test/unit/ContextSpec.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} +module ContextSpec where + + +import Test.Hspec + +import GHC ( tm_parsed_module ) +import System.Directory + +import Haskell.Ide.Engine.PluginApi +import Haskell.Ide.Engine.PluginsIdeMonads +import Haskell.Ide.Engine.PluginUtils +import Haskell.Ide.Engine.ModuleCache +import Haskell.Ide.Engine.Context + +import TestUtils + +spec :: Spec +spec = describe "Context of different cursor positions" $ do + it "can set the module as type checked" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp <- makeAbsolute "./ExampleContext.hs" + let arg = filePathToUri fp + let res = IdeResultOk (Nothing :: Maybe Context) + actual <- runSingle (IdePlugins mempty) $ do + _ <- setTypecheckedModule arg + return $ IdeResultOk Nothing + + actual `shouldBe` res + + it "module header context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just (ModuleContext "ExampleContext")) + + actual <- getContextAt fp_ (toPos (1, 10)) + + actual `shouldBe` res + + + it "module export list context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just ExportContext) + actual <- getContextAt fp_ (toPos (1, 24)) + + actual `shouldBe` res + + it "value context" $ withCurrentDirectory "./test/testdata/context" $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just ValueContext) + actual <- getContextAt fp_ (toPos (7, 6)) + + actual `shouldBe` res + + it "value context" $ withCurrentDirectory "./test/testdata/context" $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just ValueContext) + actual <- getContextAt fp_ (toPos (7, 12)) + + actual `shouldBe` res + + it "import context" $ withCurrentDirectory "./test/testdata/context" $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just (ImportContext "Data.List")) + actual <- getContextAt fp_ (toPos (3, 8)) + + actual `shouldBe` res + + it "function declaration context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just TypeContext) + actual <- getContextAt fp_ (toPos (6, 1)) + + actual `shouldBe` res + + + it "function definition context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just ValueContext) + actual <- getContextAt fp_ (toPos (7, 1)) + actual `shouldBe` res + + it "function signature context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just TypeContext) + actual <- getContextAt fp_ (toPos (6, 8)) + actual `shouldBe` res + + it "nothing" $ withCurrentDirectory "./test/testdata/context" $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk Nothing + actual <- getContextAt fp_ (toPos (2, 1)) + actual `shouldBe` res + +getContextAt :: [Char] -> Position -> IO (IdeResult (Maybe Context)) +getContextAt fp_ pos = do + let arg = filePathToUri fp_ + runSingle (IdePlugins mempty) $ do + _ <- setTypecheckedModule arg + pluginGetFile "getContext: " arg $ \fp -> + ifCachedModuleAndData fp (IdeResultOk Nothing) $ \tm _ () -> + return $ IdeResultOk $ getContext pos (tm_parsed_module tm) From cc7510bf1cfdaec25a5b015bd17971d4a3d864b8 Mon Sep 17 00:00:00 2001 From: fendor Date: Thu, 29 Aug 2019 12:32:14 +0200 Subject: [PATCH 2/5] Make sure Completions has identical behaviour --- src/Haskell/Ide/Engine/LSP/Completions.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Haskell/Ide/Engine/LSP/Completions.hs b/src/Haskell/Ide/Engine/LSP/Completions.hs index 0eebb396e..482ae02aa 100644 --- a/src/Haskell/Ide/Engine/LSP/Completions.hs +++ b/src/Haskell/Ide/Engine/LSP/Completions.hs @@ -373,7 +373,7 @@ getCompletions uri prefixInfo (WithSnippets withSnippets) = ctxCompls' = case context of TypeContext -> filter isTypeCompl compls ValueContext -> filter (not . isTypeCompl) compls - _ -> [] + _ -> filter (not . isTypeCompl) compls -- Add whether the text to insert has backticks ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls' From 2060ad09bb53fb65d13bec0d2335267aa2076a0a Mon Sep 17 00:00:00 2001 From: fendor Date: Thu, 29 Aug 2019 17:57:43 +0200 Subject: [PATCH 3/5] Add more contexts --- hie-plugin-api/Haskell/Ide/Engine/Context.hs | 59 +++++++++++++----- test/testdata/context/ExampleContext.hs | 13 +++- test/unit/ContextSpec.hs | 65 +++++++++++++++++++- 3 files changed, 118 insertions(+), 19 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Context.hs b/hie-plugin-api/Haskell/Ide/Engine/Context.hs index 959c00809..fa463a629 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Context.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE LambdaCase #-} module Haskell.Ide.Engine.Context where import Data.Generics -import Data.List (find) +import Data.Foldable (asum) import Language.Haskell.LSP.Types import GHC import qualified GhcModCore as GM (GhcPs) -- for GHC 8.2.2 import Haskell.Ide.Engine.PluginUtils +import Control.Applicative ( (<|>) ) -- | A context of a declaration in the program -- e.g. is the declaration a type declaration or a value declaration @@ -17,7 +17,12 @@ data Context = TypeContext | ValueContext | ModuleContext String | ImportContext String + | ImportListContext String + | ImportHidingContext String | ExportContext + | InstanceContext + | ClassContext + | DerivingContext deriving (Show, Eq) -- | Generates a map of where the context is a type and where the context is a value @@ -32,42 +37,64 @@ getContext pos pm , pos `isInsideRange` r = Just ExportContext - | Just ctx <- everything join (Nothing `mkQ` go `extQ` goInline) decl + | Just ctx <- everything (<|>) (Nothing `mkQ` go `extQ` goInline) decl = Just ctx - | Just (L _ impDecl) <- importRegion - = Just (ImportContext (moduleNameString $ unLoc $ ideclName impDecl)) + | Just ctx <- asum $ map importGo imports + = Just ctx | otherwise = Nothing - + where decl = hsmodDecls $ unLoc $ pm_parsed_source pm moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm exportList = hsmodExports $ unLoc $ pm_parsed_source pm imports = hsmodImports $ unLoc $ pm_parsed_source pm go :: LHsDecl GM.GhcPs -> Maybe Context - go (L (RealSrcSpan r) (SigD {})) + go (L (RealSrcSpan r) SigD {}) | pos `isInsideRange` r = Just TypeContext | otherwise = Nothing - go (L (GHC.RealSrcSpan r) (GHC.ValD {})) + go (L (GHC.RealSrcSpan r) GHC.ValD {}) | pos `isInsideRange` r = Just ValueContext | otherwise = Nothing + go (L (GHC.RealSrcSpan r) GHC.InstD {}) + | pos `isInsideRange` r = Just InstanceContext + | otherwise = Nothing + go (L (GHC.RealSrcSpan r) GHC.DerivD {}) + | pos `isInsideRange` r = Just DerivingContext + | otherwise = Nothing + go (L (GHC.RealSrcSpan r) (GHC.TyClD _ GHC.ClassDecl {})) + | pos `isInsideRange` r = Just ClassContext + | otherwise = Nothing go _ = Nothing + goInline :: GHC.LHsType GM.GhcPs -> Maybe Context goInline (GHC.L (GHC.RealSrcSpan r) _) | pos `isInsideRange` r = Just TypeContext | otherwise = Nothing goInline _ = Nothing - join Nothing x = x - join (Just x) _ = Just x + p `isInsideRange` r = sp <= p && p <= ep where (sp, ep) = unpackRealSrcSpan r - importRegion = find - (\case - (L (RealSrcSpan r) _) -> pos `isInsideRange` r - _ -> False - ) - imports + importGo :: GHC.LImportDecl GM.GhcPs -> Maybe Context + importGo (L (RealSrcSpan r) impDecl) + | pos `isInsideRange` r + = importInline importModuleName (ideclHiding impDecl) + <|> Just (ImportContext importModuleName) + + | otherwise = Nothing + where importModuleName = moduleNameString $ unLoc $ ideclName impDecl + + importGo _ = Nothing + + importInline :: String -> Maybe (Bool, GHC.Located [GHC.LIE GM.GhcPs]) -> Maybe Context + importInline modName (Just (True, L (RealSrcSpan r) _)) + | pos `isInsideRange` r = Just $ ImportHidingContext modName + | otherwise = Nothing + importInline modName (Just (False, L (RealSrcSpan r) _)) + | pos `isInsideRange` r = Just $ ImportListContext modName + | otherwise = Nothing + importInline _ _ = Nothing diff --git a/test/testdata/context/ExampleContext.hs b/test/testdata/context/ExampleContext.hs index bd2e983d6..fd28d4b61 100644 --- a/test/testdata/context/ExampleContext.hs +++ b/test/testdata/context/ExampleContext.hs @@ -1,8 +1,17 @@ module ExampleContext (foo) where -import Data.List -import Control.Monad +import Data.List (find) +import Control.Monad hiding (fix) foo :: Int -> Int foo xs = xs + 1 +data Foo a = Foo a + deriving (Show) + +class Bar a where + bar :: a -> Integer + +instance Integral a => Bar (Foo a) where + bar (Foo a) = toInteger a + diff --git a/test/unit/ContextSpec.hs b/test/unit/ContextSpec.hs index 69583d68b..4f9120bc9 100644 --- a/test/unit/ContextSpec.hs +++ b/test/unit/ContextSpec.hs @@ -56,7 +56,7 @@ spec = describe "Context of different cursor positions" $ do actual `shouldBe` res - it "value context" $ withCurrentDirectory "./test/testdata/context" $ do + it "value addition context" $ withCurrentDirectory "./test/testdata/context" $ do fp_ <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just ValueContext) actual <- getContextAt fp_ (toPos (7, 12)) @@ -70,6 +70,13 @@ spec = describe "Context of different cursor positions" $ do actual `shouldBe` res + it "import list context" $ withCurrentDirectory "./test/testdata/context" $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just (ImportListContext "Data.List")) + actual <- getContextAt fp_ (toPos (3, 20)) + + actual `shouldBe` res + it "function declaration context" $ withCurrentDirectory "./test/testdata/context" $ do @@ -96,6 +103,62 @@ spec = describe "Context of different cursor positions" $ do actual <- getContextAt fp_ (toPos (6, 8)) actual `shouldBe` res + it "data declaration context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk Nothing + actual <- getContextAt fp_ (toPos (9, 8)) + actual `shouldBe` res + + it "class declaration context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just ClassContext) + actual <- getContextAt fp_ (toPos (12, 8)) + actual `shouldBe` res + + it "class declaration function sig context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just ClassContext) + actual <- getContextAt fp_ (toPos (13, 7)) + actual `shouldBe` res + + it "instance declaration context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just InstanceContext) + actual <- getContextAt fp_ (toPos (15, 7)) + actual `shouldBe` res + + it "instance declaration function def context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just InstanceContext) + actual <- getContextAt fp_ (toPos (16, 6)) + actual `shouldBe` res + + it "deriving context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk Nothing + actual <- getContextAt fp_ (toPos (10, 9)) + actual `shouldBe` res + + it "deriving typeclass context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just TypeContext) + actual <- getContextAt fp_ (toPos (10, 18)) + actual `shouldBe` res + it "nothing" $ withCurrentDirectory "./test/testdata/context" $ do fp_ <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk Nothing From 82f38704e8663a8f1fec6b6e9d442dfdfa142a88 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 30 Aug 2019 14:48:34 +0200 Subject: [PATCH 4/5] Add more test cases for context queries --- hie-plugin-api/Haskell/Ide/Engine/Context.hs | 5 +- test/testdata/context/ExampleContext.hs | 7 +- test/unit/ContextSpec.hs | 95 +++++++++++++++++--- 3 files changed, 90 insertions(+), 17 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Context.hs b/hie-plugin-api/Haskell/Ide/Engine/Context.hs index fa463a629..d6f35df39 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Context.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -1,7 +1,6 @@ module Haskell.Ide.Engine.Context where import Data.Generics -import Data.Foldable (asum) import Language.Haskell.LSP.Types import GHC import qualified GhcModCore as GM (GhcPs) -- for GHC 8.2.2 @@ -37,10 +36,10 @@ getContext pos pm , pos `isInsideRange` r = Just ExportContext - | Just ctx <- everything (<|>) (Nothing `mkQ` go `extQ` goInline) decl + | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl = Just ctx - | Just ctx <- asum $ map importGo imports + | Just ctx <- something (Nothing `mkQ` importGo) imports = Just ctx | otherwise diff --git a/test/testdata/context/ExampleContext.hs b/test/testdata/context/ExampleContext.hs index fd28d4b61..324d05528 100644 --- a/test/testdata/context/ExampleContext.hs +++ b/test/testdata/context/ExampleContext.hs @@ -4,9 +4,12 @@ import Data.List (find) import Control.Monad hiding (fix) foo :: Int -> Int -foo xs = xs + 1 +foo xs = bar xs + 1 + where + bar :: Int -> Int + bar x = x + 2 -data Foo a = Foo a +data Foo a = Foo a deriving (Show) class Bar a where diff --git a/test/unit/ContextSpec.hs b/test/unit/ContextSpec.hs index 4f9120bc9..dcc186c8e 100644 --- a/test/unit/ContextSpec.hs +++ b/test/unit/ContextSpec.hs @@ -77,6 +77,13 @@ spec = describe "Context of different cursor positions" $ do actual `shouldBe` res + it "import hiding context" $ withCurrentDirectory "./test/testdata/context" $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just (ImportHidingContext "Control.Monad")) + actual <- getContextAt fp_ (toPos (4, 32)) + + actual `shouldBe` res + it "function declaration context" $ withCurrentDirectory "./test/testdata/context" $ do @@ -85,6 +92,14 @@ spec = describe "Context of different cursor positions" $ do actual <- getContextAt fp_ (toPos (6, 1)) actual `shouldBe` res + + it "function signature context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just TypeContext) + actual <- getContextAt fp_ (toPos (6, 8)) + actual `shouldBe` res it "function definition context" @@ -95,20 +110,44 @@ spec = describe "Context of different cursor positions" $ do actual <- getContextAt fp_ (toPos (7, 1)) actual `shouldBe` res - it "function signature context" + -- This is interesting, the context for this is assumed to be ValueContext + -- although the cursor is at the signature of a function in a where clause. + -- Reason is probably that we only traverse the AST until we know that + -- that we are in a ValueContext, however, within a ValueContext, another + -- TypeContext may arise, like in this case. + it "inner function declaration context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just TypeContext) - actual <- getContextAt fp_ (toPos (6, 8)) - actual `shouldBe` res + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just ValueContext) + actual <- getContextAt fp_ (toPos (9, 10)) + actual `shouldBe` res + + it "inner function value context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just ValueContext) + actual <- getContextAt fp_ (toPos (10, 10)) + actual `shouldBe` res + + -- Declare a datatype, is Nothing, could be DataContext it "data declaration context" $ withCurrentDirectory "./test/testdata/context" $ do fp_ <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk Nothing - actual <- getContextAt fp_ (toPos (9, 8)) + actual <- getContextAt fp_ (toPos (12, 8)) + actual `shouldBe` res + + -- Define a datatype. + it "data definition context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just TypeContext) + actual <- getContextAt fp_ (toPos (12, 18)) actual `shouldBe` res it "class declaration context" @@ -116,7 +155,7 @@ spec = describe "Context of different cursor positions" $ do $ do fp_ <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just ClassContext) - actual <- getContextAt fp_ (toPos (12, 8)) + actual <- getContextAt fp_ (toPos (15, 8)) actual `shouldBe` res it "class declaration function sig context" @@ -124,7 +163,7 @@ spec = describe "Context of different cursor positions" $ do $ do fp_ <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just ClassContext) - actual <- getContextAt fp_ (toPos (13, 7)) + actual <- getContextAt fp_ (toPos (16, 7)) actual `shouldBe` res it "instance declaration context" @@ -132,23 +171,53 @@ spec = describe "Context of different cursor positions" $ do $ do fp_ <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just InstanceContext) - actual <- getContextAt fp_ (toPos (15, 7)) + actual <- getContextAt fp_ (toPos (18, 7)) actual `shouldBe` res + -- Function definition it "instance declaration function def context" $ withCurrentDirectory "./test/testdata/context" $ do fp_ <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just InstanceContext) - actual <- getContextAt fp_ (toPos (16, 6)) + actual <- getContextAt fp_ (toPos (19, 6)) actual `shouldBe` res + -- This seems plain wrong, if the cursor is on the String "deriving", + -- we would expect the context to be DerivingContext, but it is not. + -- May require investigation if this is important. it "deriving context" $ withCurrentDirectory "./test/testdata/context" $ do fp_ <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk Nothing - actual <- getContextAt fp_ (toPos (10, 9)) + actual <- getContextAt fp_ (toPos (13, 9)) + actual `shouldBe` res + + -- Cursor is directly before the open parenthesis of a deriving clause. + -- E.g. deriving (...) + -- ^---- cursor is here + -- Context is still Nothing. + it "deriving parenthesis context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk Nothing + actual <- getContextAt fp_ (toPos (13, 14)) + actual `shouldBe` res + + -- Cursor is directly after the open parenthesis of a deriving clause. + -- E.g. deriving (...) + -- ^---- cursor is here + -- Context is now Type. This makes sense, but an extension may be to be + -- aware of the context of a deriving clause, thus offering only Type Classes + -- as a completion. + it "deriving parenthesis context" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp_ <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just TypeContext) + actual <- getContextAt fp_ (toPos (13, 15)) actual `shouldBe` res it "deriving typeclass context" @@ -156,9 +225,11 @@ spec = describe "Context of different cursor positions" $ do $ do fp_ <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just TypeContext) - actual <- getContextAt fp_ (toPos (10, 18)) + actual <- getContextAt fp_ (toPos (13, 18)) actual `shouldBe` res + -- Point at an empty line. + -- There is no context it "nothing" $ withCurrentDirectory "./test/testdata/context" $ do fp_ <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk Nothing From a127d55a09de79f573f46f8107335dc0a96093be Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 31 Aug 2019 11:15:06 +0200 Subject: [PATCH 5/5] Scrap contexts that may or may not be useful yet --- hie-plugin-api/Haskell/Ide/Engine/Context.hs | 22 +--- test/unit/ContextSpec.hs | 118 ++++++++++--------- 2 files changed, 66 insertions(+), 74 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Context.hs b/hie-plugin-api/Haskell/Ide/Engine/Context.hs index d6f35df39..9f3b3380d 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Context.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -14,14 +14,11 @@ import Control.Applicative ( (<|>) ) -- smarter code completion data Context = TypeContext | ValueContext - | ModuleContext String - | ImportContext String - | ImportListContext String - | ImportHidingContext String - | ExportContext - | InstanceContext - | ClassContext - | DerivingContext + | ModuleContext String -- ^ module context with module name + | ImportContext String -- ^ import context with module name + | ImportListContext String -- ^ import list context with module name + | ImportHidingContext String -- ^ import hiding context with module name + | ExportContext -- ^ List of exported identifiers from the current module deriving (Show, Eq) -- | Generates a map of where the context is a type and where the context is a value @@ -57,15 +54,6 @@ getContext pos pm go (L (GHC.RealSrcSpan r) GHC.ValD {}) | pos `isInsideRange` r = Just ValueContext | otherwise = Nothing - go (L (GHC.RealSrcSpan r) GHC.InstD {}) - | pos `isInsideRange` r = Just InstanceContext - | otherwise = Nothing - go (L (GHC.RealSrcSpan r) GHC.DerivD {}) - | pos `isInsideRange` r = Just DerivingContext - | otherwise = Nothing - go (L (GHC.RealSrcSpan r) (GHC.TyClD _ GHC.ClassDecl {})) - | pos `isInsideRange` r = Just ClassContext - | otherwise = Nothing go _ = Nothing goInline :: GHC.LHsType GM.GhcPs -> Maybe Context diff --git a/test/unit/ContextSpec.hs b/test/unit/ContextSpec.hs index dcc186c8e..bb911083d 100644 --- a/test/unit/ContextSpec.hs +++ b/test/unit/ContextSpec.hs @@ -32,10 +32,10 @@ spec = describe "Context of different cursor positions" $ do it "module header context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just (ModuleContext "ExampleContext")) - actual <- getContextAt fp_ (toPos (1, 10)) + actual <- getContextAt fp (toPos (1, 10)) actual `shouldBe` res @@ -43,71 +43,71 @@ spec = describe "Context of different cursor positions" $ do it "module export list context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just ExportContext) - actual <- getContextAt fp_ (toPos (1, 24)) + actual <- getContextAt fp (toPos (1, 24)) actual `shouldBe` res it "value context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just ValueContext) - actual <- getContextAt fp_ (toPos (7, 6)) + actual <- getContextAt fp (toPos (7, 6)) actual `shouldBe` res it "value addition context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just ValueContext) - actual <- getContextAt fp_ (toPos (7, 12)) + actual <- getContextAt fp (toPos (7, 12)) actual `shouldBe` res it "import context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just (ImportContext "Data.List")) - actual <- getContextAt fp_ (toPos (3, 8)) + actual <- getContextAt fp (toPos (3, 8)) actual `shouldBe` res it "import list context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just (ImportListContext "Data.List")) - actual <- getContextAt fp_ (toPos (3, 20)) + actual <- getContextAt fp (toPos (3, 20)) actual `shouldBe` res it "import hiding context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just (ImportHidingContext "Control.Monad")) - actual <- getContextAt fp_ (toPos (4, 32)) + actual <- getContextAt fp (toPos (4, 32)) actual `shouldBe` res it "function declaration context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just TypeContext) - actual <- getContextAt fp_ (toPos (6, 1)) + actual <- getContextAt fp (toPos (6, 1)) actual `shouldBe` res - + it "function signature context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just TypeContext) - actual <- getContextAt fp_ (toPos (6, 8)) + actual <- getContextAt fp (toPos (6, 8)) actual `shouldBe` res it "function definition context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just ValueContext) - actual <- getContextAt fp_ (toPos (7, 1)) + actual <- getContextAt fp (toPos (7, 1)) actual `shouldBe` res -- This is interesting, the context for this is assumed to be ValueContext @@ -118,17 +118,17 @@ spec = describe "Context of different cursor positions" $ do it "inner function declaration context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just ValueContext) - actual <- getContextAt fp_ (toPos (9, 10)) + actual <- getContextAt fp (toPos (9, 10)) actual `shouldBe` res it "inner function value context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just ValueContext) - actual <- getContextAt fp_ (toPos (10, 10)) + actual <- getContextAt fp (toPos (10, 10)) actual `shouldBe` res @@ -136,51 +136,55 @@ spec = describe "Context of different cursor positions" $ do it "data declaration context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk Nothing - actual <- getContextAt fp_ (toPos (12, 8)) + actual <- getContextAt fp (toPos (12, 8)) actual `shouldBe` res -- Define a datatype. it "data definition context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just TypeContext) - actual <- getContextAt fp_ (toPos (12, 18)) + actual <- getContextAt fp (toPos (12, 18)) actual `shouldBe` res + -- Declaration of a class. Should be something with types. it "class declaration context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just ClassContext) - actual <- getContextAt fp_ (toPos (15, 8)) + fp <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk Nothing + actual <- getContextAt fp (toPos (15, 8)) actual `shouldBe` res + -- Function signature in class declaration. + -- Ought to be TypeContext it "class declaration function sig context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just ClassContext) - actual <- getContextAt fp_ (toPos (16, 7)) + fp <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk Nothing + actual <- getContextAt fp (toPos (16, 7)) actual `shouldBe` res it "instance declaration context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just InstanceContext) - actual <- getContextAt fp_ (toPos (18, 7)) + fp <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk Nothing + actual <- getContextAt fp (toPos (18, 7)) actual `shouldBe` res - -- Function definition + -- Function definition in an instance declaration + -- Should be ValueContext, but nothing is fine, too for now it "instance declaration function def context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just InstanceContext) - actual <- getContextAt fp_ (toPos (19, 6)) + fp <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk Nothing + actual <- getContextAt fp (toPos (19, 6)) actual `shouldBe` res -- This seems plain wrong, if the cursor is on the String "deriving", @@ -189,9 +193,9 @@ spec = describe "Context of different cursor positions" $ do it "deriving context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk Nothing - actual <- getContextAt fp_ (toPos (13, 9)) + actual <- getContextAt fp (toPos (13, 9)) actual `shouldBe` res -- Cursor is directly before the open parenthesis of a deriving clause. @@ -201,9 +205,9 @@ spec = describe "Context of different cursor positions" $ do it "deriving parenthesis context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk Nothing - actual <- getContextAt fp_ (toPos (13, 14)) + actual <- getContextAt fp (toPos (13, 14)) actual `shouldBe` res -- Cursor is directly after the open parenthesis of a deriving clause. @@ -215,32 +219,32 @@ spec = describe "Context of different cursor positions" $ do it "deriving parenthesis context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just TypeContext) - actual <- getContextAt fp_ (toPos (13, 15)) + actual <- getContextAt fp (toPos (13, 15)) actual `shouldBe` res it "deriving typeclass context" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk (Just TypeContext) - actual <- getContextAt fp_ (toPos (13, 18)) + actual <- getContextAt fp (toPos (13, 18)) actual `shouldBe` res -- Point at an empty line. -- There is no context it "nothing" $ withCurrentDirectory "./test/testdata/context" $ do - fp_ <- makeAbsolute "./ExampleContext.hs" + fp <- makeAbsolute "./ExampleContext.hs" let res = IdeResultOk Nothing - actual <- getContextAt fp_ (toPos (2, 1)) + actual <- getContextAt fp (toPos (2, 1)) actual `shouldBe` res -getContextAt :: [Char] -> Position -> IO (IdeResult (Maybe Context)) -getContextAt fp_ pos = do - let arg = filePathToUri fp_ +getContextAt :: FilePath -> Position -> IO (IdeResult (Maybe Context)) +getContextAt fp pos = do + let arg = filePathToUri fp runSingle (IdePlugins mempty) $ do _ <- setTypecheckedModule arg - pluginGetFile "getContext: " arg $ \fp -> - ifCachedModuleAndData fp (IdeResultOk Nothing) $ \tm _ () -> + pluginGetFile "getContext: " arg $ \fp_ -> + ifCachedModuleAndData fp_ (IdeResultOk Nothing) $ \tm _ () -> return $ IdeResultOk $ getContext pos (tm_parsed_module tm)