From 4ad648fac174ce2b8475d24c2e4f215105e10e94 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 4 Jul 2018 16:50:52 +0100 Subject: [PATCH] Start work on script and FSM --- haskell-lsp-test.cabal | 9 ++- src/Language/Haskell/LSP/Test.hs | 2 +- src/Language/Haskell/LSP/Test/Machine.hs | 46 ++++++++++++++ src/Language/Haskell/LSP/Test/Script.hs | 80 ++++++++++++++++++++++++ 4 files changed, 135 insertions(+), 2 deletions(-) create mode 100644 src/Language/Haskell/LSP/Test/Machine.hs create mode 100644 src/Language/Haskell/LSP/Test/Script.hs diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index bc0f581..5facd92 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -47,12 +47,19 @@ library Language.Haskell.LSP.Test.Decoding Language.Haskell.LSP.Test.Exceptions Language.Haskell.LSP.Test.Files + Language.Haskell.LSP.Test.Machine Language.Haskell.LSP.Test.Messages Language.Haskell.LSP.Test.Parsing Language.Haskell.LSP.Test.Server Language.Haskell.LSP.Test.Session ghc-options: -W +executable lsp-test + hs-source-dirs: src + main-is: Language/Haskell/LSP/Test/Script.hs + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + test-suite tests type: exitcode-stdio-1.0 main-is: Test.hs @@ -74,7 +81,7 @@ test-suite tests other-modules: ParsingTests default-language: Haskell2010 -executable example +executable lsp-test-example hs-source-dirs: example main-is: Main.hs default-language: Haskell2010 diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index b406e7b..6c2c052 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -94,7 +94,7 @@ import Data.Default import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import Data.Maybe -import Language.Haskell.LSP.Types hiding (id, capabilities, error) +import Language.Haskell.LSP.Types hiding (id, capabilities) import qualified Language.Haskell.LSP.Types as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.VFS diff --git a/src/Language/Haskell/LSP/Test/Machine.hs b/src/Language/Haskell/LSP/Test/Machine.hs new file mode 100644 index 0000000..f305570 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Machine.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.Haskell.LSP.Test.Machine where + +import Control.Monad.IO.Class +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Test.Messages +import Language.Haskell.LSP.Test.Session + +data State = State String (FromServerMessage -> Bool) [FromClientMessage] State + | Passed + | Failed + +data Event = Timeout | Received FromServerMessage + +advance :: State -> Event -> Session State +advance _ Timeout = return Failed +advance s@(State name f outMsgs next) (Received msg) + | f msg = do + liftIO $ putStrLn name + mapM_ (handleClientMessage sendRequestMessage sendMessage sendMessage) outMsgs + return next + | otherwise = return s +advance s _ = return s + +mkStates [] = Passed +mkStates ((n, f, msgs):xs) = State n f msgs (mkStates xs) + +main = let symbReq = ReqDocumentSymbols (RequestMessage "2.0" (IdInt 24) TextDocumentDocumentSymbol (DocumentSymbolParams (TextDocumentIdentifier (filePathToUri "/Users/luke/Desktop/test/src/Lib.hs")))) + barPred (RspDocumentSymbols _) = True + barPred _ = False + encoded = [("start", const True, [symbReq]) + ,("silent", barPred, []) + ,("end", const True, [])] + initState = mkStates encoded + in + runSession "hie --lsp" "/Users/luke/Desktop/test" $ do + openDoc "src/Lib.hs" "haskell" + let f Passed = return Passed + f s = Received <$> anyMessage >>= advance s >>= f + res <- f initState + case res of + Passed -> return "passed" + _ -> return "failed" + diff --git a/src/Language/Haskell/LSP/Test/Script.hs b/src/Language/Haskell/LSP/Test/Script.hs new file mode 100644 index 0000000..9577ee3 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Script.hs @@ -0,0 +1,80 @@ +module Main where + +import Control.Applicative ( (<|>), some ) +import Data.Char +import Text.ParserCombinators.ReadP +import System.Environment + +{- + - "asdf" + - wait for + - asdsdf == "asdf" + - adsf == "adsf" + - send + - foo + - bar + - + - str ::= " char " + - wait ::= wait for (pred+ | any) + - pred ::= x == y + - send ::= send msg+ + - msg ::= str + - block ::= str wait send? + -} + +data Block = Block String Wait (Maybe Send) + deriving Show +data Wait = WaitPred [Predicate] + | WaitAny + deriving Show +data Predicate = Predicate String String + deriving Show +data Send = Send [Message] + deriving Show +type Message = String + +skip = skipMany $ satisfy isSpace <|> char '\n' <|> char '\r' + +strLit :: ReadP String +strLit = between (char '"') (char '"') (many (satisfy (/= '"'))) + +block :: ReadP Block +block = do + skip + name <- strLit + skip + w <- wait + skip + s <- option Nothing (Just <$> send) + return $ Block name w s + +wait :: ReadP Wait +wait = do + string "wait for" + skip + f <|> g + where f = string "any" >> return WaitAny + g = WaitPred <$> some predicate + +predicate :: ReadP Predicate +predicate = do + skip + x <- strLit + skip + string "==" + skip + y <- strLit + return $ Predicate x y + +send :: ReadP Send +send = do + -- skip + string "send" + Send <$> some (skip >> strLit) + +parseScript :: String -> [Block] +parseScript = fst . last . readP_to_S (some block) + +main = do + fileName <- head <$> getArgs + print . parseScript =<< readFile fileName -- 2.30.2