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..9f3b3380d 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Context.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -5,6 +5,7 @@ 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 @@ -13,27 +14,74 @@ import Haskell.Ide.Engine.PluginUtils -- smarter code completion data Context = TypeContext | ValueContext + | 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 -- 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 <- something (Nothing `mkQ` go `extQ` goInline) decl + = Just ctx + + | Just ctx <- something (Nothing `mkQ` 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 _ = 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 + + 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/src/Haskell/Ide/Engine/LSP/Completions.hs b/src/Haskell/Ide/Engine/LSP/Completions.hs index b9471b595..482ae02aa 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 + _ -> 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..324d05528 --- /dev/null +++ b/test/testdata/context/ExampleContext.hs @@ -0,0 +1,20 @@ +module ExampleContext (foo) where + +import Data.List (find) +import Control.Monad hiding (fix) + +foo :: Int -> Int +foo xs = bar xs + 1 + where + bar :: Int -> Int + bar x = x + 2 + +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/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..bb911083d --- /dev/null +++ b/test/unit/ContextSpec.hs @@ -0,0 +1,250 @@ +{-# 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 addition 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 "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 "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 + fp <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just TypeContext) + 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" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just ValueContext) + actual <- getContextAt fp (toPos (7, 1)) + actual `shouldBe` res + + -- 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 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 (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 + + -- 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 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 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 Nothing + actual <- getContextAt fp (toPos (18, 7)) + actual `shouldBe` res + + -- 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 Nothing + 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 (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" + $ withCurrentDirectory "./test/testdata/context" + $ do + fp <- makeAbsolute "./ExampleContext.hs" + let res = IdeResultOk (Just TypeContext) + 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 + actual <- getContextAt fp (toPos (2, 1)) + actual `shouldBe` res + +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 _ () -> + return $ IdeResultOk $ getContext pos (tm_parsed_module tm)