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

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Language.Haskell.LSP.Test.Machine where
   3
   4 import Control.Monad.IO.Class
   5 import Language.Haskell.LSP.Messages
   6 import Language.Haskell.LSP.Types
   7 import Language.Haskell.LSP.Test
   8 import Language.Haskell.LSP.Test.Messages
   9 import Language.Haskell.LSP.Test.Session
  10
  11 data State = State String (FromServerMessage -> Bool) [FromClientMessage] State
  12            | Passed
  13            | Failed
  14
  15 data Event = Timeout | Received FromServerMessage
  16
  17 advance :: State -> Event -> Session State
  18 advance _ Timeout = return Failed
  19 advance s@(State name f outMsgs next) (Received msg)
  20   | f msg = do
  21     liftIO $ putStrLn name
  22     mapM_ (handleClientMessage sendRequestMessage sendMessage sendMessage) outMsgs
  23     return next
  24   | otherwise = return s
  25 advance s _ = return s
  26
  27 mkStates [] = Passed
  28 mkStates ((n, f, msgs):xs) = State n f msgs (mkStates xs)
  29
  30 main = let symbReq = ReqDocumentSymbols (RequestMessage "2.0" (IdInt 24) TextDocumentDocumentSymbol (DocumentSymbolParams (TextDocumentIdentifier (filePathToUri "/Users/luke/Desktop/test/src/Lib.hs"))))
  31            barPred (RspDocumentSymbols _) = True
  32            barPred _ = False
  33            encoded = [("start", const True, [symbReq])
  34                      ,("silent", barPred, [])
  35                      ,("end", const True, [])]
  36            initState = mkStates encoded
  37         in
  38           runSession "hie --lsp" "/Users/luke/Desktop/test" $ do
  39             openDoc "src/Lib.hs" "haskell"
  40             let f Passed = return Passed
  41                 f s = Received <$> anyMessage >>= advance s >>= f
  42             res <- f initState
  43             case res of
  44               Passed -> return "passed"
  45               _ -> return "failed"
  46