Skip to content

Commit

Permalink
Bugfix type signature lenses / code actions for pattern synonyms. (#1952
Browse files Browse the repository at this point in the history 
)

* 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

* GHC 9.2 compat fix.

The multiplicities returned by patSynSig on the orig_args value are
uninteresting. patSynSig is literally just calling (map unrestricted). There is
no information there for us to care about.

Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
  • Loading branch information
@peterwicksstringfield @mergify
peterwicksstringfield and mergify[bot] authored Jun 28, 2021
1 parent dff418c commit e48e02a
Show file tree
Hide file tree
Showing 2 changed files with 54 additions and 17 deletions.
29 changes: 21 additions & 8 deletions ghcide/src/Development/IDE/Plugin/TypeLenses.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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),
Expand All @@ -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),
Expand All @@ -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)
Expand Down Expand Up @@ -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 (..))
Expand Down Expand Up @@ -279,10 +282,20 @@ 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
orig_args' = map scaledThing orig_args
42 changes: 33 additions & 9 deletions ghcide/test/exe/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 <> ")")
Expand All @@ -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"
Expand Down

0 comments on commit e48e02a

Please sign in to comment.