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

Commit 91dd4c7

Browse files
fendorfendor
committed
Add type information for fun pat
1 parent aec6709 commit 91dd4c7

File tree

2 files changed

+53
-29
lines changed

2 files changed

+53
-29
lines changed

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

Lines changed: 8 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ import qualified TcHsSyn
1818
import qualified CoreUtils
1919
import qualified Type
2020
import qualified Desugar
21+
import qualified Var
2122
import Haskell.Ide.Engine.Compat
2223

2324
import Haskell.Ide.Engine.ArtifactMap
@@ -38,7 +39,7 @@ everythingInTypecheckedSourceM = everythingButTypeM @GHC.Id
3839

3940
-- | Obtain details map for types.
4041
types :: GHC.HscEnv -> GHC.TypecheckedSource -> IO TypeMap
41-
types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun)
42+
types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun `combineM` funBind)
4243
where
4344
ty :: forall a . Data a => a -> IO TypeMap
4445
ty term = case cast term of
@@ -54,6 +55,12 @@ types hs_env = everythingInTypecheckedSourceM (ty `combineM` fun)
5455
return (IM.singleton (rspToInt spn) (TcHsSyn.hsPatType hsPatType))
5556
_ -> return IM.empty
5657

58+
funBind :: forall a . Data a => a -> IO TypeMap
59+
funBind term = case cast term of
60+
(Just (GHC.L (GHC.RealSrcSpan spn) ((GHC.FunBind _ (GHC.L _ (idp :: GHC.IdP GhcTc)) _ _ _) :: GHC.HsBindLR GhcTc GhcTc))) ->
61+
return (IM.singleton (rspToInt spn) (Var.varType idp))
62+
_ -> return IM.empty
63+
5764
-- | Combine two queries into one using alternative combinator.
5865
combineM
5966
:: (forall a . Data a => a -> IO TypeMap)

‎test/unit/GhcModPluginSpec.hs

Lines changed: 45 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -80,7 +80,7 @@ ghcmodSpec =
8080
-- ghc-mod tries to load the test file in the context of the hie project if we do not cd first.
8181
testCommand testPlugins act "ghcmod" "info" arg res
8282

83-
-- ---------------------------------
83+
-- ----------------------------------------------------------------------------
8484

8585
it "runs the type command, find type" $ withCurrentDirectory "./test/testdata" $ do
8686
fp <- makeAbsolute "HaReRename.hs"
@@ -90,8 +90,10 @@ ghcmodSpec =
9090
liftToGhc $ newTypeCmd (toPos (5,9)) uri
9191
arg = TP False uri (toPos (5,9))
9292
res = IdeResultOk
93-
[(Range (toPos (5,9)) (toPos (5,10)), "Int")
93+
[ (Range (toPos (5,9)) (toPos (5,10)), "Int")
94+
, (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int")
9495
]
96+
9597
testCommand testPlugins act "ghcmod" "type" arg res
9698
it "runs the type command, find function type" $ withCurrentDirectory "./test/testdata" $ do
9799
fp <- makeAbsolute "HaReRename.hs"
@@ -101,7 +103,8 @@ ghcmodSpec =
101103
liftToGhc $ newTypeCmd (toPos (2,11)) uri
102104
arg = TP False uri (toPos (2,11))
103105
res = IdeResultOk
104-
[(Range (toPos (2, 8)) (toPos (2,16)), "String -> IO ()")
106+
[ (Range (toPos (2, 8)) (toPos (2,16)), "String -> IO ()")
107+
, (Range (toPos (2, 1)) (toPos (2,24)), "IO ()")
105108
]
106109
testCommand testPlugins act "ghcmod" "type" arg res
107110

@@ -115,7 +118,6 @@ ghcmodSpec =
115118
res = IdeResultOk []
116119
testCommand testPlugins act "ghcmod" "type" arg res
117120

118-
-- ----------------------------------------------------------------------------
119121
it "runs the type command, simple" $ withCurrentDirectory "./test/testdata" $ do
120122
fp <- makeAbsolute "Types.hs"
121123
let uri = filePathToUri fp
@@ -125,6 +127,7 @@ ghcmodSpec =
125127
arg = TP False uri (toPos (6,16))
126128
res = IdeResultOk
127129
[ (Range (toPos (6, 16)) (toPos (6,17)), "Int")
130+
, (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int")
128131
]
129132
testCommand testPlugins act "ghcmod" "type" arg res
130133

@@ -138,7 +141,7 @@ ghcmodSpec =
138141
res = IdeResultOk
139142
[ (Range (toPos (6, 6)) (toPos (6, 12)), "Maybe Int")
140143
, (Range (toPos (6, 5)) (toPos (6, 13)), "Maybe Int")
141-
-- TODO: why is this happening?
144+
, (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int")
142145
]
143146
testCommand testPlugins act "ghcmod" "type" arg res
144147

@@ -153,7 +156,7 @@ ghcmodSpec =
153156
[ (Range (toPos (6, 11)) (toPos (6, 12)), "Int")
154157
, (Range (toPos (6, 6)) (toPos (6, 12)), "Maybe Int")
155158
, (Range (toPos (6, 5)) (toPos (6, 13)), "Maybe Int")
156-
-- TODO: why is this happening?
159+
, (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int")
157160
]
158161
testCommand testPlugins act "ghcmod" "type" arg res
159162

@@ -166,6 +169,7 @@ ghcmodSpec =
166169
arg = TP False uri (toPos (7,5))
167170
res = IdeResultOk
168171
[ (Range (toPos (7, 5)) (toPos (7, 12)), "Maybe Int")
172+
, (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int")
169173
]
170174
testCommand testPlugins act "ghcmod" "type" arg res
171175

@@ -178,6 +182,7 @@ ghcmodSpec =
178182
arg = TP False uri (toPos (7,15))
179183
res = IdeResultOk
180184
[ (Range (toPos (7, 15)) (toPos (7, 16)), "Int")
185+
, (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int")
181186
]
182187
testCommand testPlugins act "ghcmod" "type" arg res
183188

@@ -190,6 +195,7 @@ ghcmodSpec =
190195
arg = TP False uri (toPos (10,5))
191196
res = IdeResultOk
192197
[ (Range (toPos (10, 5)) (toPos (10, 6)), "Maybe Int")
198+
, (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int")
193199
]
194200
testCommand testPlugins act "ghcmod" "type" arg res
195201

@@ -203,6 +209,7 @@ ghcmodSpec =
203209
res = IdeResultOk
204210
[ (Range (toPos (10, 14)) (toPos (10, 15)), "Maybe Int")
205211
, (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int")
212+
, (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int")
206213
]
207214
testCommand testPlugins act "ghcmod" "type" arg res
208215

@@ -216,6 +223,7 @@ ghcmodSpec =
216223
res = IdeResultOk
217224
[ (Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int")
218225
, (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int")
226+
, (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int")
219227
]
220228
testCommand testPlugins act "ghcmod" "type" arg res
221229

@@ -230,6 +238,7 @@ ghcmodSpec =
230238
[ (Range (toPos (11, 10)) (toPos (11, 11)), "Int")
231239
, (Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int")
232240
, (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int")
241+
, (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int")
233242
]
234243
testCommand testPlugins act "ghcmod" "type" arg res
235244

@@ -243,6 +252,7 @@ ghcmodSpec =
243252
res = IdeResultOk
244253
[ (Range (toPos (11, 17)) (toPos (11, 18)), "Int -> Int -> Int")
245254
, (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int")
255+
, (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int")
246256
]
247257
testCommand testPlugins act "ghcmod" "type" arg res
248258

@@ -256,6 +266,7 @@ ghcmodSpec =
256266
res = IdeResultOk
257267
[ (Range (toPos (12, 5)) (toPos (12, 12)), "Maybe Int")
258268
, (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int")
269+
, (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int")
259270
]
260271
testCommand testPlugins act "ghcmod" "type" arg res
261272

@@ -268,6 +279,7 @@ ghcmodSpec =
268279
arg = TP False uri (toPos (16,5))
269280
res = IdeResultOk
270281
[ (Range (toPos (16, 5)) (toPos (16, 6)), "Int")
282+
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
271283
]
272284
testCommand testPlugins act "ghcmod" "type" arg res
273285

@@ -280,6 +292,7 @@ ghcmodSpec =
280292
arg = TP False uri (toPos (16,10))
281293
res = IdeResultOk
282294
[ (Range (toPos (16, 10)) (toPos (16, 11)), "Maybe Int")
295+
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
283296
]
284297
testCommand testPlugins act "ghcmod" "type" arg res
285298

@@ -292,6 +305,8 @@ ghcmodSpec =
292305
arg = TP False uri (toPos (17,13))
293306
res = IdeResultOk
294307
[ (Range (toPos (17, 13)) (toPos (17, 19)), "Int -> Maybe Int")
308+
, (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int")
309+
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
295310
]
296311
testCommand testPlugins act "ghcmod" "type" arg res
297312

@@ -304,6 +319,8 @@ ghcmodSpec =
304319
arg = TP False uri (toPos (17,21))
305320
res = IdeResultOk
306321
[ (Range (toPos (17, 21)) (toPos (17, 22)), "Int")
322+
, (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int")
323+
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
307324
]
308325
testCommand testPlugins act "ghcmod" "type" arg res
309326

@@ -314,9 +331,10 @@ ghcmodSpec =
314331
_ <- setTypecheckedModule uri
315332
liftToGhc $ newTypeCmd (toPos (17,9)) uri
316333
arg = TP False uri (toPos (17,9))
317-
res = IdeResultOk []
318-
-- TODO: do we want this?
319-
-- (Range (toPos (17, 9)) (toPos (17, 10)), "Maybe Int")
334+
res = IdeResultOk
335+
[ (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int")
336+
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
337+
]
320338
testCommand testPlugins act "ghcmod" "type" arg res
321339

322340
it "runs the type command, do expr, function type" $ withCurrentDirectory "./test/testdata" $ do
@@ -328,6 +346,7 @@ ghcmodSpec =
328346
arg = TP False uri (toPos (18,10))
329347
res = IdeResultOk
330348
[ (Range (toPos (18, 10)) (toPos (18, 11)), "Maybe Int")
349+
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
331350
]
332351
testCommand testPlugins act "ghcmod" "type" arg res
333352

@@ -340,6 +359,7 @@ ghcmodSpec =
340359
arg = TP False uri (toPos (18,5))
341360
res = IdeResultOk
342361
[ (Range (toPos (18, 5)) (toPos (18, 6)), "Int")
362+
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
343363
]
344364
testCommand testPlugins act "ghcmod" "type" arg res
345365

@@ -350,20 +370,8 @@ ghcmodSpec =
350370
_ <- setTypecheckedModule uri
351371
liftToGhc $ newTypeCmd (toPos (15,5)) uri
352372
arg = TP False uri (toPos (15,5))
353-
res = IdeResultOk []
354-
-- TODO: the type is known, why not in the map?
355-
-- [(Range (toPos (15, 1)) (toPos (14, 11)), "Maybe Int -> Maybe Int")]
356-
testCommand testPlugins act "ghcmod" "type" arg res
357-
358-
it "runs the type command, function parameter" $ withCurrentDirectory "./test/testdata" $ do
359-
fp <- makeAbsolute "Types.hs"
360-
let uri = filePathToUri fp
361-
act = do
362-
_ <- setTypecheckedModule uri
363-
liftToGhc $ newTypeCmd (toPos (22,10)) uri
364-
arg = TP False uri (toPos (22,10))
365373
res = IdeResultOk
366-
[ (Range (toPos (22, 10)) (toPos (22, 11)), "a -> a")
374+
[ (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
367375
]
368376
testCommand testPlugins act "ghcmod" "type" arg res
369377

@@ -376,6 +384,7 @@ ghcmodSpec =
376384
arg = TP False uri (toPos (22,10))
377385
res = IdeResultOk
378386
[ (Range (toPos (22, 10)) (toPos (22, 11)), "a -> a")
387+
, (Range (toPos (22, 1)) (toPos (22, 19)), "(a -> a) -> a -> a")
379388
]
380389
testCommand testPlugins act "ghcmod" "type" arg res
381390

@@ -388,6 +397,8 @@ ghcmodSpec =
388397
arg = TP False uri (toPos (25,26))
389398
res = IdeResultOk
390399
[ (Range (toPos (25, 26)) (toPos (25, 27)), "(b -> c) -> (a -> b) -> a -> c")
400+
, (Range (toPos (25, 20)) (toPos (25, 29)), "a -> c")
401+
, (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c")
391402
]
392403
testCommand testPlugins act "ghcmod" "type" arg res
393404

@@ -398,9 +409,10 @@ ghcmodSpec =
398409
_ <- setTypecheckedModule uri
399410
liftToGhc $ newTypeCmd (toPos (25,20)) uri
400411
arg = TP False uri (toPos (25,20))
401-
res = IdeResultOk []
402-
-- TODO: do we want this?
403-
--(Range (toPos (25, 20)) (toPos (25, 21)), "a -> c")
412+
res = IdeResultOk
413+
[ (Range (toPos (25, 20)) (toPos (25, 29)), "a -> c")
414+
, (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c")
415+
]
404416
testCommand testPlugins act "ghcmod" "type" arg res
405417

406418
it "runs the type command, let binding, type of function" $ withCurrentDirectory "./test/testdata" $ do
@@ -412,6 +424,7 @@ ghcmodSpec =
412424
arg = TP False uri (toPos (25,33))
413425
res = IdeResultOk
414426
[ (Range (toPos (25, 33)) (toPos (25, 34)), "a -> c")
427+
, (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c")
415428
]
416429
testCommand testPlugins act "ghcmod" "type" arg res
417430

@@ -422,9 +435,9 @@ ghcmodSpec =
422435
_ <- setTypecheckedModule uri
423436
liftToGhc $ newTypeCmd (toPos (25,5)) uri
424437
arg = TP False uri (toPos (25,5))
425-
res = IdeResultOk []
426-
-- TODO: the type is known, why not in the map?
427-
-- (Range (toPos (25, 1)) (toPos (25, 9)), "(b -> c) -> (a -> b) -> a -> c")
438+
res = IdeResultOk
439+
[ (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c")
440+
]
428441
testCommand testPlugins act "ghcmod" "type" arg res
429442

430443
it "runs the type command, infix operator" $ withCurrentDirectory "./test/testdata" $ do
@@ -436,6 +449,7 @@ ghcmodSpec =
436449
arg = TP False uri (toPos (28,25))
437450
res = IdeResultOk
438451
[ (Range (toPos (28, 25)) (toPos (28, 28)), "(a -> b) -> IO a -> IO b")
452+
, (Range (toPos (28, 1)) (toPos (28, 35)), "(a -> b) -> IO a -> IO b")
439453
]
440454
testCommand testPlugins act "ghcmod" "type" arg res
441455

@@ -463,6 +477,7 @@ ghcmodSpec =
463477
, (Range (toPos (33, 15)) (toPos (33, 19)), "Int -> Test -> ShowS")
464478
, (Range (toPos (33, 15)) (toPos (33, 19)), "Test -> String")
465479
, (Range (toPos (33, 15)) (toPos (33, 19)), "[Test] -> ShowS")
480+
, (Range (toPos (33, 15)) (toPos (33, 19)), "Int -> Test -> ShowS")
466481
]
467482
testCommand testPlugins act "ghcmod" "type" arg res
468483

@@ -477,6 +492,7 @@ ghcmodSpec =
477492
[ (Range (toPos (33, 21)) (toPos (33, 23)), "(Test -> Test -> Bool) -> (Test -> Test -> Bool) -> Eq Test")
478493
, (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool")
479494
, (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool")
495+
, (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool")
480496
]
481497
testCommand testPlugins act "ghcmod" "type" arg res
482498

@@ -495,6 +511,7 @@ ghcmodSpec =
495511
let arg = TP False uri (toPos (5,9))
496512
let res = IdeResultOk
497513
[(Range (toPos (5,9)) (toPos (5,10)), "Int")
514+
, (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int")
498515
]
499516
testCommand testPlugins act "ghcmod" "type" arg res
500517

0 commit comments

Comments
 (0)