Skip to content

Commit 88f3586

Browse files
dmjiodmjio
committed
Address warnings, drop unused params, use throwError instead of error
- Renames new 'r' type variable to be 'request' (for library consumers) - Uses 'throwError' instead of 'error' when using the new 'sendEvent' function - Bumps nix to use ghc966 in shell.nix - Light formatting updates
1 parent 813e665 commit 88f3586

File tree

6 files changed

+82
-68
lines changed

6 files changed

+82
-68
lines changed

‎default.nix‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
{ pkgs ? import <nixpkgs> {} }:
22
let
3-
dap = pkgs.haskell.packages.ghc927.callCabal2nix "dap" ./. {};
3+
dap = pkgs.haskell.packages.ghc966.callCabal2nix "dap" ./. {};
44
in
55
{
66
inherit dap pkgs;

‎src/DAP.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
----------------------------------------------------------------------------
12
module DAP
23
( module DAP.Adaptor
34
, module DAP.Event
@@ -6,10 +7,11 @@ module DAP
67
, module DAP.Server
78
, module DAP.Types
89
) where
9-
10+
----------------------------------------------------------------------------
1011
import DAP.Adaptor
1112
import DAP.Event
1213
import DAP.Internal
1314
import DAP.Response
1415
import DAP.Server
1516
import DAP.Types
17+
----------------------------------------------------------------------------

‎src/DAP/Adaptor.hs‎

Lines changed: 60 additions & 50 deletions
Original file line numberDiff line numberDiff line change
@@ -56,37 +56,38 @@ module DAP.Adaptor
5656
import Control.Concurrent.Lifted ( fork, killThread )
5757
import Control.Exception ( throwIO )
5858
import Control.Concurrent.STM ( atomically, readTVarIO, modifyTVar' )
59-
import Control.Monad ( when, unless )
59+
import Control.Monad ( when, unless, void )
6060
import Control.Monad.Except ( runExceptT, throwError )
6161
import Control.Monad.State ( runStateT, gets, gets, modify' )
62-
import Control.Monad.Reader
62+
import Control.Monad.IO.Class ( liftIO )
63+
import Control.Monad.Reader ( asks, ask, runReaderT )
6364
import Data.Aeson ( FromJSON, Result (..), fromJSON )
6465
import Data.Aeson.Encode.Pretty ( encodePretty )
6566
import Data.Aeson.Types ( object, Key, KeyValue((.=)), ToJSON )
67+
import Data.IORef ( readIORef, writeIORef )
6668
import Data.Text ( unpack, pack )
6769
import Network.Socket ( SockAddr )
6870
import System.IO ( Handle )
6971
import qualified Data.ByteString.Lazy.Char8 as BL8
7072
import qualified Data.ByteString.Char8 as BS
7173
import qualified Data.HashMap.Strict as H
72-
import Data.IORef
7374
----------------------------------------------------------------------------
7475
import DAP.Types
7576
import DAP.Utils
7677
import DAP.Internal
7778
----------------------------------------------------------------------------
78-
logWarn :: BL8.ByteString -> Adaptor app r ()
79+
logWarn :: BL8.ByteString -> Adaptor app request ()
7980
logWarn msg = logWithAddr WARN Nothing (withBraces msg)
8081
----------------------------------------------------------------------------
81-
logError :: BL8.ByteString -> Adaptor app r ()
82+
logError :: BL8.ByteString -> Adaptor app request ()
8283
logError msg = logWithAddr ERROR Nothing (withBraces msg)
8384
----------------------------------------------------------------------------
84-
logInfo :: BL8.ByteString -> Adaptor app r ()
85+
logInfo :: BL8.ByteString -> Adaptor app request ()
8586
logInfo msg = logWithAddr INFO Nothing (withBraces msg)
8687
----------------------------------------------------------------------------
8788
-- | Meant for internal consumption, used to signify a message has been
8889
-- SENT from the server
89-
debugMessage :: BL8.ByteString -> Adaptor app r ()
90+
debugMessage :: BL8.ByteString -> Adaptor app request ()
9091
debugMessage msg = do
9192
shouldLog <- getDebugLogging
9293
addr <- getAddress
@@ -95,7 +96,7 @@ debugMessage msg = do
9596
$ logger DEBUG addr (Just SENT) msg
9697
----------------------------------------------------------------------------
9798
-- | Meant for external consumption
98-
logWithAddr :: Level -> Maybe DebugStatus -> BL8.ByteString -> Adaptor app r ()
99+
logWithAddr :: Level -> Maybe DebugStatus -> BL8.ByteString -> Adaptor app request ()
99100
logWithAddr level status msg = do
100101
addr <- getAddress
101102
liftIO (logger level addr status msg)
@@ -115,22 +116,22 @@ logger level addr maybeDebug msg = do
115116
, msg
116117
]
117118
----------------------------------------------------------------------------
118-
getDebugLogging :: Adaptor app r Bool
119+
getDebugLogging :: Adaptor app request Bool
119120
getDebugLogging = asks (debugLogging . serverConfig)
120121
----------------------------------------------------------------------------
121-
getServerCapabilities :: Adaptor app r Capabilities
122+
getServerCapabilities :: Adaptor app request Capabilities
122123
getServerCapabilities = asks (serverCapabilities . serverConfig)
123124
----------------------------------------------------------------------------
124-
getAddress :: Adaptor app r SockAddr
125+
getAddress :: Adaptor app request SockAddr
125126
getAddress = asks address
126127
----------------------------------------------------------------------------
127-
getHandle :: Adaptor app r Handle
128+
getHandle :: Adaptor app request Handle
128129
getHandle = asks handle
129130
----------------------------------------------------------------------------
130131
getRequestSeqNum :: Adaptor app Request Seq
131132
getRequestSeqNum = asks (requestSeqNum . request)
132133
----------------------------------------------------------------------------
133-
getDebugSessionId :: Adaptor app r SessionId
134+
getDebugSessionId :: Adaptor app request SessionId
134135
getDebugSessionId = do
135136
var <- asks (sessionId)
136137
res <- liftIO $ readIORef var
@@ -142,7 +143,7 @@ getDebugSessionId = do
142143
let err = "No Debug Session has started"
143144
sendError (ErrorMessage (pack err)) Nothing
144145
----------------------------------------------------------------------------
145-
setDebugSessionId :: SessionId -> Adaptor app r ()
146+
setDebugSessionId :: SessionId -> Adaptor app request ()
146147
setDebugSessionId session = do
147148
var <- asks sessionId
148149
liftIO $ writeIORef var (Just session)
@@ -167,21 +168,21 @@ registerNewDebugSession
167168
-- > withAdaptor $ sendOutputEvent defaultOutputEvent { outputEventOutput = output }
168169
-- > ]
169170
--
170-
-> Adaptor app r ()
171+
-> Adaptor app request ()
171172
registerNewDebugSession k v debuggerConcurrentActions = do
172173
store <- asks appStore
173174
lcl <- ask
174175
let lcl' = lcl { request = () }
175176
let emptyState = AdaptorState MessageTypeEvent []
176177
debuggerThreadState <- liftIO $
177178
DebuggerThreadState
178-
<$> sequence [fork $ action (runAdaptorWith lcl' emptyState "s") | action <- debuggerConcurrentActions]
179+
<$> sequence [fork $ action (runAdaptorWith lcl' emptyState) | action <- debuggerConcurrentActions]
179180
liftIO . atomically $ modifyTVar' store (H.insert k (debuggerThreadState, v))
180181
logInfo $ BL8.pack $ "Registered new debug session: " <> unpack k
181182
setDebugSessionId k
182183

183184
----------------------------------------------------------------------------
184-
updateDebugSession :: (app -> app) -> Adaptor app r ()
185+
updateDebugSession :: (app -> app) -> Adaptor app request ()
185186
updateDebugSession updateFun = do
186187
sessionId <- getDebugSessionId
187188
store <- asks appStore
@@ -192,7 +193,7 @@ getDebugSession = do
192193
(_, _, app) <- getDebugSessionWithThreadIdAndSessionId
193194
pure app
194195
----------------------------------------------------------------------------
195-
getDebugSessionWithThreadIdAndSessionId :: Adaptor app r (SessionId, DebuggerThreadState, app)
196+
getDebugSessionWithThreadIdAndSessionId :: Adaptor app request (SessionId, DebuggerThreadState, app)
196197
getDebugSessionWithThreadIdAndSessionId = do
197198
sessionId <- getDebugSessionId
198199
appStore <- liftIO . readTVarIO =<< getAppStore
@@ -212,7 +213,7 @@ getDebugSessionWithThreadIdAndSessionId = do
212213
-- | Whenever a debug Session ends (cleanly or otherwise) this function
213214
-- will remove the local debugger communication state from the global state
214215
----------------------------------------------------------------------------
215-
destroyDebugSession :: Adaptor app r ()
216+
destroyDebugSession :: Adaptor app request ()
216217
destroyDebugSession = do
217218
(sessionId, DebuggerThreadState {..}, _) <- getDebugSessionWithThreadIdAndSessionId
218219
store <- getAppStore
@@ -221,7 +222,7 @@ destroyDebugSession = do
221222
atomically $ modifyTVar' store (H.delete sessionId)
222223
logInfo $ BL8.pack $ "SessionId " <> unpack sessionId <> " ended"
223224
----------------------------------------------------------------------------
224-
getAppStore :: Adaptor app r (AppStore app)
225+
getAppStore :: Adaptor app request (AppStore app)
225226
getAppStore = asks appStore
226227
----------------------------------------------------------------------------
227228
getCommand :: Adaptor app Request Command
@@ -231,7 +232,7 @@ getCommand = command <$> asks request
231232
-- Sends a raw JSON payload to the editor. No "seq", "type" or "command" fields are set.
232233
-- The message is still encoded with the ProtocolMessage Header, byte count, and CRLF.
233234
--
234-
sendRaw :: ToJSON value => value -> Adaptor app r ()
235+
sendRaw :: ToJSON value => value -> Adaptor app request ()
235236
sendRaw value = do
236237
handle <- getHandle
237238
address <- getAddress
@@ -259,36 +260,40 @@ send action = do
259260

260261
-- "seq" and "type" must be set for all protocol messages
261262
setField "type" messageType
262-
unless (messageType == MessageTypeEvent) $
263-
setField "seq" seqNum
263+
unless (messageType == MessageTypeEvent) (setField "seq" seqNum)
264264

265265
-- Once all fields are set, fetch the payload for sending
266266
payload <- object <$> gets payload
267267

268268
-- Send payload to client from debug adaptor
269269
writeToHandle address handle payload
270270
resetAdaptorStatePayload
271-
272-
sendEvent :: Adaptor app r () -> Adaptor app r ()
271+
----------------------------------------------------------------------------
272+
-- | Write event to Handle
273+
sendEvent
274+
:: Adaptor app request ()
275+
-> Adaptor app request ()
273276
sendEvent action = do
274-
() <- action
277+
() <- action
275278
handle <- getHandle
276279
messageType <- gets messageType
277280
address <- getAddress
281+
let errorMsg =
282+
"Use 'send' function when responding to a DAP request, 'sendEvent'\
283+
\ is for responding to events"
278284
case messageType of
279-
MessageTypeResponse -> error "use send"
280-
MessageTypeRequest -> error "use send"
281-
MessageTypeEvent -> do
282-
address <- getAddress
285+
MessageTypeResponse ->
286+
sendError (ErrorMessage errorMsg) Nothing
287+
MessageTypeRequest ->
288+
sendError (ErrorMessage errorMsg) Nothing
289+
MessageTypeEvent ->
283290
setField "type" messageType
284291

285292
-- Once all fields are set, fetch the payload for sending
286293
payload <- object <$> gets payload
287294
-- Send payload to client from debug adaptor
288295
writeToHandle address handle payload
289296
resetAdaptorStatePayload
290-
291-
292297
----------------------------------------------------------------------------
293298
-- | Writes payload to the given 'Handle' using the local connection lock
294299
----------------------------------------------------------------------------
@@ -297,15 +302,15 @@ writeToHandle
297302
=> SockAddr
298303
-> Handle
299304
-> event
300-
-> Adaptor app r ()
305+
-> Adaptor app request ()
301306
writeToHandle _ handle evt = do
302307
let msg = encodeBaseProtocolMessage evt
303308
debugMessage ("\n" <> encodePretty evt)
304309
withConnectionLock (BS.hPutStr handle msg)
305310
----------------------------------------------------------------------------
306311
-- | Resets Adaptor's payload
307312
----------------------------------------------------------------------------
308-
resetAdaptorStatePayload :: Adaptor app r ()
313+
resetAdaptorStatePayload :: Adaptor app request ()
309314
resetAdaptorStatePayload = modify' $ \s -> s { payload = [] }
310315
----------------------------------------------------------------------------
311316
sendSuccesfulResponse :: Adaptor app Request () -> Adaptor app Request ()
@@ -319,7 +324,10 @@ sendSuccesfulEmptyResponse :: Adaptor app Request ()
319324
sendSuccesfulEmptyResponse = sendSuccesfulResponse (pure ())
320325
----------------------------------------------------------------------------
321326
-- | Sends successful event
322-
sendSuccesfulEvent :: EventType -> Adaptor app r () -> Adaptor app r ()
327+
sendSuccesfulEvent
328+
:: EventType
329+
-> Adaptor app request ()
330+
-> Adaptor app request ()
323331
sendSuccesfulEvent event action = do
324332
sendEvent $ do
325333
setEvent event
@@ -333,7 +341,7 @@ sendSuccesfulEvent event action = do
333341
sendError
334342
:: ErrorMessage
335343
-> Maybe Message
336-
-> Adaptor app r a
344+
-> Adaptor app request a
337345
sendError errorMessage maybeMessage = do
338346
throwError (errorMessage, maybeMessage)
339347
----------------------------------------------------------------------------
@@ -352,24 +360,24 @@ sendErrorResponse errorMessage maybeMessage = do
352360
----------------------------------------------------------------------------
353361
setErrorMessage
354362
:: ErrorMessage
355-
-> Adaptor app r ()
363+
-> Adaptor app request ()
356364
setErrorMessage v = setField "message" v
357365
----------------------------------------------------------------------------
358366
-- | Sends successful event
359367
setSuccess
360368
:: Bool
361-
-> Adaptor app r ()
369+
-> Adaptor app request ()
362370
setSuccess = setField "success"
363371
----------------------------------------------------------------------------
364372
setBody
365373
:: ToJSON value
366374
=> value
367-
-> Adaptor app r ()
375+
-> Adaptor app request ()
368376
setBody value = setField "body" value
369377
----------------------------------------------------------------------------
370378
setType
371379
:: MessageType
372-
-> Adaptor app r ()
380+
-> Adaptor app request ()
373381
setType messageType = do
374382
modify' $ \adaptorState ->
375383
adaptorState
@@ -378,14 +386,14 @@ setType messageType = do
378386
----------------------------------------------------------------------------
379387
setEvent
380388
:: EventType
381-
-> Adaptor app r ()
389+
-> Adaptor app request ()
382390
setEvent = setField "event"
383391
----------------------------------------------------------------------------
384392
setField
385393
:: ToJSON value
386394
=> Key
387395
-> value
388-
-> Adaptor app r ()
396+
-> Adaptor app request ()
389397
setField key value = do
390398
currentPayload <- gets payload
391399
modify' $ \adaptorState ->
@@ -395,7 +403,7 @@ setField key value = do
395403
----------------------------------------------------------------------------
396404
withConnectionLock
397405
:: IO ()
398-
-> Adaptor app r ()
406+
-> Adaptor app request ()
399407
withConnectionLock action = do
400408
lock <- asks handleLock
401409
liftIO (withLock lock action)
@@ -418,19 +426,21 @@ getArguments = do
418426
x -> do
419427
logError (BL8.pack (show x))
420428
liftIO $ throwIO (ParseException (show x))
421-
422429
----------------------------------------------------------------------------
423430
-- | Evaluates Adaptor action by using and updating the state in the MVar
424-
runAdaptorWith :: AdaptorLocal app r -> AdaptorState -> String -> Adaptor app r () -> IO ()
425-
runAdaptorWith lcl st s (Adaptor action) = do
426-
runStateT (runReaderT (runExceptT action) lcl) st
427-
return ()
428-
431+
runAdaptorWith
432+
:: AdaptorLocal app request
433+
-> AdaptorState
434+
-> Adaptor app request ()
435+
-> IO ()
436+
runAdaptorWith lcl st (Adaptor action) =
437+
void (runStateT (runReaderT (runExceptT action) lcl) st)
429438
----------------------------------------------------------------------------
430439
-- | Utility for evaluating a monad transformer stack
431440
runAdaptor :: AdaptorLocal app Request -> AdaptorState -> Adaptor app Request () -> IO ()
432441
runAdaptor lcl s (Adaptor client) =
433442
runStateT (runReaderT (runExceptT client) lcl) s >>= \case
434443
(Left (errorMessage, maybeMessage), s') ->
435444
runAdaptor lcl s' (sendErrorResponse errorMessage maybeMessage)
436-
(Right (), s') -> pure ()
445+
(Right (), _) -> pure ()
446+
----------------------------------------------------------------------------

‎src/DAP/Event.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -107,7 +107,7 @@ defaultMemoryEvent
107107
sendModuleEvent :: ModuleEvent -> Adaptor app Request ()
108108
sendModuleEvent = sendSuccesfulEvent EventTypeModule . setBody
109109
----------------------------------------------------------------------------
110-
sendOutputEvent :: OutputEvent -> Adaptor app r ()
110+
sendOutputEvent :: OutputEvent -> Adaptor app request ()
111111
sendOutputEvent = sendSuccesfulEvent EventTypeOutput . setBody
112112
----------------------------------------------------------------------------
113113
defaultOutputEvent :: OutputEvent

0 commit comments

Comments
 (0)