diff --git a/ghcide-test/exe/CodeLensTests.hs b/ghcide-test/exe/CodeLensTests.hs index 4ec5f3957c..fd821e37b6 100644 --- a/ghcide-test/exe/CodeLensTests.hs +++ b/ghcide-test/exe/CodeLensTests.hs @@ -10,7 +10,6 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A import Data.Maybe import qualified Data.Text as T -import Data.Tuple.Extra import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types hiding @@ -28,6 +27,25 @@ tests = testGroup "code lenses" [ addSigLensesTests ] +data TestSpec = + TestSpec + { mName :: Maybe TestName -- ^ Optional Test Name + , input :: T.Text -- ^ Input + , expected :: Maybe T.Text -- ^ Expected Type Sig + } + +mkT :: T.Text -> T.Text -> TestSpec +mkT i e = TestSpec Nothing i (Just e) +mkT' :: TestName -> T.Text -> T.Text -> TestSpec +mkT' name i e = TestSpec (Just name) i (Just e) + +noExpected :: TestSpec -> TestSpec +noExpected t = t { expected = Nothing } + +mkTestName :: TestSpec -> String +mkTestName t = case mName t of + Nothing -> T.unpack $ T.replace "\n" "\\n" (input t) + Just name -> name addSigLensesTests :: TestTree addSigLensesTests = @@ -41,14 +59,14 @@ addSigLensesTests = , "data T1 a where" , " MkT1 :: (Show b) => a -> b -> T1 a" ] - before enableGHCWarnings exported (def, _) others = - T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others - after' enableGHCWarnings exported (def, sig) others = - T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others + before enableGHCWarnings exported spec others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, input spec] <> others + after' enableGHCWarnings exported spec others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure (expected spec) <> [input spec] <> others createConfig mode = A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]] - sigSession testName enableGHCWarnings waitForDiags mode exported def others = testWithDummyPluginEmpty testName $ do - let originalCode = before enableGHCWarnings exported def others - let expectedCode = after' enableGHCWarnings exported def others + sigSession testName enableGHCWarnings waitForDiags mode exported spec others = testWithDummyPluginEmpty testName $ do + let originalCode = before enableGHCWarnings exported spec others + let expectedCode = after' enableGHCWarnings exported spec others setConfigSection "haskell" (createConfig mode) doc <- createDoc "Sigs.hs" "haskell" originalCode -- Because the diagnostics mode is really relying only on diagnostics now @@ -58,7 +76,7 @@ addSigLensesTests = then void waitForDiagnostics else waitForProgressDone codeLenses <- getAndResolveCodeLenses doc - if not $ null $ snd def + if isJust $ expected spec then do liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses executeCommand $ fromJust $ head codeLenses ^. L.command @@ -66,43 +84,46 @@ addSigLensesTests = liftIO $ expectedCode @=? modifiedCode else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses cases = - [ ("abc = True", "abc :: Bool") - , ("foo a b = a + b", "foo :: Num a => a -> a -> a") - , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String") - , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool") - , ("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 = MkT1 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, String)") - , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") - , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing") - , ("typeOperatorTest = Refl", "typeOperatorTest :: forall {k} {a :: k}. a :~: a") - , ("notInScopeTest = mkCharType" - , if ghcVersion < GHC910 + [ mkT "abc = True" "abc :: Bool" + , mkT "foo a b = a + b" "foo :: Num a => a -> a -> a" + , mkT "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String" + , mkT "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool" + , mkT "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a" + , mkT "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2" + , mkT "pattern Some a = Just a" "pattern Some :: a -> Maybe a" + , mkT "pattern Some a <- Just a" "pattern Some :: a -> Maybe a" + , mkT "pattern Some a <- Just a\n where Some a = Just a" "pattern Some :: a -> Maybe a" + , mkT "pattern Some a <- Just !a\n where Some !a = Just a" "pattern Some :: a -> Maybe a" + , mkT "pattern Point{x, y} = (x, y)" "pattern Point :: a -> b -> (a, b)" + , mkT "pattern Point{x, y} <- (x, y)" "pattern Point :: a -> b -> (a, b)" + , mkT "pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)" "pattern Point :: a -> b -> (a, b)" + , mkT "pattern MkT1' b = MkT1 42 b" "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + , mkT "pattern MkT1' b <- MkT1 42 b" "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + , mkT "pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b" "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a" + , mkT "qualifiedSigTest= C.realPart" "qualifiedSigTest :: C.Complex a -> a" + , mkT "head = 233" "head :: Integer" + , mkT "rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")" "rank2Test :: (forall a. a -> a) -> (Int, String)" + , mkT "symbolKindTest = Proxy @\"qwq\"" "symbolKindTest :: Proxy \"qwq\"" + , mkT "promotedKindTest = Proxy @Nothing" (if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing") + , mkT "typeOperatorTest = Refl" "typeOperatorTest :: forall {k} {a :: k}. a :~: a" + , mkT "notInScopeTest = mkCharType" + (if ghcVersion < GHC910 then "notInScopeTest :: String -> Data.Data.DataType" else "notInScopeTest :: String -> GHC.Internal.Data.Data.DataType" ) - , ("aVeryLongSignature a b c d e f g h i j k l m n = a && b && c && d && e && f && g && h && i && j && k && l && m && n", "aVeryLongSignature :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool") + + , mkT' "aVeryLongSignature" + "aVeryLongSignature a b c d e f g h i j k l m n = a && b && c && d && e && f && g && h && i && j && k && l && m && n" + "aVeryLongSignature :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool" ] in testGroup "add signature" - [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False False "always" "" (def, Just sig) [] | (def, sig) <- cases] - , sigSession "exported mode works" False False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) + [ testGroup "signatures are correct" [sigSession (mkTestName spec) False False "always" "" spec [] | spec <- cases] + , sigSession "exported mode works" False False "exported" "xyz" (mkT "xyz = True" "xyz :: Bool") (input <$> take 3 cases) , testGroup "diagnostics mode works" - [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) [] - , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) [] + [ sigSession "with GHC warnings" True True "diagnostics" "" (head cases) [] + , sigSession "without GHC warnings" False False "diagnostics" "" (noExpected $ head cases) [] ] , testWithDummyPluginEmpty "keep stale lens" $ do let content = T.unlines diff --git a/ghcide-test/exe/ReferenceTests.hs b/ghcide-test/exe/ReferenceTests.hs index 50c263c4fc..cdbf8e472d 100644 --- a/ghcide-test/exe/ReferenceTests.hs +++ b/ghcide-test/exe/ReferenceTests.hs @@ -115,7 +115,7 @@ tests = testGroup "references" ] , testGroup "can get references to non FOIs" - [ referenceTest "can get references to symbol defined in a module we import" + [ referenceTest "references to symbol defined in a module we import" ("References.hs", 22, 4) YesIncludeDeclaration [ ("References.hs", 22, 4) @@ -123,7 +123,7 @@ tests = testGroup "references" , ("OtherModule.hs", 4, 0) ] - , referenceTest "can get references in modules that import us to symbols we define" + , referenceTest "references in modules that import us to symbols we define" ("OtherModule.hs", 4, 0) YesIncludeDeclaration [ ("References.hs", 22, 4) @@ -131,7 +131,7 @@ tests = testGroup "references" , ("OtherModule.hs", 4, 0) ] - , referenceTest "can get references to symbol defined in a module we import transitively" + , referenceTest "references to symbol defined in a module we import transitively" ("References.hs", 24, 4) YesIncludeDeclaration [ ("References.hs", 24, 4) @@ -139,7 +139,7 @@ tests = testGroup "references" , ("OtherOtherModule.hs", 2, 0) ] - , referenceTest "can get references in modules that import us transitively to symbols we define" + , referenceTest "references in modules that transitively use symbols we define" ("OtherOtherModule.hs", 2, 0) YesIncludeDeclaration [ ("References.hs", 24, 4) @@ -147,7 +147,7 @@ tests = testGroup "references" , ("OtherOtherModule.hs", 2, 0) ] - , referenceTest "can get type references to other modules" + , referenceTest "type references to other modules" ("Main.hs", 12, 10) YesIncludeDeclaration [ ("Main.hs", 12, 7)