Merge branch 'master' into script-fsm

diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal
index 4a3c5ed9c1d957b9546382f254c6b86c0a738815..c5d1391eca38a99d3546c5ef407c06eaf5f564a0 100644 (file)
--- a/haskell-lsp-test.cabal
+++ b/haskell-lsp-test.cabal
@@ -10,15 +10,46 @@ maintainer:          luke_lau@icloud.com
 copyright:           2018 Luke Lau
 category:            Testing
 build-type:          Simple
-cabal-version:       >=1.10
+cabal-version:       >=2.0
 extra-source-files:  README.md
 
 library
-  hs-source-dirs:      src
+  hs-source-dirs:      lib
   exposed-modules:     Language.Haskell.LSP.Test
                      , Language.Haskell.LSP.Test.Replay
+                     , Language.Haskell.LSP.Test.Machine
   default-language:    Haskell2010
   build-depends:       base >= 4.7 && < 5
+                     , haskell-lsp-types
+                     , haskell-lsp >= 0.3
+                     , haskell-lsp-test-internal
+                     , aeson
+                     , bytestring
+                     , containers
+                     , data-default
+                     , directory
+                     , filepath
+                     , lens
+                     , parser-combinators
+                     , text
+                     , unordered-containers
+                     , yi-rope
+
+  ghc-options:         -W
+
+library haskell-lsp-test-internal
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  exposed-modules:     Language.Haskell.LSP.Test.Compat
+                       Language.Haskell.LSP.Test.Decoding
+                       Language.Haskell.LSP.Test.Exceptions
+                       Language.Haskell.LSP.Test.Files
+                       Language.Haskell.LSP.Test.Messages
+                       Language.Haskell.LSP.Test.Parsing
+                       Language.Haskell.LSP.Test.Script
+                       Language.Haskell.LSP.Test.Server
+                       Language.Haskell.LSP.Test.Session
+  build-depends:       base
                      , haskell-lsp-types
                      , haskell-lsp >= 0.3
                      , aeson
@@ -33,6 +64,7 @@ library
                      , filepath
                      , lens
                      , mtl
+                     , scientific
                      , parser-combinators
                      , process
                      , text
@@ -43,16 +75,26 @@ library
     build-depends:     Win32
   else
     build-depends:     unix
-  other-modules:       Language.Haskell.LSP.Test.Compat
-                       Language.Haskell.LSP.Test.Decoding
-                       Language.Haskell.LSP.Test.Exceptions
-                       Language.Haskell.LSP.Test.Files
-                       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:     lsp-test
+  main-is:            Main.hs
+  default-language:   Haskell2010
+  build-depends:      base >= 4.7 && < 5
+                    , haskell-lsp-types
+                    , haskell-lsp >= 0.3
+                    , haskell-lsp-test-internal
+                    , haskell-lsp-test
+                    , aeson
+                    , bytestring
+                    , directory
+                    , filepath
+                    , text
+                    , unordered-containers
+                    , scientific
+
 test-suite tests
   type:                exitcode-stdio-1.0
   main-is:             Test.hs
@@ -64,6 +106,7 @@ test-suite tests
                      , data-default
                      , directory
                      , haskell-lsp-test
+                     , haskell-lsp-test-internal
                      , haskell-lsp
                      , haskell-lsp-types
                      , conduit
@@ -73,7 +116,7 @@ test-suite tests
                      , text
   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/lib/Language/Haskell/LSP/Test.hs
similarity index 100%
rename from src/Language/Haskell/LSP/Test.hs
rename to lib/Language/Haskell/LSP/Test.hs

diff --git a/lib/Language/Haskell/LSP/Test/Machine.hs b/lib/Language/Haskell/LSP/Test/Machine.hs
new file mode 100644 (file)
index 0000000..7e0a78d
--- /dev/null
+++ b/lib/Language/Haskell/LSP/Test/Machine.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.Haskell.LSP.Test.Machine where
+
+import Control.Monad.IO.Class
+import Language.Haskell.LSP.Messages
+import Language.Haskell.LSP.Test
+
+data State = State String (FromServerMessage -> Bool) [Session ()] State
+           | Passed
+           | Failed
+
+data Event = Timeout | Received FromServerMessage
+
+advance :: State -> Event -> Session State
+advance _ Timeout = return Failed
+advance s@(State name f actions next) (Received msg)
+  | f msg = do
+    liftIO $ putStrLn name
+    sequence_ actions
+    return next
+  | otherwise = return s
+advance s _ = return s
+
+mkStates [] = Passed
+mkStates ((n, f, msgs):xs) = State n f msgs (mkStates xs)
+
+runMachine :: String -> FilePath -> [(String, FromServerMessage -> Bool, [Session ()])] -> IO Bool
+runMachine cmd rootDir encodedStates =
+  runSession cmd rootDir $ do
+    let f Passed = return Passed
+        f s = Received <$> anyMessage >>= advance s >>= f
+        initState = mkStates encodedStates
+    res <- f initState
+    case res of
+      Passed -> return True
+      _ -> return False
+

diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/lib/Language/Haskell/LSP/Test/Replay.hs
similarity index 100%
rename from src/Language/Haskell/LSP/Test/Replay.hs
rename to lib/Language/Haskell/LSP/Test/Replay.hs

diff --git a/lsp-test/Main.hs b/lsp-test/Main.hs
new file mode 100644 (file)
index 0000000..ec9cfa4
--- /dev/null
+++ b/lsp-test/Main.hs
@@ -0,0 +1,71 @@
+module Main where
+
+import           Control.Monad
+import           Data.Aeson
+import qualified Data.Text                     as T
+import qualified Data.HashMap.Lazy             as HM
+import           Language.Haskell.LSP.Test
+import           Language.Haskell.LSP.Test.Script
+import           System.Environment
+import           System.FilePath
+import           System.Directory
+import           System.Exit
+import           Language.Haskell.LSP.Test.Machine
+import           Language.Haskell.LSP.Test.Parsing
+                                                ( toJSONMsg )
+import           Language.Haskell.LSP.Test.Replay
+import           Language.Haskell.LSP.Messages
+import qualified Language.Haskell.LSP.Types    as LSP
+
+main = do
+  args <- getArgs
+  curDir <- getCurrentDirectory
+  case args of
+    ["replay", cmd] -> replaySession cmd curDir
+    [file, cmd] -> do
+      blocks <- parseScript <$> readFile file
+      success <- runBlocks cmd curDir blocks
+      if success
+        then putStrLn "Success ✅"
+        else putStrLn "Failed ❌" >> exitFailure
+    _ -> putStrLn "usage: lsp-test (replay <cmd>)|(<file> <cmd>)"
+
+runBlocks :: String -> FilePath -> [Block] -> IO Bool
+runBlocks cmd rootDir blocks = runMachine cmd rootDir (map convertBlock blocks)
+  where
+    convertBlock :: Block -> (String, FromServerMessage -> Bool, [Session ()])
+    convertBlock (Block name w actions) = (name, mkWait w, map mkAction actions)
+
+    mkWait :: Wait -> FromServerMessage -> Bool
+    mkWait WaitAny _ = True
+    mkWait (WaitPred preds) x = all (`mkPred` x) preds
+
+    mkPred :: Predicate -> (FromServerMessage -> Bool)
+    mkPred (Predicate accessor comparison) msg =
+      let (Object obj) = toJSONMsg msg in comp (access obj accessor) comparison
+
+    comp (Just (String str)) (EqualsString expected) = str == T.pack expected
+    comp (Just (Number num)) (EqualsNumber expected) = num == expected
+    comp _ _ = False
+
+    access :: Object -> Accessor -> Maybe Value
+    access obj (AccessorTerm prop) = HM.lookup (T.pack prop) obj
+    access obj (Accessor prop next) =
+      case HM.lookup (T.pack prop) obj of
+        Just (Object nextObj) -> access nextObj next
+        _ -> Nothing
+
+    mkAction :: Action -> Session ()
+
+    mkAction (OpenDoc fp fileType) = void $ openDoc fp fileType
+
+    mkAction (Request identifier methodStr ps) = void $ sendRequest' (strToMethod methodStr) (paramToValue ps)
+    mkAction (Reply methodStr ps) = undefined -- TODO
+    mkAction (Notify methodStr ps) = void $ sendNotification (strToMethod methodStr) (paramToValue ps)
+
+    strToMethod str = case fromJSON (String $ T.pack str) of
+      Success x -> x
+      Error _ -> error $ str ++ " is not a valid method"
+    paramToValue (ParamString str) = String str
+    paramToValue (ParamUri uri)    = toJSON $ LSP.filePathToUri (rootDir </> uri)
+    paramToValue (ParamObject obj) = Object (HM.map paramToValue obj)
\ No newline at end of file

diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs
index 3ecc53888b31f5090b64344a866d512b5dd1460b..88109a5155801e2ed3015861c019ee4fd93217d6 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Parsing.hs
+++ b/src/Language/Haskell/LSP/Test/Parsing.hs
@@ -85,7 +85,10 @@ castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg
 -- | A version of encode that encodes FromServerMessages as if they
 -- weren't wrapped.
 encodeMsg :: FromServerMessage -> B.ByteString
-encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
+encodeMsg = encode . toJSONMsg
+
+toJSONMsg :: FromServerMessage -> Value
+toJSONMsg = genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
 
 -- | Matches if the message is a log message notification or a show message notification/request.
 loggingNotification :: Session FromServerMessage

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..ce44664
--- /dev/null
+++ b/src/Language/Haskell/LSP/Test/Script.hs
@@ -0,0 +1,164 @@
+module Language.Haskell.LSP.Test.Script where
+
+import Control.Applicative ( (<|>), some )
+import Control.Monad
+import Data.Char
+import qualified Data.Text as T
+import qualified Data.HashMap.Lazy as HM
+import Data.Scientific
+import Text.ParserCombinators.ReadP
+
+data Block = Block String Wait [Action]
+  deriving Show
+
+data Wait = WaitPred [Predicate]
+          | WaitAny
+  deriving Show
+
+data Predicate = Predicate Accessor Comparison
+  deriving Show
+
+data Accessor = AccessorTerm String
+              | Accessor String Accessor
+  deriving Show
+
+data Comparison = EqualsNumber Scientific
+                | EqualsString String
+                | ContainsString String
+  deriving Show
+
+data Action = OpenDoc FilePath String
+            | Request String Method MessageParam
+            | Reply Method MessageParam
+            | Notify Method MessageParam
+  deriving Show
+
+type Method = String
+
+data MessageParam = ParamObject (HM.HashMap T.Text MessageParam)
+                  | ParamString T.Text
+                  | ParamUri FilePath
+  deriving Show
+
+-- | Parse a string literal like "foo".
+strLiteral :: ReadP String
+strLiteral = between (char '"') (char '"') (many (satisfy (/= '"')))
+
+-- | Parse mandatory whitespace, including newlines
+space :: ReadP ()
+space = void $ some (satisfy isSpace)
+
+block :: ReadP Block
+block = do
+  skipSpaces
+  name <- strLiteral
+  skipSpaces
+  between (char '{') (char '}') $ do
+    skipSpaces
+    w <- wait
+    actions <- option [] $ do
+      space
+      string "then"
+      space
+      action `sepBy1` space
+    skipSpaces
+    return $ Block name w actions
+
+wait :: ReadP Wait
+wait = do
+  string "wait for"
+  space
+  f <|> g
+  where f = string "any" >> return WaitAny
+        g = WaitPred <$> some predicate
+
+predicate :: ReadP Predicate
+predicate = do
+  x <- accessor
+  Predicate x <$> comparison
+
+accessor :: ReadP Accessor
+accessor = do
+  x:xs <- reverse <$> sepBy1 property (char '.')
+  return $ foldl (flip Accessor) (AccessorTerm x) xs
+  where property = many (satisfy isAlphaNum)
+
+comparison :: ReadP Comparison
+comparison = do
+  space
+  operator <- string "==" <|> string "is in"
+  space
+  choice [eqString, eqNumber]
+  -- todo: contains string
+  where eqString = EqualsString <$> strLiteral
+        eqNumber = EqualsNumber . read <$> some (satisfy isNumber)
+
+action :: ReadP Action
+action = choice
+    [ openAction
+    , requestAction
+    , sendAction "reply"   Reply
+    , sendAction "notify"  Notify
+    ]
+  where
+    requestAction = do
+      skipSpaces
+      identifier <- manyTill (satisfy isAlphaNum) (skipSpaces >> char ':')
+      skipSpaces
+      sendAction "request" (Request identifier)
+
+openAction :: ReadP Action
+openAction = do
+  skipSpaces
+  string "open"
+  space
+  fp <- strLiteral
+  space
+  OpenDoc fp <$> strLiteral
+
+sendAction :: String -> (String -> MessageParam -> Action) -> ReadP Action
+sendAction keyword con = do
+  skipSpaces
+  string keyword
+  skipSpaces
+  method <- strLiteral
+  skipSpaces
+  con method <$> messageParam
+
+messageParam :: ReadP MessageParam
+messageParam = choice [uriParam, stringParam, objParam]
+  where
+    uriParam = do
+      skipSpaces
+      string "uri"
+      skipSpaces
+      fp <- strLiteral
+      skipSpaces
+      return (ParamUri fp)
+
+    stringParam = ParamString . T.pack <$> strLiteral
+
+    objParam = do
+      props <- between (char '{') (char '}') (some parseProp)
+      return (ParamObject (HM.fromList props))
+
+    parseProp = do
+      skipSpaces
+      name <- many (satisfy (\x -> (x /= ':') && isAlphaNum x))
+      char ':'
+      skipSpaces
+      param <- messageParam
+      skipSpaces
+      return (T.pack name, param)
+
+parseScript :: String -> [Block]
+parseScript str =
+  case readP_to_S parser str of
+    [] -> error "Couldn't parse"
+    xs -> fst $ last xs
+  where
+    parser = do
+      blocks <- some block
+      skipSpaces
+      eof
+      return blocks
\ No newline at end of file

diff --git a/test/data/script/Test.hs b/test/data/script/Test.hs
new file mode 100644 (file)
index 0000000..c1ac06e
--- /dev/null
+++ b/test/data/script/Test.hs
@@ -0,0 +1,3 @@
+foo = 3
+bar = False
+baz = "hello"

diff --git a/test/data/script/test.lsp b/test/data/script/test.lsp
new file mode 100644 (file)
index 0000000..52c0a95
--- /dev/null
+++ b/test/data/script/test.lsp
@@ -0,0 +1,18 @@
+"start" { wait for any then open "Test.hs" "haskell" }
+"get the symbols" {
+  wait for
+    method == "textDocument/publishDiagnostics"
+  then
+    open "Test.hs" "haskell"
+    id1: request "textDocument/documentSymbol" {
+      textDocument: {
+        uri: uri "Test.hs"
+      }
+    }
+}
+"check the symbols" {
+  wait for
+    id == 1
+  then
+    open "Test.hs" "haskell"
+}