X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FScript.hs;h=ce4466429c853aafe7e292d5b3a13d53d0b873e0;hb=ae334dce13ab47fd20b976a17b1f296e082c7531;hp=9577ee335b2036ad6ee4a74bc3f672e88503e8b1;hpb=4ad648fac174ce2b8475d24c2e4f215105e10e94;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Script.hs b/src/Language/Haskell/LSP/Test/Script.hs
index 9577ee3..ce44664 100644
--- a/src/Language/Haskell/LSP/Test/Script.hs
+++ b/src/Language/Haskell/LSP/Test/Script.hs
@@ -1,80 +1,164 @@
-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