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