Add different Contexts for Module, import etc...

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

hie-plugin-api/Haskell/Ide/Engine/Context.hs

@@ -1,10 +1,12 @@
 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
 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 +15,86 @@ import Haskell.Ide.Engine.PluginUtils
 -- smarter code completion
 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
 -- 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 (<|>) (Nothing `mkQ` go `extQ` goInline) decl
+  = Just ctx
+
+  | 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
+
+        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
+

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'
 

test/testdata/context/ExampleContext.hs

@@ -0,0 +1,17 @@
+module ExampleContext (foo) where
+
+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
+

test/testdata/context/Foo/Bar.hs

@@ -0,0 +1,3 @@
+module Foo.Bar where
+
+

test/unit/ContextSpec.hs

@@ -0,0 +1,175 @@
+{-# 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 "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 "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
+        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)