{-# LANGUAGE GADTs #-}
module CodeLensTests (tests) where
import Config
import Control.Applicative.Combinators
import Control.Lens ((^.))
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson as A
import Data.Maybe
import qualified Data.Text as T
import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion)
import qualified Language.LSP.Protocol.Lens as L
import Language.LSP.Protocol.Types hiding
(SemanticTokenAbsolute (..),
SemanticTokenRelative (..),
SemanticTokensEdit (..),
mkRange)
import Language.LSP.Test
import Test.Hls (mkRange, waitForProgressDone)
import Test.Tasty
import Test.Tasty.HUnit
tests :: TestTree
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 =
let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
moduleH exported =
T.unlines
[ "{-# 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 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 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
-- to generate the code lens we need to make sure we wait till the file
-- is parsed before asking for codelenses, otherwise we will get nothing.
if waitForDiags
then void waitForDiagnostics
else waitForProgressDone
codeLenses <- getAndResolveCodeLenses doc
if isJust $ expected spec
then do
liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses
executeCommand $ fromJust $ head codeLenses ^. L.command
modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc)
liftIO $ expectedCode @=? modifiedCode
else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses
cases =
[ 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"
)
, 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 (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" "" (head cases) []
, sigSession "without GHC warnings" False False "diagnostics" "" (noExpected $ head cases) []
]
, testWithDummyPluginEmpty "keep stale lens" $ do
let content = T.unlines
[ "module Stale where"
, "f = _"
]
doc <- createDoc "Stale.hs" "haskell" content
oldLens <- getCodeLenses doc
liftIO $ length oldLens @?= 1
let edit = TextEdit (mkRange 0 4 0 5) "" -- Remove the `_`
_ <- applyEdit doc edit
newLens <- getCodeLenses doc
liftIO $ newLens @?= oldLens
]