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   }
  32
  33 newtype SessionState = SessionState
  34   {
  35     curReqId :: LspId
  36   }
  37
  38 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
  39
  40 -- | A session representing one instance of launching and connecting to a server.
  41 --
  42 -- You can send and receive messages to the server within 'Session' via 'getMessage',
  43 -- 'sendRequest' and 'sendNotification'.
  44 --
  45 -- @
  46 -- runSession \"path\/to\/root\/dir\" $ do
  47 --   docItem <- getDocItem "Desktop/simple.hs" "haskell"
  48 --   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
  49 --   diagnostics <- getMessage :: Session PublishDiagnosticsNotification
  50 -- @
  51 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
  52
  53 -- | Matches if the message is a notification.
  54 anyNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  55 anyNotification = satisfy isServerNotification
  56
  57 notification :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a)
  58 notification = do
  59   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a)
  60   x <- satisfy (isJust . parser)
  61   return $ decodeMsg $ encodeMsg x
  62
  63 -- | Matches if the message is a request.
  64 anyRequest :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  65 anyRequest = satisfy isServerRequest
  66
  67 request :: forall m a b. (Monad m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b)
  68 request = do
  69   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b)
  70   x <- satisfy (isJust . parser)
  71   return $ decodeMsg $ encodeMsg x
  72
  73 -- | Matches if the message is a response.
  74 anyResponse :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  75 anyResponse = satisfy isServerResponse
  76
  77 response :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a)
  78 response = do
  79   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
  80   x <- satisfy (isJust . parser)
  81   return $ decodeMsg $ encodeMsg x
  82
  83 -- | A version of encode that encodes FromServerMessages as if they
  84 -- weren't wrapped.
  85 encodeMsg :: FromServerMessage -> B.ByteString
  86 encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
  87
  88 decodeMsg :: FromJSON a => B.ByteString -> a
  89 decodeMsg x = fromMaybe (error $ "Unexpected message type\nGot:\n " ++ show x)
  90                   (decode x)
  91
  92 -- | Matches if the message is a log message notification or a show message notification/request.
  93 loggingNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
  94 loggingNotification = satisfy shouldSkip
  95   where
  96     shouldSkip (NotLogMessage _) = True
  97     shouldSkip (NotShowMessage _) = True
  98     shouldSkip (ReqShowMessage _) = True
  99     shouldSkip _ = False
 100
 101 publishDiagnosticsNotification :: Monad m => ConduitParser FromServerMessage m PublishDiagnosticsNotification
 102 publishDiagnosticsNotification = do
 103   NotPublishDiagnostics diags <- satisfy test
 104   return diags
 105   where test (NotPublishDiagnostics _) = True
 106         test _ = False
 107
 108 satisfy :: Monad m => (a -> Bool) -> ConduitParser a m a
 109 satisfy pred = do
 110   x <- await
 111   if pred x
 112     then return x
 113     else empty
 114
 115 runSession' :: Chan FromServerMessage -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
 116 runSession' chan context state session = runReaderT (runStateT conduit state) context
 117   where conduit = runConduit $ chanSource chan .| runConduitParser session
 118
 119 get :: Monad m => ParserStateReader a s r m s
 120 get = lift Control.Monad.Trans.State.get
 121
 122 put :: Monad m => s -> ParserStateReader a s r m ()
 123 put = lift . Control.Monad.Trans.State.put
 124
 125 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
 126 modify = lift . Control.Monad.Trans.State.modify
 127
 128 ask :: Monad m => ParserStateReader a s r m r
 129 ask = lift $ lift Control.Monad.Trans.Reader.ask