Skip to content

Commit ad80919

Browse files
peterwicksstringfieldpeterwicksstringfield
committed
Bugfix type signature lenses / code actions for pattern synonyms.
Use a better method for getting the type. The old method didn't work for unidirectional synonyms: pattern Some a <- Just a and gave the wrong type for synonyms with provided constraints: data T1 a where" MkT1 :: (Show b) => a -> b -> T1 a" pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a pattern MkT1' b = MkT1 42 b
1 parent 48fcaf1 commit ad80919

File tree

2 files changed

+48
-17
lines changed

2 files changed

+48
-17
lines changed

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

Lines changed: 15 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,7 @@ import Data.Aeson.Types (Value (..), toJSON)
2121
import qualified Data.Aeson.Types as A
2222
import qualified Data.HashMap.Strict as Map
2323
import Data.List (find)
24-
import Data.Maybe (catMaybes, fromJust)
24+
import Data.Maybe (catMaybes)
2525
import qualified Data.Text as T
2626
import Development.IDE (GhcSession (..),
2727
HscEnvEq (hscEnv),
@@ -36,7 +36,6 @@ import Development.IDE.Core.Shake (getHiddenDiagnostics, use)
3636
import Development.IDE.GHC.Compat
3737
import Development.IDE.GHC.Util (printName)
3838
import Development.IDE.Graph.Classes
39-
import Development.IDE.Spans.Common (safeTyThingType)
4039
import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)
4140
import Development.IDE.Types.Location (Position (Position, _character, _line),
4241
Range (Range, _end, _start),
@@ -46,8 +45,7 @@ import GHC.Generics (Generic)
4645
import GhcPlugins (GlobalRdrEnv,
4746
HscEnv (hsc_dflags), SDoc,
4847
elemNameSet, getSrcSpan,
49-
idName, lookupTypeEnv,
50-
mkRealSrcLoc,
48+
idName, mkRealSrcLoc,
5149
realSrcLocSpan,
5250
tidyOpenType)
5351
import HscTypes (mkPrintUnqualified)
@@ -76,7 +74,7 @@ import Language.LSP.Types (ApplyWorkspaceEditParams (
7674
TextEdit (TextEdit),
7775
WorkspaceEdit (WorkspaceEdit))
7876
import Outputable (showSDocForUser)
79-
import PatSyn (patSynName)
77+
import PatSyn (PatSyn, patSynName, pprPatSynType, patSynSig, mkPatSyn, patSynIsInfix, patSynMatcher, patSynBuilder, patSynFieldLabels)
8078
import TcEnv (tcInitTidyEnv)
8179
import TcRnMonad (initTcWithGbl)
8280
import TcRnTypes (TcGblEnv (..))
@@ -279,10 +277,19 @@ gblBindingType (Just hsc) (Just gblEnv) = do
279277
pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports)
280278
patToSig p = do
281279
let name = patSynName p
282-
-- we don't use pprPatSynType, since it always prints forall
283-
ty = fromJust $ lookupTypeEnv (tcg_type_env gblEnv) name >>= safeTyThingType
284-
hasSig name $ pure $ GlobalBindingTypeSig name ("pattern " <> printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports)
280+
hasSig name $ pure $ GlobalBindingTypeSig name ("pattern " <> printName name <> " :: " <> showDoc (pprPatSynTypeWithoutForalls p)) (name `elemNameSet` exports)
285281
(_, maybe [] catMaybes -> bindings) <- initTcWithGbl hsc gblEnv (realSrcLocSpan $ mkRealSrcLoc "<dummy>" 1 1) $ mapM bindToSig binds
286282
patterns <- catMaybes <$> mapM patToSig patSyns
287283
pure . Just . GlobalBindingTypeSigsResult $ bindings <> patterns
288284
gblBindingType _ _ = pure Nothing
285+
286+
pprPatSynTypeWithoutForalls :: PatSyn -> SDoc
287+
pprPatSynTypeWithoutForalls p = pprPatSynType pWithoutTypeVariables
288+
where
289+
pWithoutTypeVariables = mkPatSyn name declared_infix ([], req_theta) ([], prov_theta) orig_args orig_res_ty matcher builder field_labels
290+
(_uniq_tvs, req_theta, _ex_tvs, prov_theta, orig_args, orig_res_ty) = patSynSig p
291+
name = patSynName p
292+
declared_infix = patSynIsInfix p
293+
matcher = patSynMatcher p
294+
builder = patSynBuilder p
295+
field_labels = patSynFieldLabels p

‎ghcide/test/exe/Main.hs‎

Lines changed: 33 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -2890,17 +2890,21 @@ removeRedundantConstraintsTests = let
28902890

28912891
addSigActionTests :: TestTree
28922892
addSigActionTests = let
2893-
header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
2894-
moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
2895-
before def = T.unlines [header, moduleH, def]
2896-
after' def sig = T.unlines [header, moduleH, sig, def]
2897-
2898-
def >:: sig = testSession (T.unpack def) $ do
2893+
header = [ "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
2894+
, "{-# LANGUAGE PatternSynonyms,BangPatterns,GADTs #-}"
2895+
, "module Sigs where"
2896+
, "data T1 a where"
2897+
, " MkT1 :: (Show b) => a -> b -> T1 a"
2898+
]
2899+
before def = T.unlines $ header ++ [def]
2900+
after' def sig = T.unlines $ header ++ [sig, def]
2901+
2902+
def >:: sig = testSession (T.unpack $ T.replace "\n" "\\n" def) $ do
28992903
let originalCode = before def
29002904
let expectedCode = after' def sig
29012905
doc <- createDoc "Sigs.hs" "haskell" originalCode
29022906
_ <- waitForDiagnostics
2903-
actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
2907+
actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound))
29042908
chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
29052909
executeCodeAction chosenAction
29062910
modifiedCode <- documentContents doc
@@ -2914,6 +2918,15 @@ addSigActionTests = let
29142918
, "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
29152919
, "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
29162920
, "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"
2921+
, "pattern Some a <- Just a" >:: "pattern Some :: a -> Maybe a"
2922+
, "pattern Some a <- Just a\n where Some a = Just a" >:: "pattern Some :: a -> Maybe a"
2923+
, "pattern Some a <- Just !a\n where Some !a = Just a" >:: "pattern Some :: a -> Maybe a"
2924+
, "pattern Point{x, y} = (x, y)" >:: "pattern Point :: a -> b -> (a, b)"
2925+
, "pattern Point{x, y} <- (x, y)" >:: "pattern Point :: a -> b -> (a, b)"
2926+
, "pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)" >:: "pattern Point :: a -> b -> (a, b)"
2927+
, "pattern MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"
2928+
, "pattern MkT1' b <- MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"
2929+
, "pattern MkT1' b <- MkT1 42 b\n where MkT1' b = T1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"
29172930
]
29182931

29192932
exportUnusedTests :: TestTree
@@ -3377,10 +3390,12 @@ addSigLensesTests =
33773390
let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
33783391
moduleH exported =
33793392
T.unlines
3380-
[ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators #-}"
3393+
[ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}"
33813394
, "module Sigs(" <> exported <> ") where"
33823395
, "import qualified Data.Complex as C"
33833396
, "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)"
3397+
, "data T1 a where"
3398+
, " MkT1 :: (Show b) => a -> b -> T1 a"
33843399
]
33853400
before enableGHCWarnings exported (def, _) others =
33863401
T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others
@@ -3409,6 +3424,15 @@ addSigLensesTests =
34093424
, ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a")
34103425
, ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2")
34113426
, ("pattern Some a = Just a", "pattern Some :: a -> Maybe a")
3427+
, ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a")
3428+
, ("pattern Some a <- Just a\n where Some a = Just a", "pattern Some :: a -> Maybe a")
3429+
, ("pattern Some a <- Just !a\n where Some !a = Just a", "pattern Some :: a -> Maybe a")
3430+
, ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)")
3431+
, ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)")
3432+
, ("pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)")
3433+
, ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")
3434+
, ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")
3435+
, ("pattern MkT1' b <- MkT1 42 b\n where MkT1' b = T1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")
34123436
, ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a")
34133437
, ("head = 233", "head :: Integer")
34143438
, ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")")
@@ -3419,7 +3443,7 @@ addSigLensesTests =
34193443
]
34203444
in testGroup
34213445
"add signature"
3422-
[ testGroup "signatures are correct" [sigSession (T.unpack def) False "always" "" (def, Just sig) [] | (def, sig) <- cases]
3446+
[ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases]
34233447
, sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases)
34243448
, testGroup
34253449
"diagnostics mode works"

0 commit comments

Comments
 (0)