Bugfix type signature lenses / code actions for pattern synonyms.

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

@@ -21,7 +21,7 @@ import Data.Aeson.Types (Value (..), toJSON)
 import qualified Data.Aeson.Types as A
 import qualified Data.HashMap.Strict as Map
 import Data.List (find)
-import Data.Maybe (catMaybes, fromJust)
+import Data.Maybe (catMaybes)
 import qualified Data.Text as T
 import Development.IDE (GhcSession (..),
  HscEnvEq (hscEnv),
@@ -36,7 +36,6 @@ import Development.IDE.Core.Shake (getHiddenDiagnostics, use)
 import Development.IDE.GHC.Compat
 import Development.IDE.GHC.Util (printName)
 import Development.IDE.Graph.Classes
-import Development.IDE.Spans.Common (safeTyThingType)
 import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)
 import Development.IDE.Types.Location (Position (Position, _character, _line),
  Range (Range, _end, _start),
@@ -46,8 +45,7 @@ import GHC.Generics (Generic)
 import GhcPlugins (GlobalRdrEnv,
  HscEnv (hsc_dflags), SDoc,
  elemNameSet, getSrcSpan,
- idName, lookupTypeEnv,
- mkRealSrcLoc,
+ idName, mkRealSrcLoc,
  realSrcLocSpan,
  tidyOpenType)
 import HscTypes (mkPrintUnqualified)
@@ -76,7 +74,12 @@ import Language.LSP.Types (ApplyWorkspaceEditParams (
  TextEdit (TextEdit),
  WorkspaceEdit (WorkspaceEdit))
 import Outputable (showSDocForUser)
-import PatSyn (patSynName)
+import PatSyn (PatSyn, mkPatSyn,
+ patSynBuilder,
+ patSynFieldLabels,
+ patSynIsInfix,
+ patSynMatcher, patSynName,
+ patSynSig, pprPatSynType)
 import TcEnv (tcInitTidyEnv)
 import TcRnMonad (initTcWithGbl)
 import TcRnTypes (TcGblEnv (..))
@@ -279,10 +282,19 @@ gblBindingType (Just hsc) (Just gblEnv) = do
  pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports)
  patToSig p = do
  let name = patSynName p
- -- we don't use pprPatSynType, since it always prints forall
- ty = fromJust $ lookupTypeEnv (tcg_type_env gblEnv) name >>= safeTyThingType
- hasSig name $ pure $ GlobalBindingTypeSig name ("pattern " <> printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports)
+ hasSig name $ pure $ GlobalBindingTypeSig name ("pattern " <> printName name <> " :: " <> showDoc (pprPatSynTypeWithoutForalls p)) (name `elemNameSet` exports)
  (_, maybe [] catMaybes -> bindings) <- initTcWithGbl hsc gblEnv (realSrcLocSpan $ mkRealSrcLoc "<dummy>" 1 1) $ mapM bindToSig binds
  patterns <- catMaybes <$> mapM patToSig patSyns
  pure . Just . GlobalBindingTypeSigsResult $ bindings <> patterns
 gblBindingType _ _ = pure Nothing
+
+pprPatSynTypeWithoutForalls :: PatSyn -> SDoc
+pprPatSynTypeWithoutForalls p = pprPatSynType pWithoutTypeVariables
+ where
+ pWithoutTypeVariables = mkPatSyn name declared_infix ([], req_theta) ([], prov_theta) orig_args orig_res_ty matcher builder field_labels
+ (_univ_tvs, req_theta, _ex_tvs, prov_theta, orig_args, orig_res_ty) = patSynSig p
+ name = patSynName p
+ declared_infix = patSynIsInfix p
+ matcher = patSynMatcher p
+ builder = patSynBuilder p
+ field_labels = patSynFieldLabels p

ghcide/test/exe/Main.hs

@@ -2890,17 +2890,21 @@ removeRedundantConstraintsTests = let
 
 addSigActionTests :: TestTree
 addSigActionTests = let
- header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
- moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
- before def = T.unlines [header, moduleH, def]
- after' def sig = T.unlines [header, moduleH, sig, def]
-
- def >:: sig = testSession (T.unpack def) $ do
+ header = [ "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
+ , "{-# LANGUAGE PatternSynonyms,BangPatterns,GADTs #-}"
+ , "module Sigs where"
+ , "data T1 a where"
+ , " MkT1 :: (Show b) => a -> b -> T1 a"
+ ]
+ before def = T.unlines $ header ++ [def]
+ after' def sig = T.unlines $ header ++ [sig, def]
+
+ def >:: sig = testSession (T.unpack $ T.replace "\n" "\\n" def) $ do
  let originalCode = before def
  let expectedCode = after' def sig
  doc <- createDoc "Sigs.hs" "haskell" originalCode
  _ <- waitForDiagnostics
- actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
+ actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound))
  chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
  executeCodeAction chosenAction
  modifiedCode <- documentContents doc
@@ -2914,6 +2918,15 @@ addSigActionTests = let
  , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
  , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
  , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"
+ , "pattern Some a <- Just a" >:: "pattern Some :: a -> Maybe a"
+ , "pattern Some a <- Just a\n where Some a = Just a" >:: "pattern Some :: a -> Maybe a"
+ , "pattern Some a <- Just !a\n where Some !a = Just a" >:: "pattern Some :: a -> Maybe a"
+ , "pattern Point{x, y} = (x, y)" >:: "pattern Point :: a -> b -> (a, b)"
+ , "pattern Point{x, y} <- (x, y)" >:: "pattern Point :: a -> b -> (a, b)"
+ , "pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)" >:: "pattern Point :: a -> b -> (a, b)"
+ , "pattern MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"
+ , "pattern MkT1' b <- MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"
+ , "pattern MkT1' b <- MkT1 42 b\n where MkT1' b = T1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"
  ]
 
 exportUnusedTests :: TestTree
@@ -3377,10 +3390,12 @@ addSigLensesTests =
  let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
  moduleH exported =
  T.unlines
- [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators #-}"
+ [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}"
  , "module Sigs(" <> exported <> ") where"
  , "import qualified Data.Complex as C"
  , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)"
+ , "data T1 a where"
+ , " MkT1 :: (Show b) => a -> b -> T1 a"
  ]
  before enableGHCWarnings exported (def, _) others =
  T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others
@@ -3409,6 +3424,15 @@ addSigLensesTests =
  , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a")
  , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2")
  , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a")
+ , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a")
+ , ("pattern Some a <- Just a\n where Some a = Just a", "pattern Some :: a -> Maybe a")
+ , ("pattern Some a <- Just !a\n where Some !a = Just a", "pattern Some :: a -> Maybe a")
+ , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)")
+ , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)")
+ , ("pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)")
+ , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")
+ , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")
+ , ("pattern MkT1' b <- MkT1 42 b\n where MkT1' b = T1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")
  , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a")
  , ("head = 233", "head :: Integer")
  , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")")
@@ -3419,7 +3443,7 @@ addSigLensesTests =
  ]
  in testGroup
  "add signature"
- [ testGroup "signatures are correct" [sigSession (T.unpack def) False "always" "" (def, Just sig) [] | (def, sig) <- cases]
+ [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases]
  , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases)
  , testGroup
  "diagnostics mode works"