src/Language/Haskell/LSP/Test/Parsing.hs

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE RankNTypes #-}
   5 module Language.Haskell.LSP.Test.Parsing where
   6
   7 import Control.Applicative
   8 import Control.Concurrent.Chan
   9 import Control.Concurrent.MVar
  10 import Control.Monad.Trans.Class
  11 import Control.Monad.Trans.Reader
  12 import Control.Monad.Trans.State
  13 import Data.Aeson
  14 import qualified Data.ByteString.Lazy.Char8 as B
  15 import Data.Conduit hiding (await)
  16 import Data.Conduit.Parser
  17 import Data.Maybe
  18 import Language.Haskell.LSP.Messages
  19 import Language.Haskell.LSP.Types hiding (error)
  20 import Language.Haskell.LSP.Test.Compat
  21 import Language.Haskell.LSP.Test.Decoding
  22 import Language.Haskell.LSP.Test.Messages
  23 import System.IO
  24
  25 data SessionContext = SessionContext
  26   {
  27     serverIn :: Handle,
  28     rootDir :: FilePath,
  29     messageChan :: Chan FromServerMessage,
  30     requestMap :: MVar RequestMap,
  31     initRsp :: MVar InitializeResponse
  32   }
  33
  34 newtype SessionState = SessionState
  35   {
  36     curReqId :: LspId
  37   }
  38
  39 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
  40
  41 -- | A session representing one instance of launching and connecting to a server.
  42 --
  43 -- You can send and receive messages to the server within 'Session' via 'getMessage',
  44 -- 'sendRequest' and 'sendNotification'.
  45 --
  46 -- @
  47 -- runSession \"path\/to\/root\/dir\" $ do
  48 --   docItem <- getDocItem "Desktop/simple.hs" "haskell"
  49 --   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
  50 --   diagnostics <- getMessage :: Session PublishDiagnosticsNotification
  51 -- @
  52 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
  53
  54 -- | Matches if the message is a notification.
  55 anyNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  56 anyNotification = satisfy isServerNotification
  57
  58 notification :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a)
  59 notification = do
  60   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a)
  61   x <- satisfy (isJust . parser)
  62   return $ decodeMsg $ encodeMsg x
  63
  64 -- | Matches if the message is a request.
  65 anyRequest :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  66 anyRequest = satisfy isServerRequest
  67
  68 request :: forall m a b. (Monad m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b)
  69 request = do
  70   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b)
  71   x <- satisfy (isJust . parser)
  72   return $ decodeMsg $ encodeMsg x
  73
  74 -- | Matches if the message is a response.
  75 anyResponse :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  76 anyResponse = satisfy isServerResponse
  77
  78 response :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a)
  79 response = do
  80   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
  81   x <- satisfy (isJust . parser)
  82   return $ decodeMsg $ encodeMsg x
  83
  84 -- | A version of encode that encodes FromServerMessages as if they
  85 -- weren't wrapped.
  86 encodeMsg :: FromServerMessage -> B.ByteString
  87 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
  88
  89 decodeMsg :: FromJSON a => B.ByteString -> a
  90 decodeMsg x = fromMaybe (error $ "Unexpected message type\nGot:\n " ++ show x)
  91                   (decode x)
  92
  93 -- | Matches if the message is a log message notification or a show message notification/request.
  94 loggingNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  95 loggingNotification = satisfy shouldSkip
  96   where
  97     shouldSkip (NotLogMessage _) = True
  98     shouldSkip (NotShowMessage _) = True
  99     shouldSkip (ReqShowMessage _) = True
 100     shouldSkip _ = False
 101
 102 publishDiagnosticsNotification :: Monad m => ConduitParser FromServerMessage m PublishDiagnosticsNotification
 103 publishDiagnosticsNotification = do
 104   NotPublishDiagnostics diags <- satisfy test
 105   return diags
 106   where test (NotPublishDiagnostics _) = True
 107         test _ = False
 108
 109 satisfy :: Monad m => (a -> Bool) -> ConduitParser a m a
 110 satisfy pred = do
 111   x <- await
 112   if pred x
 113     then return x
 114     else empty
 115
 116 runSession' :: Chan FromServerMessage -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
 117 runSession' chan context state session = runReaderT (runStateT conduit state) context
 118   where conduit = runConduit $ chanSource chan .| runConduitParser session
 119
 120 get :: Monad m => ParserStateReader a s r m s
 121 get = lift Control.Monad.Trans.State.get
 122
 123 put :: Monad m => s -> ParserStateReader a s r m ()
 124 put = lift . Control.Monad.Trans.State.put
 125
 126 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
 127 modify = lift . Control.Monad.Trans.State.modify
 128
 129 ask :: Monad m => ParserStateReader a s r m r
 130 ask = lift $ lift Control.Monad.Trans.Reader.ask