diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index cae5364b88..327ac65513 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/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,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 "" 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 diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 3c0db29088..8d3cb7d155 100644 --- a/ghcide/test/exe/Main.hs +++ b/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"