Skip to content

Commit 51ef231

Browse files
July541July541
committed
Golden tests
1 parent 7bf07ca commit 51ef231

22 files changed

+293
-118
lines changed

‎ghcide/src/Development/IDE/Plugin/TypeLenses.hs

Lines changed: 112 additions & 98 deletions
Original file line numberDiff line numberDiff line change
@@ -112,7 +112,7 @@ properties = emptyProperties
112112
, (Diagnostics, "Follows error messages produced by GHC about missing signatures")
113113
] Always
114114
& defineBooleanProperty #whereLensOn
115-
"Enable type lens on instance methods"
115+
"Display type lenses of where bindings"
116116
True
117117

118118
codeLensProvider ::
@@ -329,114 +329,128 @@ pprPatSynTypeWithoutForalls p = pprPatSynType pWithoutTypeVariables
329329

330330
-- | A binding expression with its id(s) and location.
331331
data WhereBinding = WhereBinding
332-
{ bindingId :: [Id]
333-
-- ^ There may multiple ids for one expression.
334-
-- e.g. @(a,b) = (1,True)@
335-
, bindingLoc :: SrcSpan
336-
-- ^ Location for the whole binding.
337-
-- Here we use the this to render the type signature at the proper place.
338-
--
339-
-- Example: For @(a,b) = (1,True)@, it will print the signature after the
340-
-- open parenthesis instead of the above of the whole expression.
341-
}
332+
{ bindingId :: [Id]
333+
-- ^ There may multiple ids for one expression.
334+
-- e.g. @(a,b) = (1,True)@
335+
, bindingLoc :: SrcSpan
336+
-- ^ Location for the whole binding.
337+
-- Here we use the this to render the type signature at the proper place.
338+
--
339+
-- Example: For @(a,b) = (1,True)@, it will print the signature after the
340+
-- open parenthesis instead of the above of the whole expression
341+
-- if we don't use the binding span.
342+
}
342343

343344
-- | Existed bindings in a where clause.
344345
data WhereBindings = WhereBindings
345-
{ bindings :: [WhereBinding]
346-
, existedSigNames :: [Name]
347-
-- ^ Names of existing signatures.
348-
-- It is used to hide type lens for existing signatures.
349-
}
346+
{ bindings :: [WhereBinding]
347+
, existedSigNames :: [Name]
348+
-- ^ Names of existing signatures.
349+
-- It is used to hide type lens for existing signatures.
350+
--
351+
-- NOTE: The location of this name is equal to
352+
-- the binding name.
353+
--
354+
-- Example:
355+
-- @
356+
-- f :: Int
357+
-- f = 42
358+
-- @
359+
-- The location of signature name `f`(first line) is equal to
360+
-- the definition of `f`(second line).
361+
}
350362

351363
-- | All where clauses from type checked source.
352364
findWhereQ :: GenericQ [HsLocalBinds GhcTc]
353365
findWhereQ = everything (<>) $ mkQ [] (pure . findWhere)
354-
where
355-
findWhere :: GRHSs GhcTc (LHsExpr GhcTc) -> HsLocalBinds GhcTc
356-
findWhere = grhssLocalBindsCompat
366+
where
367+
findWhere :: GRHSs GhcTc (LHsExpr GhcTc) -> HsLocalBinds GhcTc
368+
findWhere = grhssLocalBindsCompat
357369

358-
-- | Find all bindings for **one** where clasure.
370+
-- | Find all bindings for **one** where clause.
359371
findBindingsQ :: GenericQ (Maybe WhereBindings)
360372
findBindingsQ = something (mkQ Nothing findBindings)
361-
where
362-
findBindings :: NHsValBindsLR GhcTc -> Maybe WhereBindings
363-
findBindings (NValBinds binds sigs) =
364-
Just $ WhereBindings
365-
{ bindings = mapMaybe (something (mkQ Nothing findBindingIds) . snd) binds
366-
, existedSigNames = concatMap findSigIds sigs
367-
}
368-
369-
findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe WhereBinding
370-
findBindingIds bind = case unLoc bind of
371-
FunBind{..} -> Just $ WhereBinding (pure $ unLoc fun_id) l
372-
PatBind{..} ->
373-
let ids = (everything (<>) $ mkQ [] (maybeToList . findIdFromPat)) pat_lhs
374-
in Just $ WhereBinding ids l
375-
_ -> Nothing
376-
where
377-
l = getLoc bind
378-
379-
-- | Example: Find `a` and `b` from @(a,b) = (1,True)@
380-
findIdFromPat :: Pat GhcTc -> Maybe Id
381-
findIdFromPat (VarPat _ (L _ id)) = Just id
382-
findIdFromPat _ = Nothing
383-
384-
findSigIds (L _ (TypeSig _ names _)) = map unLoc names
385-
findSigIds _ = []
373+
where
374+
findBindings :: NHsValBindsLR GhcTc -> Maybe WhereBindings
375+
findBindings (NValBinds binds sigs) =
376+
Just $ WhereBindings
377+
{ bindings = mapMaybe (something (mkQ Nothing findBindingIds) . snd) binds
378+
, existedSigNames = concatMap findSigIds sigs
379+
}
380+
381+
findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe WhereBinding
382+
findBindingIds bind = case unLoc bind of
383+
FunBind{..} -> Just $ WhereBinding (pure $ unLoc fun_id) l
384+
PatBind{..} ->
385+
let ids = (everything (<>) $ mkQ [] (maybeToList . findIdFromPat)) pat_lhs
386+
in Just $ WhereBinding ids l
387+
_ -> Nothing
388+
where
389+
l = getLoc bind
390+
391+
-- | Example: Find `a` and `b` from @(a,b) = (1,True)@
392+
findIdFromPat :: Pat GhcTc -> Maybe Id
393+
findIdFromPat (VarPat _ (L _ id)) = Just id
394+
findIdFromPat _ = Nothing
395+
396+
findSigIds (L _ (TypeSig _ names _)) = map unLoc names
397+
findSigIds _ = []
386398

387399
-- | Provide code lens for where bindings.
388400
whereClauseCodeLens :: PluginMethodHandler IdeState TextDocumentCodeLens
389401
whereClauseCodeLens state plId CodeLensParams{..} = do
390-
enabled <- usePropertyLsp #whereLensOn plId properties
391-
if not enabled then pure $ pure $ List [] else pluginResponse $ do
392-
nfp <- getNormalizedFilePath plId uri
393-
tmr <- handleMaybeM "Unable to typechecking"
394-
$ liftIO
395-
$ runAction "codeLens.local.TypeCheck" state
396-
$ use TypeCheck nfp
397-
(hscEnv -> hsc) <- handleMaybeM "Unable to get GhcSession"
398-
$ liftIO
399-
$ runAction "codeLens.local.GhcSession" state
400-
$ use GhcSession nfp
401-
let tcGblEnv = tmrTypechecked tmr
402-
rdrEnv = tcg_rdr_env tcGblEnv
403-
typeCheckedSource = tcg_binds tcGblEnv
404-
405-
wheres = findWhereQ typeCheckedSource
406-
localBindings = mapMaybe findBindingsQ wheres
407-
408-
-- | Note there may multi ids for one binding
409-
bindingToLenses ids span = case srcSpanToRange span of
410-
Nothing -> pure []
411-
Just range -> forM ids $ \id -> do
412-
(_, fromMaybe [] -> sig) <- liftIO
413-
$ initTcWithGbl hsc tcGblEnv ghostSpan
414-
$ bindToSig id hsc rdrEnv
415-
pure $ generateWhereLens plId range (T.pack sig)
416-
417-
lenses <- concat <$> sequence
418-
[ bindingToLenses idsWithoutSig bindingLoc
419-
| WhereBindings{..} <- localBindings
420-
, let sigSpans = getSrcSpan <$> existedSigNames
421-
, WhereBinding{..} <- bindings
422-
, let idsWithoutSig = filter (\x -> getSrcSpan (idName x) `notElem` sigSpans) bindingId
423-
]
424-
425-
pure $ List lenses
426-
where
427-
uri = _textDocument ^. L.uri
428-
429-
generateWhereLens :: PluginId -> Range -> T.Text -> CodeLens
430-
generateWhereLens plId range title =
431-
let cmd = mkLspCommand plId typeLensCommandId title (Just [toJSON (makeEdit range title)])
432-
in CodeLens range (Just cmd) Nothing
433-
434-
makeEdit :: Range -> T.Text -> WorkspaceEdit
435-
makeEdit range text =
436-
let startPos = range ^. L.start
437-
insertChar = startPos ^. L.character
438-
insertRange = Range startPos startPos
439-
in WorkspaceEdit
440-
(pure [(uri, List [TextEdit insertRange (text <> "\n" <> T.replicate (fromIntegral insertChar) " ")])])
441-
Nothing
442-
Nothing
402+
enabled <- usePropertyLsp #whereLensOn plId properties
403+
if not enabled then pure $ pure $ List [] else pluginResponse $ do
404+
nfp <- getNormalizedFilePath plId uri
405+
tmr <- handleMaybeM "Unable to typechecking"
406+
$ liftIO
407+
$ runAction "codeLens.local.TypeCheck" state
408+
$ use TypeCheck nfp
409+
(hscEnv -> hsc) <- handleMaybeM "Unable to get GhcSession"
410+
$ liftIO
411+
$ runAction "codeLens.local.GhcSession" state
412+
$ use GhcSession nfp
413+
let tcGblEnv = tmrTypechecked tmr
414+
rdrEnv = tcg_rdr_env tcGblEnv
415+
typeCheckedSource = tcg_binds tcGblEnv
416+
417+
wheres = findWhereQ typeCheckedSource
418+
localBindings = mapMaybe findBindingsQ wheres
419+
420+
-- | Note there may multi ids for one binding,
421+
-- like @(a, b) = (42, True)@, there are `a` and `b`
422+
-- in one binding.
423+
bindingToLenses ids span = case srcSpanToRange span of
424+
Nothing -> pure []
425+
Just range -> forM ids $ \id -> do
426+
(_, fromMaybe [] -> sig) <- liftIO
427+
$ initTcWithGbl hsc tcGblEnv ghostSpan
428+
$ bindToSig id hsc rdrEnv
429+
pure $ generateWhereLens plId range (T.pack sig)
430+
431+
lenses <- concat <$> sequence
432+
[ bindingToLenses idsWithoutSig bindingLoc
433+
| WhereBindings{..} <- localBindings
434+
, let sigSpans = getSrcSpan <$> existedSigNames
435+
, WhereBinding{..} <- bindings
436+
, let idsWithoutSig = filter (\x -> getSrcSpan (idName x) `notElem` sigSpans) bindingId
437+
]
438+
439+
pure $ List lenses
440+
where
441+
uri = _textDocument ^. L.uri
442+
443+
generateWhereLens :: PluginId -> Range -> T.Text -> CodeLens
444+
generateWhereLens plId range title =
445+
let cmd = mkLspCommand plId typeLensCommandId title (Just [toJSON (makeEdit range title)])
446+
in CodeLens range (Just cmd) Nothing
447+
448+
makeEdit :: Range -> T.Text -> WorkspaceEdit
449+
makeEdit range text =
450+
let startPos = range ^. L.start
451+
insertChar = startPos ^. L.character
452+
insertRange = Range startPos startPos
453+
in WorkspaceEdit
454+
(pure [(uri, List [TextEdit insertRange (text <> "\n" <> T.replicate (fromIntegral insertChar) " ")])])
455+
Nothing
456+
Nothing

‎ghcide/test/data/local-sig-lens/Infix.expected.hs

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
module Infix where
2+
3+
f :: a
4+
f = undefined
5+
where
6+
g :: p1 -> p -> p1
7+
a `g` b = a

‎ghcide/test/data/local-sig-lens/Infix.hs

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
module Infix where
2+
3+
f :: a
4+
f = undefined
5+
where
6+
a `g` b = a

‎ghcide/test/data/local-sig-lens/Inline.expected.hs

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
module Inline where
2+
3+
f :: a
4+
f = undefined
5+
where g :: Bool
6+
g = True

‎ghcide/test/data/local-sig-lens/Inline.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module Inline where
2+
3+
f :: a
4+
f = undefined
5+
where g = True

‎ghcide/test/data/local-sig-lens/Nest.expected.hs

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
module Nest where
2+
3+
f :: Int
4+
f = g
5+
where
6+
g :: Int
7+
g = h
8+
h :: Int
9+
h = k where k :: Int
10+
k = 3

‎ghcide/test/data/local-sig-lens/Nest.hs

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
module Nest where
2+
3+
f :: Int
4+
f = g
5+
where
6+
g = h
7+
h = k where k = 3

‎ghcide/test/data/local-sig-lens/NoLens.expected.hs

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
module NoLens where
2+
3+
f :: a
4+
f = undefined
5+
where
6+
g = 3
7+
8+
9+
10+
11+
12+
13+
g :: Int

‎ghcide/test/data/local-sig-lens/NoLens.hs

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
module NoLens where
2+
3+
f :: a
4+
f = undefined
5+
where
6+
g = 3
7+
8+
9+
10+
11+
12+
13+
g :: Int

‎ghcide/test/data/local-sig-lens/Operator.expected.hs

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
module Operator where
2+
3+
f :: a
4+
f = undefined
5+
where
6+
g :: (a -> b) -> a -> b
7+
g = ($)

0 commit comments

Comments
 (0)