X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FScript.hs;fp=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FScript.hs;h=f9721b0e0298407a58f743b2cb330d8e3ab74b2b;hp=9577ee335b2036ad6ee4a74bc3f672e88503e8b1;hb=92f1ae3d69a580eee74755a38a647e27c4f164ff;hpb=4ad648fac174ce2b8475d24c2e4f215105e10e94 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)