Skip to content

Commit

Permalink
Bugfix type signature lenses / code actions for pattern synonyms.
Browse files Browse the repository at this point in the history 
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
  • Loading branch information
@peterwicksstringfield
peterwicksstringfield committed Jun 20, 2021
1 parent 48fcaf1 commit ad80919
Show file tree
Hide file tree
Showing 2 changed files with 48 additions and 17 deletions.
23 changes: 15 additions & 8 deletions ghcide/src/Development/IDE/Plugin/TypeLenses.hs
View file
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,7 @@ import Language.LSP.Types (ApplyWorkspaceEditParams (
TextEdit (TextEdit),
WorkspaceEdit (WorkspaceEdit))
import Outputable (showSDocForUser)
import PatSyn (patSynName)
import PatSyn (PatSyn, patSynName, pprPatSynType, patSynSig, mkPatSyn, patSynIsInfix, patSynMatcher, patSynBuilder, patSynFieldLabels)
import TcEnv (tcInitTidyEnv)
import TcRnMonad (initTcWithGbl)
import TcRnTypes (TcGblEnv (..))
Expand Down Expand Up @@ -279,10 +277,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
(_uniq_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
42 changes: 33 additions & 9 deletions ghcide/test/exe/Main.hs
View file
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 ad80919

Please sign in to comment.