Add more contexts

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
 

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
+

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