3 import Control.Applicative ( (<|>), some )
7 import qualified Data.Text as T
8 import qualified Data.HashMap.Lazy as HM
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
24 data Block = Block String Wait [Action]
27 data Wait = WaitPred [Predicate]
31 data Predicate = Predicate Accessor Comparison
34 data Accessor = AccessorTerm String
35 | Accessor String Accessor
38 data Comparison = EqualsNumber Scientific
40 | ContainsString String
43 data Action = OpenDoc FilePath String
44 | Request String Method MessageParam
45 | Reply Method MessageParam
46 | Notify Method MessageParam
51 data MessageParam = ParamObject (HM.HashMap T.Text MessageParam)
56 -- | Parse a string literal like "foo".
57 strLiteral :: ReadP String
58 strLiteral = between (char '"') (char '"') (many (satisfy (/= '"')))
60 -- | Parse mandatory whitespace, including newlines
62 space = void $ some (satisfy isSpace)
69 between (char '{') (char '}') $ do
72 actions <- option [] $ do
78 return $ Block name w actions
85 where f = string "any" >> return WaitAny
86 g = WaitPred <$> some predicate
88 predicate :: ReadP Predicate
91 Predicate x <$> comparison
93 accessor :: ReadP Accessor
95 x:xs <- reverse <$> sepBy1 property (char '.')
96 return $ foldl (flip Accessor) (AccessorTerm x) xs
97 where property = many (satisfy isAlphaNum)
99 comparison :: ReadP Comparison
102 operator <- string "==" <|> string "is in"
104 choice [eqString, eqNumber]
105 -- todo: contains string
106 where eqString = EqualsString <$> strLiteral
107 eqNumber = EqualsNumber . read <$> some (satisfy isNumber)
109 action :: ReadP Action
113 , sendAction "reply" Reply
114 , sendAction "notify" Notify
119 identifier <- manyTill (satisfy isAlphaNum) (skipSpaces >> char ':')
121 sendAction "request" (Request identifier)
123 openAction :: ReadP Action
130 OpenDoc fp <$> strLiteral
132 sendAction :: String -> (String -> MessageParam -> Action) -> ReadP Action
133 sendAction keyword con = do
139 con method <$> messageParam
141 messageParam :: ReadP MessageParam
142 messageParam = choice [uriParam, stringParam, objParam]
152 stringParam = ParamString . T.pack <$> strLiteral
155 props <- between (char '{') (char '}') (some parseProp)
156 return (ParamObject (HM.fromList props))
160 name <- many (satisfy (\x -> (x /= ':') && isAlphaNum x))
163 param <- messageParam
165 return (T.pack name, param)
167 parseScript :: String -> [Block]
169 case readP_to_S parser str of
170 [] -> error "Couldn't parse"
180 fileName <- head <$> getArgs
181 blocks <- parseScript <$> readFile fileName
183 rootDir <- getCurrentDirectory
184 runBlocks rootDir blocks
187 runBlocks :: FilePath -> [Block] -> IO ()
188 runBlocks rootDir blocks = runMachine rootDir (map convertBlock blocks) >>= putStrLn
190 convertBlock :: Block -> (String, FromServerMessage -> Bool, [Session ()])
191 convertBlock (Block name w actions) = (name, mkWait w, map mkAction actions)
193 mkWait :: Wait -> FromServerMessage -> Bool
194 mkWait WaitAny _ = True
195 mkWait (WaitPred preds) x = all (`mkPred` x) preds
197 mkPred :: Predicate -> (FromServerMessage -> Bool)
198 mkPred (Predicate accessor comparison) msg =
199 let (Object obj) = toJSONMsg msg in comp (access obj accessor) comparison
201 comp (Just (String str)) (EqualsString expected) = str == T.pack expected
202 comp (Just (Number num)) (EqualsNumber expected) = num == expected
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
212 mkAction :: Action -> Session ()
214 mkAction (OpenDoc fp fileType) = void $ openDoc fp fileType
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)
220 strToMethod str = case fromJSON (String $ T.pack str) of
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)