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