src/Language/Haskell/LSP/Test/Script.hs

   1 module Language.Haskell.LSP.Test.Script where
   2
   3 import Control.Applicative ( (<|>), some )
   4 import Control.Monad
   5 import Data.Char
   6 import qualified Data.Text as T
   7 import qualified Data.HashMap.Lazy as HM
   8 import Data.Scientific
   9 import Text.ParserCombinators.ReadP
  10
  11 data Block = Block String Wait [Action]
  12   deriving Show
  13
  14 data Wait = WaitPred [Predicate]
  15           | WaitAny
  16   deriving Show
  17
  18 data Predicate = Predicate Accessor Comparison
  19   deriving Show
  20
  21 data Accessor = AccessorTerm String
  22               | Accessor String Accessor
  23   deriving Show
  24
  25 data Comparison = EqualsNumber Scientific
  26                 | EqualsString String
  27                 | ContainsString String
  28   deriving Show
  29
  30 data Action = OpenDoc FilePath String
  31             | Request String Method MessageParam
  32             | Reply Method MessageParam
  33             | Notify Method MessageParam
  34   deriving Show
  35
  36 type Method = String
  37
  38 data MessageParam = ParamObject (HM.HashMap T.Text MessageParam)
  39                   | ParamString T.Text
  40                   | ParamUri FilePath
  41   deriving Show
  42
  43 -- | Parse a string literal like "foo".
  44 strLiteral :: ReadP String
  45 strLiteral = between (char '"') (char '"') (many (satisfy (/= '"')))
  46
  47 -- | Parse mandatory whitespace, including newlines
  48 space :: ReadP ()
  49 space = void $ some (satisfy isSpace)
  50
  51 block :: ReadP Block
  52 block = do
  53   skipSpaces
  54   name <- strLiteral
  55   skipSpaces
  56   between (char '{') (char '}') $ do
  57     skipSpaces
  58     w <- wait
  59     actions <- option [] $ do
  60       space
  61       string "then"
  62       space
  63       action `sepBy1` space
  64     skipSpaces
  65     return $ Block name w actions
  66
  67 wait :: ReadP Wait
  68 wait = do
  69   string "wait for"
  70   space
  71   f <|> g
  72   where f = string "any" >> return WaitAny
  73         g = WaitPred <$> some predicate
  74
  75 predicate :: ReadP Predicate
  76 predicate = do
  77   x <- accessor
  78   Predicate x <$> comparison
  79
  80 accessor :: ReadP Accessor
  81 accessor = do
  82   x:xs <- reverse <$> sepBy1 property (char '.')
  83   return $ foldl (flip Accessor) (AccessorTerm x) xs
  84   where property = many (satisfy isAlphaNum)
  85
  86 comparison :: ReadP Comparison
  87 comparison = do
  88   space
  89   operator <- string "==" <|> string "is in"
  90   space
  91   choice [eqString, eqNumber]
  92   -- todo: contains string
  93   where eqString = EqualsString <$> strLiteral
  94         eqNumber = EqualsNumber . read <$> some (satisfy isNumber)
  95
  96 action :: ReadP Action
  97 action = choice
  98     [ openAction
  99     , requestAction
 100     , sendAction "reply"   Reply
 101     , sendAction "notify"  Notify
 102     ]
 103   where
 104     requestAction = do
 105       skipSpaces
 106       identifier <- manyTill (satisfy isAlphaNum) (skipSpaces >> char ':')
 107       skipSpaces
 108       sendAction "request" (Request identifier)
 109
 110 openAction :: ReadP Action
 111 openAction = do
 112   skipSpaces
 113   string "open"
 114   space
 115   fp <- strLiteral
 116   space
 117   OpenDoc fp <$> strLiteral
 118
 119 sendAction :: String -> (String -> MessageParam -> Action) -> ReadP Action
 120 sendAction keyword con = do
 121   skipSpaces
 122   string keyword
 123   skipSpaces
 124   method <- strLiteral
 125   skipSpaces
 126   con method <$> messageParam
 127
 128 messageParam :: ReadP MessageParam
 129 messageParam = choice [uriParam, stringParam, objParam]
 130   where
 131     uriParam = do
 132       skipSpaces
 133       string "uri"
 134       skipSpaces
 135       fp <- strLiteral
 136       skipSpaces
 137       return (ParamUri fp)
 138
 139     stringParam = ParamString . T.pack <$> strLiteral
 140
 141     objParam = do
 142       props <- between (char '{') (char '}') (some parseProp)
 143       return (ParamObject (HM.fromList props))
 144
 145     parseProp = do
 146       skipSpaces
 147       name <- many (satisfy (\x -> (x /= ':') && isAlphaNum x))
 148       char ':'
 149       skipSpaces
 150       param <- messageParam
 151       skipSpaces
 152       return (T.pack name, param)
 153
 154 parseScript :: String -> [Block]
 155 parseScript str =
 156   case readP_to_S parser str of
 157     [] -> error "Couldn't parse"
 158     xs -> fst $ last xs
 159   where
 160     parser = do
 161       blocks <- some block
 162       skipSpaces
 163       eof
 164       return blocks