From: Luke Lau Date: Mon, 9 Jul 2018 00:27:48 +0000 (+0100) Subject: Merge branch 'master' into script-fsm X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=fbb260c6078a39ff071fefd6586af18715b3e6a3;hp=f8ee63f1c1d245c16f7a928c14c0e8908e6240c8 Merge branch 'master' into script-fsm --- diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index 4a3c5ed..c5d1391 100644 --- 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 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 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 )|( )" + +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 3ecc538..88109a5 100644 --- 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 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 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 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" +}