-module Main where
+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
-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)
+
+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 Send = Send [Message]
+
+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
-type Message = String
-skip = skipMany $ satisfy isSpace <|> char '\n' <|> char '\r'
+-- | Parse a string literal like "foo".
+strLiteral :: ReadP String
+strLiteral = between (char '"') (char '"') (many (satisfy (/= '"')))
-strLit :: ReadP String
-strLit = 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
-parseScript :: String -> [Block]
-parseScript = fst . last . readP_to_S (some block)
+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
-main = do
- fileName <- head <$> getArgs
- print . parseScript =<< readFile fileName
+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
projects / lsp-test.git / blobdiff