lsp-test/Main.hs

   1 module Main where
   2
   3 import           Control.Monad
   4 import           Data.Aeson
   5 import qualified Data.Text                     as T
   6 import qualified Data.HashMap.Lazy             as HM
   7 import           Language.Haskell.LSP.Test
   8 import           Language.Haskell.LSP.Test.Script
   9 import           System.Environment
  10 import           System.FilePath
  11 import           System.Directory
  12 import           System.Exit
  13 import           Language.Haskell.LSP.Test.Machine
  14 import           Language.Haskell.LSP.Test.Parsing
  15                                                 ( toJSONMsg )
  16 import           Language.Haskell.LSP.Test.Replay
  17 import           Language.Haskell.LSP.Messages
  18 import qualified Language.Haskell.LSP.Types    as LSP
  19
  20 main = do
  21   args <- getArgs
  22   curDir <- getCurrentDirectory
  23   case args of
  24     ["replay", cmd] -> replaySession cmd curDir
  25     [file, cmd] -> do
  26       blocks <- parseScript <$> readFile file
  27       success <- runBlocks cmd curDir blocks
  28       if success
  29         then putStrLn "Success ✅"
  30         else putStrLn "Failed ❌" >> exitFailure
  31     _ -> putStrLn "usage: lsp-test (replay <cmd>)|(<file> <cmd>)"
  32
  33 runBlocks :: String -> FilePath -> [Block] -> IO Bool
  34 runBlocks cmd rootDir blocks = runMachine cmd rootDir (map convertBlock blocks)
  35   where
  36     convertBlock :: Block -> (String, FromServerMessage -> Bool, [Session ()])
  37     convertBlock (Block name w actions) = (name, mkWait w, map mkAction actions)
  38
  39     mkWait :: Wait -> FromServerMessage -> Bool
  40     mkWait WaitAny _ = True
  41     mkWait (WaitPred preds) x = all (`mkPred` x) preds
  42
  43     mkPred :: Predicate -> (FromServerMessage -> Bool)
  44     mkPred (Predicate accessor comparison) msg =
  45       let (Object obj) = toJSONMsg msg in comp (access obj accessor) comparison
  46
  47     comp (Just (String str)) (EqualsString expected) = str == T.pack expected
  48     comp (Just (Number num)) (EqualsNumber expected) = num == expected
  49     comp _ _ = False
  50
  51     access :: Object -> Accessor -> Maybe Value
  52     access obj (AccessorTerm prop) = HM.lookup (T.pack prop) obj
  53     access obj (Accessor prop next) =
  54       case HM.lookup (T.pack prop) obj of
  55         Just (Object nextObj) -> access nextObj next
  56         _ -> Nothing
  57
  58     mkAction :: Action -> Session ()
  59
  60     mkAction (OpenDoc fp fileType) = void $ openDoc fp fileType
  61
  62     mkAction (Request identifier methodStr ps) = void $ sendRequest' (strToMethod methodStr) (paramToValue ps)
  63     mkAction (Reply methodStr ps) = undefined -- TODO
  64     mkAction (Notify methodStr ps) = void $ sendNotification (strToMethod methodStr) (paramToValue ps)
  65
  66     strToMethod str = case fromJSON (String $ T.pack str) of
  67       Success x -> x
  68       Error _ -> error $ str ++ " is not a valid method"
  69     paramToValue (ParamString str) = String str
  70     paramToValue (ParamUri uri)    = toJSON $ LSP.filePathToUri (rootDir </> uri)
  71     paramToValue (ParamObject obj) = Object (HM.map paramToValue obj)