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

   1 module Main where
   2
   3 import Control.Applicative ( (<|>), some )
   4 import Control.Monad
   5 import Data.Aeson
   6 import Data.Char
   7 import qualified Data.Text as T
   8 import qualified Data.HashMap.Lazy as HM
   9 import Data.Maybe
  10 import Data.Scientific
  11 import Text.ParserCombinators.ReadP
  12 import System.Environment
  13 import System.FilePath
  14 import System.Directory
  15 import Language.Haskell.LSP.Test (openDoc, sendRequest', sendNotification, sendResponse)
  16 import Language.Haskell.LSP.Test.Session
  17 import Language.Haskell.LSP.Test.Machine
  18 import Language.Haskell.LSP.Test.Parsing (toJSONMsg)
  19 import Language.Haskell.LSP.Messages
  20 import Language.Haskell.LSP.TH.MessageFuncs
  21 import qualified Language.Haskell.LSP.Types as LSP
  22 import Debug.Trace
  23
  24 data Block = Block String Wait [Action]
  25   deriving Show
  26
  27 data Wait = WaitPred [Predicate]
  28           | WaitAny
  29   deriving Show
  30
  31 data Predicate = Predicate Accessor Comparison
  32   deriving Show
  33
  34 data Accessor = AccessorTerm String
  35               | Accessor String Accessor
  36   deriving Show
  37
  38 data Comparison = EqualsNumber Scientific
  39                 | EqualsString String
  40                 | ContainsString String
  41   deriving Show
  42
  43 data Action = OpenDoc FilePath String
  44             | Request String Method MessageParam
  45             | Reply Method MessageParam
  46             | Notify Method MessageParam
  47   deriving Show
  48
  49 type Method = String
  50
  51 data MessageParam = ParamObject (HM.HashMap T.Text MessageParam)
  52                   | ParamString T.Text
  53                   | ParamUri FilePath
  54   deriving Show
  55
  56 -- | Parse a string literal like "foo".
  57 strLiteral :: ReadP String
  58 strLiteral = between (char '"') (char '"') (many (satisfy (/= '"')))
  59
  60 -- | Parse mandatory whitespace, including newlines
  61 space :: ReadP ()
  62 space = void $ some (satisfy isSpace)
  63
  64 block :: ReadP Block
  65 block = do
  66   skipSpaces
  67   name <- strLiteral
  68   skipSpaces
  69   between (char '{') (char '}') $ do
  70     skipSpaces
  71     w <- wait
  72     actions <- option [] $ do
  73       space
  74       string "then"
  75       space
  76       action `sepBy1` space
  77     skipSpaces
  78     return $ Block name w actions
  79
  80 wait :: ReadP Wait
  81 wait = do
  82   string "wait for"
  83   space
  84   f <|> g
  85   where f = string "any" >> return WaitAny
  86         g = WaitPred <$> some predicate
  87
  88 predicate :: ReadP Predicate
  89 predicate = do
  90   x <- accessor
  91   Predicate x <$> comparison
  92
  93 accessor :: ReadP Accessor
  94 accessor = do
  95   x:xs <- reverse <$> sepBy1 property (char '.')
  96   return $ foldl (flip Accessor) (AccessorTerm x) xs
  97   where property = many (satisfy isAlphaNum)
  98
  99 comparison :: ReadP Comparison
 100 comparison = do
 101   space
 102   operator <- string "==" <|> string "is in"
 103   space
 104   choice [eqString, eqNumber]
 105   -- todo: contains string
 106   where eqString = EqualsString <$> strLiteral
 107         eqNumber = EqualsNumber . read <$> some (satisfy isNumber)
 108
 109 action :: ReadP Action
 110 action = choice
 111     [ openAction
 112     , requestAction
 113     , sendAction "reply"   Reply
 114     , sendAction "notify"  Notify
 115     ]
 116   where
 117     requestAction = do
 118       skipSpaces
 119       identifier <- manyTill (satisfy isAlphaNum) (skipSpaces >> char ':')
 120       skipSpaces
 121       sendAction "request" (Request identifier)
 122
 123 openAction :: ReadP Action
 124 openAction = do
 125   skipSpaces
 126   string "open"
 127   space
 128   fp <- strLiteral
 129   space
 130   OpenDoc fp <$> strLiteral
 131
 132 sendAction :: String -> (String -> MessageParam -> Action) -> ReadP Action
 133 sendAction keyword con = do
 134   skipSpaces
 135   string keyword
 136   skipSpaces
 137   method <- strLiteral
 138   skipSpaces
 139   con method <$> messageParam
 140
 141 messageParam :: ReadP MessageParam
 142 messageParam = choice [uriParam, stringParam, objParam]
 143   where
 144     uriParam = do
 145       skipSpaces
 146       string "uri"
 147       skipSpaces
 148       fp <- strLiteral
 149       skipSpaces
 150       return (ParamUri fp)
 151
 152     stringParam = ParamString . T.pack <$> strLiteral
 153
 154     objParam = do
 155       props <- between (char '{') (char '}') (some parseProp)
 156       return (ParamObject (HM.fromList props))
 157
 158     parseProp = do
 159       skipSpaces
 160       name <- many (satisfy (\x -> (x /= ':') && isAlphaNum x))
 161       char ':'
 162       skipSpaces
 163       param <- messageParam
 164       skipSpaces
 165       return (T.pack name, param)
 166
 167 parseScript :: String -> [Block]
 168 parseScript str =
 169   case readP_to_S parser str of
 170     [] -> error "Couldn't parse"
 171     xs -> fst $ last xs
 172   where
 173     parser = do
 174       blocks <- some block
 175       skipSpaces
 176       eof
 177       return blocks
 178
 179 main = do
 180   fileName <- head <$> getArgs
 181   blocks <- parseScript <$> readFile fileName
 182   print blocks
 183   rootDir <- getCurrentDirectory
 184   runBlocks rootDir blocks
 185
 186
 187 runBlocks :: FilePath -> [Block] -> IO ()
 188 runBlocks rootDir blocks = runMachine rootDir (map convertBlock blocks) >>= putStrLn
 189   where
 190     convertBlock :: Block -> (String, FromServerMessage -> Bool, [Session ()])
 191     convertBlock (Block name w actions) = (name, mkWait w, map mkAction actions)
 192
 193     mkWait :: Wait -> FromServerMessage -> Bool
 194     mkWait WaitAny _ = True
 195     mkWait (WaitPred preds) x = all (`mkPred` x) preds
 196
 197     mkPred :: Predicate -> (FromServerMessage -> Bool)
 198     mkPred (Predicate accessor comparison) msg =
 199       let (Object obj) = toJSONMsg msg in comp (access obj accessor) comparison
 200
 201     comp (Just (String str)) (EqualsString expected) = str == T.pack expected
 202     comp (Just (Number num)) (EqualsNumber expected) = num == expected
 203     comp _ _ = False
 204
 205     access :: Object -> Accessor -> Maybe Value
 206     access obj (AccessorTerm prop) = traceShowId $ HM.lookup (T.pack prop) obj
 207     access obj (Accessor prop next) =
 208       case HM.lookup (T.pack prop) obj of
 209         Just (Object nextObj) -> access nextObj next
 210         _ -> Nothing
 211
 212     mkAction :: Action -> Session ()
 213
 214     mkAction (OpenDoc fp fileType) = void $ openDoc fp fileType
 215
 216     mkAction (Request identifier methodStr ps) = void $ sendRequest' (strToMethod methodStr) (paramToValue ps)
 217     mkAction (Reply methodStr ps) = undefined -- TODO
 218     mkAction (Notify methodStr ps) = void $ sendNotification (strToMethod methodStr) (paramToValue ps)
 219
 220     strToMethod str = case fromJSON (String $ T.pack str) of
 221       Success x -> x
 222       Error _ -> error $ str ++ " is not a valid method"
 223     paramToValue (ParamString str) = String str
 224     paramToValue (ParamUri uri)    = toJSON $ LSP.filePathToUri (rootDir </> uri)
 225     paramToValue (ParamObject obj) = Object (HM.map paramToValue obj)