git.iko.soy/ghcide
on debug help sign in
ghcide/test/src/Development/IDE/Test.hs
105 lines 4.4 kB history raw
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4module Development.IDE.Test
5 ( Cursor
6 , cursorPosition
7 , requireDiagnostic
8 , expectDiagnostics
9 , expectNoMoreDiagnostics
10 ) where
12import Control.Applicative.Combinators
13import Control.Lens hiding (List)
14import Control.Monad
15import Control.Monad.IO.Class
16import qualified Data.Map.Strict as Map
17import qualified Data.Text as T
18import Language.Haskell.LSP.Test hiding (message, openDoc')
19import qualified Language.Haskell.LSP.Test as LspTest
20import Language.Haskell.LSP.Types
21import Language.Haskell.LSP.Types.Lens as Lsp
22import System.Time.Extra
23import Test.Tasty.HUnit
26-- | (0-based line number, 0-based column number)
27type Cursor = (Int, Int)
29cursorPosition :: Cursor -> Position
30cursorPosition (line, col) = Position line col
32requireDiagnostic :: List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text) -> Assertion
33requireDiagnostic actuals expected@(severity, cursor, expectedMsg) = do
34 unless (any match actuals) $
35 assertFailure $
36 "Could not find " <> show expected <>
37 " in " <> show actuals
38 where
39 match :: Diagnostic -> Bool
40 match d =
41 Just severity == _severity d
42 && cursorPosition cursor == d ^. range . start
43 && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf`
44 standardizeQuotes (T.toLower $ d ^. message)
46-- |wait for @timeout@ seconds and report an assertion failure
47-- if any diagnostic messages arrive in that period
48expectNoMoreDiagnostics :: Seconds -> Session ()
49expectNoMoreDiagnostics timeout = do
50 -- Give any further diagnostic messages time to arrive.
51 liftIO $ sleep timeout
52 -- Send a dummy message to provoke a response from the server.
53 -- This guarantees that we have at least one message to
54 -- process, so message won't block or timeout.
55 void $ sendRequest (CustomClientMethod "non-existent-method") ()
56 handleMessages
57 where
58 handleMessages = handleDiagnostic <|> handleCustomMethodResponse <|> ignoreOthers
59 handleDiagnostic = do
60 diagsNot <- LspTest.message :: Session PublishDiagnosticsNotification
61 let fileUri = diagsNot ^. params . uri
62 actual = diagsNot ^. params . diagnostics
63 liftIO $ assertFailure $
64 "Got unexpected diagnostics for " <> show fileUri <>
65 " got " <> show actual
66 handleCustomMethodResponse =
67 -- the CustomClientMethod triggers a log message about ignoring it
68 -- handle that and then exit
69 void (LspTest.message :: Session LogMessageNotification)
70 ignoreOthers = void anyMessage >> handleMessages
72expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()
73expectDiagnostics expected = do
74 expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) (fmap toNormalizedUri . getDocUri) expected
75 go expected'
76 where
77 go m
78 | Map.null m = pure ()
79 | otherwise = do
80 diagsNot <- skipManyTill anyMessage LspTest.message :: Session PublishDiagnosticsNotification
81 let fileUri = diagsNot ^. params . uri
82 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of
83 Nothing -> do
84 let actual = diagsNot ^. params . diagnostics
85 liftIO $ assertFailure $
86 "Got diagnostics for " <> show fileUri <>
87 " but only expected diagnostics for " <> show (Map.keys m) <>
88 " got " <> show actual
89 Just expected -> do
90 let actual = diagsNot ^. params . diagnostics
91 liftIO $ mapM_ (requireDiagnostic actual) expected
92 liftIO $ unless (length expected == length actual) $
93 assertFailure $
94 "Incorrect number of diagnostics for " <> show fileUri <>
95 ", expected " <> show expected <>
96 " but got " <> show actual
97 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m
99standardizeQuotes :: T.Text -> T.Text
100standardizeQuotes msg = let
101 repl '‘' = '\''
102 repl '’' = '\''
103 repl '`' = '\''
104 repl c = c
105 in T.map repl msg