Start work on script and FSM

diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal
index bc0f58193b9f234f507cfbf04c264776515ccb61..5facd922e76c479291ca6c6b0b6ef8382bbf4e61 100644 (file)
--- 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 b406e7bd4e87a5a068d59b44e7b27678b100a64e..6c2c052570bfca437d7f568f56643e62893cc451 100644 (file)
--- 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 (file)
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 (file)
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