Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Commit 2060ad0

Browse files
fendorfendor
committed
Add more contexts
1 parent cc7510b commit 2060ad0

File tree

3 files changed

+118
-19
lines changed

3 files changed

+118
-19
lines changed

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

+43-16
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,12 @@
1-
{-# LANGUAGE LambdaCase #-}
21
module Haskell.Ide.Engine.Context where
32

43
import Data.Generics
5-
import Data.List (find)
4+
import Data.Foldable (asum)
65
import Language.Haskell.LSP.Types
76
import GHC
87
import qualified GhcModCore as GM (GhcPs) -- for GHC 8.2.2
98
import Haskell.Ide.Engine.PluginUtils
9+
import Control.Applicative ( (<|>) )
1010

1111
-- | A context of a declaration in the program
1212
-- e.g. is the declaration a type declaration or a value declaration
@@ -17,7 +17,12 @@ data Context = TypeContext
1717
| ValueContext
1818
| ModuleContext String
1919
| ImportContext String
20+
| ImportListContext String
21+
| ImportHidingContext String
2022
| ExportContext
23+
| InstanceContext
24+
| ClassContext
25+
| DerivingContext
2126
deriving (Show, Eq)
2227

2328
-- | Generates a map of where the context is a type and where the context is a value
@@ -32,42 +37,64 @@ getContext pos pm
3237
, pos `isInsideRange` r
3338
= Just ExportContext
3439

35-
| Just ctx <- everything join (Nothing `mkQ` go `extQ` goInline) decl
40+
| Just ctx <- everything (<|>) (Nothing `mkQ` go `extQ` goInline) decl
3641
= Just ctx
3742

38-
| Just (L _ impDecl) <- importRegion
39-
= Just (ImportContext (moduleNameString $ unLoc $ ideclName impDecl))
43+
| Just ctx <- asum $ map importGo imports
44+
= Just ctx
4045

4146
| otherwise
4247
= Nothing
43-
48+
4449
where decl = hsmodDecls $ unLoc $ pm_parsed_source pm
4550
moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm
4651
exportList = hsmodExports $ unLoc $ pm_parsed_source pm
4752
imports = hsmodImports $ unLoc $ pm_parsed_source pm
4853

4954
go :: LHsDecl GM.GhcPs -> Maybe Context
50-
go (L (RealSrcSpan r) (SigD {}))
55+
go (L (RealSrcSpan r) SigD {})
5156
| pos `isInsideRange` r = Just TypeContext
5257
| otherwise = Nothing
53-
go (L (GHC.RealSrcSpan r) (GHC.ValD {}))
58+
go (L (GHC.RealSrcSpan r) GHC.ValD {})
5459
| pos `isInsideRange` r = Just ValueContext
5560
| otherwise = Nothing
61+
go (L (GHC.RealSrcSpan r) GHC.InstD {})
62+
| pos `isInsideRange` r = Just InstanceContext
63+
| otherwise = Nothing
64+
go (L (GHC.RealSrcSpan r) GHC.DerivD {})
65+
| pos `isInsideRange` r = Just DerivingContext
66+
| otherwise = Nothing
67+
go (L (GHC.RealSrcSpan r) (GHC.TyClD _ GHC.ClassDecl {}))
68+
| pos `isInsideRange` r = Just ClassContext
69+
| otherwise = Nothing
5670
go _ = Nothing
71+
5772
goInline :: GHC.LHsType GM.GhcPs -> Maybe Context
5873
goInline (GHC.L (GHC.RealSrcSpan r) _)
5974
| pos `isInsideRange` r = Just TypeContext
6075
| otherwise = Nothing
6176
goInline _ = Nothing
62-
join Nothing x = x
63-
join (Just x) _ = Just x
77+
6478
p `isInsideRange` r = sp <= p && p <= ep
6579
where (sp, ep) = unpackRealSrcSpan r
6680

67-
importRegion = find
68-
(\case
69-
(L (RealSrcSpan r) _) -> pos `isInsideRange` r
70-
_ -> False
71-
)
72-
imports
81+
importGo :: GHC.LImportDecl GM.GhcPs -> Maybe Context
82+
importGo (L (RealSrcSpan r) impDecl)
83+
| pos `isInsideRange` r
84+
= importInline importModuleName (ideclHiding impDecl)
85+
<|> Just (ImportContext importModuleName)
86+
87+
| otherwise = Nothing
88+
where importModuleName = moduleNameString $ unLoc $ ideclName impDecl
89+
90+
importGo _ = Nothing
91+
92+
importInline :: String -> Maybe (Bool, GHC.Located [GHC.LIE GM.GhcPs]) -> Maybe Context
93+
importInline modName (Just (True, L (RealSrcSpan r) _))
94+
| pos `isInsideRange` r = Just $ ImportHidingContext modName
95+
| otherwise = Nothing
96+
importInline modName (Just (False, L (RealSrcSpan r) _))
97+
| pos `isInsideRange` r = Just $ ImportListContext modName
98+
| otherwise = Nothing
99+
importInline _ _ = Nothing
73100

‎test/testdata/context/ExampleContext.hs

+11-2
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,17 @@
11
module ExampleContext (foo) where
22

3-
import Data.List
4-
import Control.Monad
3+
import Data.List (find)
4+
import Control.Monad hiding (fix)
55

66
foo :: Int -> Int
77
foo xs = xs + 1
88

9+
data Foo a = Foo a
10+
deriving (Show)
11+
12+
class Bar a where
13+
bar :: a -> Integer
14+
15+
instance Integral a => Bar (Foo a) where
16+
bar (Foo a) = toInteger a
17+

‎test/unit/ContextSpec.hs

+64-1
Original file line numberDiff line numberDiff line change
@@ -56,7 +56,7 @@ spec = describe "Context of different cursor positions" $ do
5656

5757
actual `shouldBe` res
5858

59-
it "value context" $ withCurrentDirectory "./test/testdata/context" $ do
59+
it "value addition context" $ withCurrentDirectory "./test/testdata/context" $ do
6060
fp_ <- makeAbsolute "./ExampleContext.hs"
6161
let res = IdeResultOk (Just ValueContext)
6262
actual <- getContextAt fp_ (toPos (7, 12))
@@ -70,6 +70,13 @@ spec = describe "Context of different cursor positions" $ do
7070

7171
actual `shouldBe` res
7272

73+
it "import list context" $ withCurrentDirectory "./test/testdata/context" $ do
74+
fp_ <- makeAbsolute "./ExampleContext.hs"
75+
let res = IdeResultOk (Just (ImportListContext "Data.List"))
76+
actual <- getContextAt fp_ (toPos (3, 20))
77+
78+
actual `shouldBe` res
79+
7380
it "function declaration context"
7481
$ withCurrentDirectory "./test/testdata/context"
7582
$ do
@@ -96,6 +103,62 @@ spec = describe "Context of different cursor positions" $ do
96103
actual <- getContextAt fp_ (toPos (6, 8))
97104
actual `shouldBe` res
98105

106+
it "data declaration context"
107+
$ withCurrentDirectory "./test/testdata/context"
108+
$ do
109+
fp_ <- makeAbsolute "./ExampleContext.hs"
110+
let res = IdeResultOk Nothing
111+
actual <- getContextAt fp_ (toPos (9, 8))
112+
actual `shouldBe` res
113+
114+
it "class declaration context"
115+
$ withCurrentDirectory "./test/testdata/context"
116+
$ do
117+
fp_ <- makeAbsolute "./ExampleContext.hs"
118+
let res = IdeResultOk (Just ClassContext)
119+
actual <- getContextAt fp_ (toPos (12, 8))
120+
actual `shouldBe` res
121+
122+
it "class declaration function sig context"
123+
$ withCurrentDirectory "./test/testdata/context"
124+
$ do
125+
fp_ <- makeAbsolute "./ExampleContext.hs"
126+
let res = IdeResultOk (Just ClassContext)
127+
actual <- getContextAt fp_ (toPos (13, 7))
128+
actual `shouldBe` res
129+
130+
it "instance declaration context"
131+
$ withCurrentDirectory "./test/testdata/context"
132+
$ do
133+
fp_ <- makeAbsolute "./ExampleContext.hs"
134+
let res = IdeResultOk (Just InstanceContext)
135+
actual <- getContextAt fp_ (toPos (15, 7))
136+
actual `shouldBe` res
137+
138+
it "instance declaration function def context"
139+
$ withCurrentDirectory "./test/testdata/context"
140+
$ do
141+
fp_ <- makeAbsolute "./ExampleContext.hs"
142+
let res = IdeResultOk (Just InstanceContext)
143+
actual <- getContextAt fp_ (toPos (16, 6))
144+
actual `shouldBe` res
145+
146+
it "deriving context"
147+
$ withCurrentDirectory "./test/testdata/context"
148+
$ do
149+
fp_ <- makeAbsolute "./ExampleContext.hs"
150+
let res = IdeResultOk Nothing
151+
actual <- getContextAt fp_ (toPos (10, 9))
152+
actual `shouldBe` res
153+
154+
it "deriving typeclass context"
155+
$ withCurrentDirectory "./test/testdata/context"
156+
$ do
157+
fp_ <- makeAbsolute "./ExampleContext.hs"
158+
let res = IdeResultOk (Just TypeContext)
159+
actual <- getContextAt fp_ (toPos (10, 18))
160+
actual `shouldBe` res
161+
99162
it "nothing" $ withCurrentDirectory "./test/testdata/context" $ do
100163
fp_ <- makeAbsolute "./ExampleContext.hs"
101164
let res = IdeResultOk Nothing

0 commit comments

Comments
 (0)