-Wall clean tests

Author: dmjio

dap.cabal

@@ -53,6 +53,8 @@ library
 test-suite tests
   type:
     exitcode-stdio-1.0
+  ghc-options:
+    -Wall
   hs-source-dirs:
     test, src
   main-is:

test/Main.hs

@@ -20,10 +20,8 @@ import           Control.Concurrent
 import qualified Data.HashMap.Strict        as H
 import           Data.Aeson.Encode.Pretty
 import           Data.Aeson.Types
-import           Data.Aeson
 import           Data.Aeson.KeyMap
 import           Control.Concurrent.Async
-import           Control.Concurrent
 import           Control.Exception
 import qualified Data.ByteString.Lazy.Char8 as BL8 ( hPutStrLn )
 import           Network.Simple.TCP         hiding (send)
@@ -32,8 +30,7 @@ import           System.IO
 import           Data.String.Conversions
 import           Test.Hspec
 ----------------------------------------------------------------------------
-import           DAP.Utils                  hiding (send)
-import           DAP.Internal
+import           DAP.Utils
 import           DAP.Types
 import           DAP.Event
 import           DAP.Server
@@ -45,62 +42,62 @@ main = withServer $
     describe "Should connect to the mock DAP server from a client" $ do
 
       it "Should increment sequence number properly" $ do
-        withNewClient $ \handle -> do
-          send handle
+        withNewClient $ \h -> do
+          send h
             [ "command" .= ("initialize" :: String)
             , "seq"     .= (1 :: Int)
             , "type"    .= ("request" :: String)
             ]
-          shouldReceive handle
+          shouldReceive h
             [ "seq"         .= (2 :: Int)
             , "request_seq" .= (1 :: Int)
             ]
 
       it "Should connect / disconnect 100 clients" $ do
         replicateM_ 100 $
-          withNewClient $ \handle -> do
-            send handle
+          withNewClient $ \h -> do
+            send h
               [ "command" .= ("initialize" :: String)
               , "seq"     .= (1 :: Int)
               , "type"    .= ("request" :: String)
               ]
-            shouldReceive handle
+            shouldReceive h
               [ "seq"         .= (2 :: Int)
               , "request_seq" .= (1 :: Int)
               ]
 
       it "Should perform req/resp. for initialize and receive initialized event" $ do
-          withNewClient $ \handle -> do
-            send handle
+          withNewClient $ \h -> do
+            send h
               [ "command" .= ("initialize" :: String)
               , "seq"     .= (1 :: Int)
               , "type"    .= ("request" :: String)
               ]
-            shouldReceive handle
+            shouldReceive h
               [ "seq"         .= (2 :: Int)
               , "request_seq" .= (1 :: Int)
               , "command"     .= ("initialize" :: String)
               , "type"        .= ("response" :: String)
               ]
-            shouldReceive handle
+            shouldReceive h
               [ "type"     .= ("event" :: String)
               , "event"    .= ("initialized" :: String)
               ]
 
       it "Should receive configuration done and stop event" $ do
-          withNewClient $ \handle -> do
-            send handle
+          withNewClient $ \h -> do
+            send h
               [ "command" .= ("configurationDone" :: String)
               , "seq"     .= (100 :: Int)
               , "type"    .= ("request" :: String)
               ]
-            shouldReceive handle
+            shouldReceive h
               [ "seq"         .= (101 :: Int)
               , "request_seq" .= (100 :: Int)
               , "command"     .= ("configurationDone" :: String)
               , "type"        .= ("response" :: String)
               ]
-            shouldReceive handle
+            shouldReceive h
               [ "type"     .= ("event" :: String)
               , "event"    .= ("stopped" :: String)
               ]
@@ -116,6 +113,7 @@ mockServerTalk CommandInitialize = do
 mockServerTalk CommandConfigurationDone = do
   sendConfigurationDoneResponse
   sendStoppedEvent defaultStoppedEvent
+mockServerTalk _ = pure ()
 
 -- | Sample port shared amongst client and server
 --
@@ -133,7 +131,7 @@ withServer :: IO () -> IO ()
 withServer test = withAsync server (const test)
   where
     server = runDAPServer config mockServerTalk
-    capabilities = defaultCapabilities
+    sc = defaultCapabilities
       { supportsConfigurationDoneRequest      = True
       , supportsHitConditionalBreakpoints     = True
       , supportsModulesRequest                = True
@@ -149,7 +147,7 @@ withServer test = withAsync server (const test)
     config = ServerConfig
       { host = testHost
       , port = testPort
-      , serverCapabilities = capabilities
+      , serverCapabilities = sc
       , debugLogging = False
       }
 
@@ -158,9 +156,9 @@ withServer test = withAsync server (const test)
 withNewClient :: (Handle -> IO ()) -> IO ()
 withNewClient continue = flip catch exceptionHandler $
   connect testHost (show testPort) $ \(socket, _) -> do
-    handle <- socketToHandle socket ReadWriteMode
-    hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF }
-    continue handle `finally` hClose handle
+    h <- socketToHandle socket ReadWriteMode
+    hSetNewlineMode h NewlineMode { inputNL = CRLF, outputNL = CRLF }
+    continue h `finally` hClose h
       where
         exceptionHandler :: SomeException -> IO ()
         exceptionHandler _ = do
@@ -171,8 +169,8 @@ withNewClient continue = flip catch exceptionHandler $
 -- | Helper to send JSON payloads to the server
 --
 send :: Handle -> [Pair] -> IO ()
-send handle message
-  = BL8.hPutStrLn handle
+send h message
+  = BL8.hPutStrLn h
   $ cs (encodeBaseProtocolMessage (object message))
 
 -- | Helper to receive JSON payloads to the client
@@ -185,9 +183,11 @@ shouldReceive
   -- ^ Subset of JSON values that should be present in the payload
   -> IO ()
 shouldReceive h expected = do
-  let Object ex = object expected
-  readPayload h >>= \case
-    Left e -> fail e
-    Right actual
-      | toHashMapText ex `H.isSubmapOf` toHashMapText actual -> pure ()
-      | otherwise -> encodePretty actual `shouldBe` encodePretty ex
+  case object expected of
+    Object ex ->
+      readPayload h >>= \case
+        Left e -> fail e
+        Right actual
+          | toHashMapText ex `H.isSubmapOf` toHashMapText actual -> pure ()
+          | otherwise -> encodePretty actual `shouldBe` encodePretty ex
+    _ -> fail "Invalid JSON"