From 92f1ae3d69a580eee74755a38a647e27c4f164ff Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 6 Jul 2018 23:02:23 +0100 Subject: [PATCH] Hook LSP script into haskell-lsp-test --- haskell-lsp-test.cabal | 25 +++ src/Language/Haskell/LSP/Test/Machine.hs | 23 +-- src/Language/Haskell/LSP/Test/Parsing.hs | 5 +- src/Language/Haskell/LSP/Test/Script.hs | 237 ++++++++++++++++++----- test.lsp | 18 ++ 5 files changed, 245 insertions(+), 63 deletions(-) create mode 100644 test.lsp diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index 5facd92..f724796 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -59,6 +59,31 @@ executable lsp-test main-is: Language/Haskell/LSP/Test/Script.hs default-language: Haskell2010 build-depends: base >= 4.7 && < 5 + , haskell-lsp-types + , haskell-lsp >= 0.3 + , aeson + , ansi-terminal + , async + , bytestring + , conduit + , conduit-parse + , containers + , data-default + , directory + , filepath + , lens + , mtl + , parser-combinators + , process + , text + , transformers + , unordered-containers + , scientific + , yi-rope + if os(windows) + build-depends: Win32 + else + build-depends: unix test-suite tests type: exitcode-stdio-1.0 diff --git a/src/Language/Haskell/LSP/Test/Machine.hs b/src/Language/Haskell/LSP/Test/Machine.hs index f305570..f407c7d 100644 --- a/src/Language/Haskell/LSP/Test/Machine.hs +++ b/src/Language/Haskell/LSP/Test/Machine.hs @@ -3,12 +3,9 @@ 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 +data State = State String (FromServerMessage -> Bool) [Session ()] State | Passed | Failed @@ -16,10 +13,10 @@ data Event = Timeout | Received FromServerMessage advance :: State -> Event -> Session State advance _ Timeout = return Failed -advance s@(State name f outMsgs next) (Received msg) +advance s@(State name f actions next) (Received msg) | f msg = do liftIO $ putStrLn name - mapM_ (handleClientMessage sendRequestMessage sendMessage sendMessage) outMsgs + sequence_ actions return next | otherwise = return s advance s _ = return s @@ -27,18 +24,12 @@ 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" +runMachine :: String -> [(String, FromServerMessage -> Bool, [Session ()])] -> IO String +runMachine rootDir encodedStates = + runSession "hie --lsp" 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 "passed" diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 614495b..06776cb 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 :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage diff --git a/src/Language/Haskell/LSP/Test/Script.hs b/src/Language/Haskell/LSP/Test/Script.hs index 9577ee3..f9721b0 100644 --- a/src/Language/Haskell/LSP/Test/Script.hs +++ b/src/Language/Haskell/LSP/Test/Script.hs @@ -1,80 +1,225 @@ module Main where import Control.Applicative ( (<|>), some ) +import Control.Monad +import Data.Aeson import Data.Char +import qualified Data.Text as T +import qualified Data.HashMap.Lazy as HM +import Data.Maybe +import Data.Scientific import Text.ParserCombinators.ReadP import System.Environment +import System.FilePath +import System.Directory +import Language.Haskell.LSP.Test (openDoc, sendRequest', sendNotification, sendResponse) +import Language.Haskell.LSP.Test.Session +import Language.Haskell.LSP.Test.Machine +import Language.Haskell.LSP.Test.Parsing (toJSONMsg) +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.TH.MessageFuncs +import qualified Language.Haskell.LSP.Types as LSP +import Debug.Trace -{- - - "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) +data Block = Block String Wait [Action] deriving Show + data Wait = WaitPred [Predicate] | WaitAny deriving Show -data Predicate = Predicate String String + +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 Send = Send [Message] + +data Action = OpenDoc FilePath String + | Request String Method MessageParam + | Reply Method MessageParam + | Notify Method MessageParam deriving Show -type Message = String -skip = skipMany $ satisfy isSpace <|> char '\n' <|> char '\r' +type Method = String -strLit :: ReadP String -strLit = between (char '"') (char '"') (many (satisfy (/= '"'))) +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 - skip - name <- strLit - skip + skipSpaces + name <- strLiteral + skipSpaces + between (char '{') (char '}') $ do + skipSpaces w <- wait - skip - s <- option Nothing (Just <$> send) - return $ Block name w s + actions <- option [] $ do + space + string "then" + space + action `sepBy1` space + skipSpaces + return $ Block name w actions wait :: ReadP Wait wait = do string "wait for" - skip + space 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) + 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 = fst . last . readP_to_S (some 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 main = do fileName <- head <$> getArgs - print . parseScript =<< readFile fileName + blocks <- parseScript <$> readFile fileName + print blocks + rootDir <- getCurrentDirectory + runBlocks rootDir blocks + + +runBlocks :: FilePath -> [Block] -> IO () +runBlocks rootDir blocks = runMachine rootDir (map convertBlock blocks) >>= putStrLn + 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) = traceShowId $ 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) diff --git a/test.lsp b/test.lsp new file mode 100644 index 0000000..954ca5b --- /dev/null +++ b/test.lsp @@ -0,0 +1,18 @@ +"start" { wait for any then open "src/Lib.hs" "haskell" } +"get the symbols" { + wait for + method == "textDocument/publishDiagnostics" + then + open "src/Lib.hs" "haskell" + id1: request "textDocument/documentSymbol" { + textDocument: { + uri: uri "src/Lib.hs" + } + } +} +"check the symbols" { + wait for + id == 1 + then + open "src/Lib.hs" "haskell" +} \ No newline at end of file -- 2.30.2