1{-# LANGUAGE OverloadedStrings #-} 2 3module Config (tests) where 4 5import Control.Lens hiding (List, (.=)) 6import Control.Monad 7import Data.Aeson 8import qualified Data.Map as Map 9import qualified Data.Text as T 10import Ide.Plugin.Config 11import qualified Ide.Plugin.Config as Plugin 12import Language.LSP.Test as Test 13import qualified Language.LSP.Types.Lens as L 14import System.FilePath ((</>)) 15import Test.Hls 16import Test.Hls.Command 17 18{-# ANN module ("HLint: ignore Reduce duplication"::String) #-} 19 20tests :: TestTree 21tests = testGroup "plugin config" [ 22 -- Note: because the flag is treated generically in the plugin handler, we 23 -- do not have to test each individual plugin 24 hlintTests 25 , configTests 26 ] 27 28hlintTests :: TestTree 29hlintTests = testGroup "hlint plugin enables" [ 30 31 testCase "changing hlintOn configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do 32 let config = def { hlintOn = True } 33 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) 34 35 doc <- openDoc "ApplyRefact2.hs" "haskell" 36 testHlintDiagnostics doc 37 38 let config' = def { hlintOn = False } 39 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) 40 41 diags' <- waitForDiagnosticsFrom doc 42 43 liftIO $ noHlintDiagnostics diags' 44 45 , testCase "changing hlint plugin configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do 46 let config = def { hlintOn = True } 47 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) 48 49 doc <- openDoc "ApplyRefact2.hs" "haskell" 50 testHlintDiagnostics doc 51 52 let config' = pluginGlobalOn config "hlint" False 53 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) 54 55 diags' <- waitForDiagnosticsFrom doc 56 57 liftIO $ noHlintDiagnostics diags' 58 59 , testCase "adding hlint flags to plugin configuration removes hlint diagnostics" $ runHlintSession "" $ do 60 let config = def { hlintOn = True } 61 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) 62 63 doc <- openDoc "ApplyRefact2.hs" "haskell" 64 testHlintDiagnostics doc 65 66 let config' = hlintConfigWithFlags ["--ignore=Redundant id", "--hint=test-hlint-config.yaml"] 67 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) 68 69 diags' <- waitForDiagnosticsFrom doc 70 71 liftIO $ noHlintDiagnostics diags' 72 73 , testCase "adding hlint flags to plugin configuration adds hlint diagnostics" $ runHlintSession "" $ do 74 let config = def { hlintOn = True } 75 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) 76 77 doc <- openDoc "ApplyRefact7.hs" "haskell" 78 79 expectNoMoreDiagnostics 3 doc "hlint" 80 81 let config' = hlintConfigWithFlags ["--with-group=generalise"] 82 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config')) 83 84 diags' <- waitForDiagnosticsFromSource doc "hlint" 85 d <- liftIO $ inspectDiagnostic diags' ["Use <>"] 86 87 liftIO $ do 88 length diags' @?= 1 89 d ^. L.range @?= Range (Position 1 10) (Position 1 21) 90 d ^. L.severity @?= Just DsInfo 91 ] 92 where 93 runHlintSession :: FilePath -> Session a -> IO a 94 runHlintSession subdir = 95 failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata/hlint" </> subdir) 96 97 noHlintDiagnostics :: [Diagnostic] -> Assertion 98 noHlintDiagnostics diags = 99 Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics" 100 101 testHlintDiagnostics doc = do 102 diags <- waitForDiagnosticsFromSource doc "hlint" 103 liftIO $ length diags > 0 @? "There are hlint diagnostics" 104 105configTests :: TestTree 106configTests = testGroup "config parsing" [ 107 testCase "empty object as user configuration should not send error logMessage" $ runConfigSession "" $ do 108 let config = object [] 109 sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) 110 111 -- Send custom request so server returns a response to prevent blocking 112 void $ sendNotification (SCustomMethod "non-existent-method") Null 113 114 logNot <- skipManyTill Test.anyMessage (message SWindowLogMessage) 115 116 liftIO $ (logNot ^. L.params . L.xtype) > MtError 117 || "non-existent-method" `T.isInfixOf` (logNot ^. L.params . L.message) 118 @? "Server sends logMessage with MessageType = Error" 119 ] 120 where 121 runConfigSession :: FilePath -> Session a -> IO a 122 runConfigSession subdir = 123 failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata" </> subdir) 124 125pluginGlobalOn :: Config -> T.Text -> Bool -> Config 126pluginGlobalOn config pid state = config' 127 where 128 pluginConfig = def { plcGlobalOn = state } 129 config' = def { plugins = Map.insert pid pluginConfig (plugins config) } 130 131hlintConfigWithFlags :: [T.Text] -> Config 132hlintConfigWithFlags flags = 133 def 134 { hlintOn = True 135 , Plugin.plugins = Map.fromList [("hlint", 136 def { Plugin.plcConfig = unObject $ object ["flags" .= flags] } 137 )] } 138 where 139 unObject (Object obj) = obj 140 unObject _ = undefined 141