Merge branch 'master' into script-fsm script-fsm
authorLuke Lau <luke_lau@icloud.com>
Thu, 12 Jul 2018 18:56:31 +0000 (19:56 +0100)
committerLuke Lau <luke_lau@icloud.com>
Thu, 12 Jul 2018 18:56:31 +0000 (19:56 +0100)
1  2 
haskell-lsp-test.cabal
lib/Language/Haskell/LSP/Test.hs
lib/Language/Haskell/LSP/Test/Machine.hs
lib/Language/Haskell/LSP/Test/Replay.hs
src/Language/Haskell/LSP/Test/Parsing.hs

diff --combined haskell-lsp-test.cabal
index c5d1391eca38a99d3546c5ef407c06eaf5f564a0,860c29b59057ea387e9e11c6eb22b647271da9d1..6fba8f24d253b3e26a027ad083bd6e5ded67770b
@@@ -1,60 -1,32 +1,63 @@@
  name:                haskell-lsp-test
  version:             0.1.0.0
- -- synopsis:
+ synopsis:            Functional test framework for LSP servers.
  -- description:
  homepage:            https://github.com/Bubba/haskell-lsp-test#readme
  license:             BSD3
  license-file:        LICENSE
  author:              Luke Lau
  maintainer:          luke_lau@icloud.com
+ stability:           experimental
+ bug-reports:         https://github.com/Bubba/haskell-lsp-test/issues
  copyright:           2018 Luke Lau
  category:            Testing
  build-type:          Simple
 -cabal-version:       >=1.10
 +cabal-version:       >=2.0
  extra-source-files:  README.md
  
  library
 -  hs-source-dirs:      src
 +  hs-source-dirs:      lib
    exposed-modules:     Language.Haskell.LSP.Test
                       , Language.Haskell.LSP.Test.Replay
 +                     , Language.Haskell.LSP.Test.Machine
+   reexported-modules:  haskell-lsp:Language.Haskell.LSP.Types
+                      , haskell-lsp:Language.Haskell.LSP.Types.Capabilities
+                      , parser-combinators:Control.Applicative.Combinators
    default-language:    Haskell2010
    build-depends:       base >= 4.7 && < 5
-                      , haskell-lsp >= 0.3
 +                     , haskell-lsp-types
-   ghc-options:         -W
+                      , haskell-lsp >= 0.4
 +                     , haskell-lsp-test-internal
 +                     , aeson
 +                     , bytestring
 +                     , containers
 +                     , data-default
 +                     , directory
 +                     , filepath
 +                     , lens
 +                     , parser-combinators
 +                     , text
 +                     , unordered-containers
 +                     , yi-rope
 +
 +library haskell-lsp-test-internal
 +  hs-source-dirs:      src
 +  default-language:    Haskell2010
 +  exposed-modules:     Language.Haskell.LSP.Test.Compat
 +                       Language.Haskell.LSP.Test.Decoding
 +                       Language.Haskell.LSP.Test.Exceptions
 +                       Language.Haskell.LSP.Test.Files
 +                       Language.Haskell.LSP.Test.Messages
 +                       Language.Haskell.LSP.Test.Parsing
 +                       Language.Haskell.LSP.Test.Script
 +                       Language.Haskell.LSP.Test.Server
 +                       Language.Haskell.LSP.Test.Session
 +  build-depends:       base
 +                     , haskell-lsp-types
 +                     , haskell-lsp >= 0.3
                       , aeson
                       , ansi-terminal
 +                     , async
                       , bytestring
                       , conduit
                       , conduit-parse
@@@ -64,7 -36,6 +67,7 @@@
                       , filepath
                       , lens
                       , mtl
 +                     , scientific
                       , parser-combinators
                       , process
                       , text
      build-depends:     Win32
    else
      build-depends:     unix
 -  other-modules:       Language.Haskell.LSP.Test.Compat
 -                       Language.Haskell.LSP.Test.Decoding
 -                       Language.Haskell.LSP.Test.Exceptions
 -                       Language.Haskell.LSP.Test.Files
 -                       Language.Haskell.LSP.Test.Messages
 -                       Language.Haskell.LSP.Test.Parsing
 -                       Language.Haskell.LSP.Test.Server
 -                       Language.Haskell.LSP.Test.Session
    ghc-options:         -W
  
 +executable lsp-test
 +  hs-source-dirs:     lsp-test
 +  main-is:            Main.hs
 +  default-language:   Haskell2010
 +  build-depends:      base >= 4.7 && < 5
 +                    , haskell-lsp-types
-                     , haskell-lsp >= 0.3
++                    , haskell-lsp >= 0.4
 +                    , haskell-lsp-test-internal
 +                    , haskell-lsp-test
 +                    , aeson
 +                    , bytestring
 +                    , directory
 +                    , filepath
 +                    , text
 +                    , unordered-containers
 +                    , scientific
 +
  test-suite tests
    type:                exitcode-stdio-1.0
    main-is:             Test.hs
                       , hspec
                       , lens
                       , data-default
-                      , directory
+                      , haskell-lsp >= 0.4
                       , haskell-lsp-test
-                      , haskell-lsp-test-internal
-                      , haskell-lsp
-                      , haskell-lsp-types
-                      , conduit
-                      , conduit-parse
                       , aeson
                       , unordered-containers
                       , text
@@@ -122,7 -78,3 +119,3 @@@ executable lsp-test-exampl
    default-language:    Haskell2010
    build-depends:       base >= 4.7 && < 5
                       , haskell-lsp-test
-                      , haskell-lsp-types
-                      , lens
-                      , text
-                      , directory
index eda3cd2f2925bd34fdef4014482d4c8eef2a6133,c5090f939c8c669f44e65a5d04d698d2bb7a6350..c5090f939c8c669f44e65a5d04d698d2bb7a6350
@@@ -39,25 -39,6 +39,6 @@@ module Language.Haskell.LSP.Tes
    , loggingNotification
    , publishDiagnosticsNotification
    -- * Combinators
-   , choice
-   , option
-   , optional
-   , between
-   , some
-   , many
-   , sepBy
-   , sepBy1
-   , sepEndBy1
-   , sepEndBy
-   , endBy1
-   , endBy
-   , count
-   , manyTill
-   , skipMany
-   , skipSome
-   , skipManyTill
-   , skipSomeTill
-   , (<|>)
    , satisfy
    -- * Utilities
    , initializeResponse
    , documentContents
    , getDocumentEdit
    , getDocUri
+   , getVersionedDoc
    -- ** Symbols
    , getDocumentSymbols
    -- ** Diagnostics
    , waitForDiagnostics
+   , waitForDiagnosticsSource
    , noDiagnostics
    -- ** Commands
    , executeCommand
    -- ** Code Actions
    , getAllCodeActions
    , executeCodeAction
+   -- ** Completions
+   , getCompletions
+   -- ** References
+   , getReferences
+   -- ** Renaming
+   , rename
+   -- ** Edits
+   , applyEdit
    ) where
  
- import Control.Applicative
  import Control.Applicative.Combinators
  import Control.Concurrent
  import Control.Monad
@@@ -94,6 -84,7 +84,7 @@@ import qualified Data.Map as Ma
  import Data.Maybe
  import Language.Haskell.LSP.Types hiding (id, capabilities, message)
  import qualified Language.Haskell.LSP.Types as LSP
+ import qualified Language.Haskell.LSP.Types.Capabilities as LSP
  import Language.Haskell.LSP.Messages
  import Language.Haskell.LSP.VFS
  import Language.Haskell.LSP.Test.Compat
@@@ -177,7 -168,7 +168,7 @@@ getDocumentEdit doc = d
    req <- message :: Session ApplyWorkspaceEditRequest
  
    unless (checkDocumentChanges req || checkChanges req) $
-     liftIO $ throw (IncorrectApplyEditRequestException (show req))
+     liftIO $ throw (IncorrectApplyEditRequest (show req))
  
    documentContents doc
    where
@@@ -313,19 -304,31 +304,31 @@@ getDocUri file = d
    let fp = rootDir context </> file
    return $ filePathToUri fp
  
+ -- | Waits for diagnostics to be published and returns them.
  waitForDiagnostics :: Session [Diagnostic]
  waitForDiagnostics = do
    diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
    let (List diags) = diagsNot ^. params . LSP.diagnostics
    return diags
  
+ waitForDiagnosticsSource :: String -> Session [Diagnostic]
+ waitForDiagnosticsSource src = do
+   diags <- waitForDiagnostics
+   let res = filter matches diags
+   if null res
+     then waitForDiagnosticsSource src
+     else return res
+   where
+     matches :: Diagnostic -> Bool
+     matches d = d ^. source == Just (T.pack src)
  -- | Expects a 'PublishDiagnosticsNotification' and throws an
  -- 'UnexpectedDiagnosticsException' if there are any diagnostics
  -- returned.
  noDiagnostics :: Session ()
  noDiagnostics = do
    diagsNot <- message :: Session PublishDiagnosticsNotification
-   when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
+   when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
  
  -- | Returns the symbols in a document.
  getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
@@@ -335,6 -338,9 +338,9 @@@ getDocumentSymbols doc = d
    let (Just (List symbols)) = mRes
    return symbols
  
+ -- | Returns all the code actions in a document by 
+ -- querying the code actions at each of the current 
+ -- diagnostics' positions.
  getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
  getAllCodeActions doc = do
    curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
            let Just (List cmdOrCAs) = mRes
              in return (acc ++ cmdOrCAs)
  
+ -- | Executes a command.
  executeCommand :: Command -> Session ()
  executeCommand cmd = do
    let args = decode $ encode $ fromJust $ cmd ^. arguments
        execParams = ExecuteCommandParams (cmd ^. command) args
    sendRequest_ WorkspaceExecuteCommand execParams
  
+ -- | Executes a code action. 
+ -- Matching with the specification, if a code action
+ -- contains both an edit and a command, the edit will
+ -- be applied first.
  executeCodeAction :: CodeAction -> Session ()
  executeCodeAction action = do
    maybe (return ()) handleEdit $ action ^. edit
  
    where handleEdit :: WorkspaceEdit -> Session ()
          handleEdit e =
+           -- Its ok to pass in dummy parameters here as they aren't used
            let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
              in updateState (ReqApplyWorkspaceEdit req)
+ -- | Adds the current version to the document, as tracked by the session.
+ getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
+ getVersionedDoc (TextDocumentIdentifier uri) = do
+   fs <- vfs <$> get
+   let ver =
+         case fs Map.!? uri of
+           Just (VirtualFile v _) -> Just v
+           _ -> Nothing
+   return (VersionedTextDocumentIdentifier uri ver)
+ -- | Applys an edit to the document and returns the updated document version.
+ applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
+ applyEdit doc edit = do
+   verDoc <- getVersionedDoc doc
+   caps <- asks (capabilities . config)
+   let supportsDocChanges = fromMaybe False $ do
+         let LSP.ClientCapabilities mWorkspace _ _ = caps
+         LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
+         LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
+         mDocChanges
+   let wEdit = if supportsDocChanges
+       then
+         let docEdit = TextDocumentEdit verDoc (List [edit])
+         in WorkspaceEdit Nothing (Just (List [docEdit]))
+       else
+         let changes = HashMap.singleton (doc ^. uri) (List [edit])
+         in WorkspaceEdit (Just changes) Nothing
+   let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
+   updateState (ReqApplyWorkspaceEdit req)
+   -- version may have changed
+   getVersionedDoc doc
+   
+ -- | Returns the completions for the position in the document.
+ getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
+ getCompletions doc pos = do
+   rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos)
+   case getResponseResult rsp of
+     Completions (List items) -> return items
+     CompletionList (CompletionListType _ (List items)) -> return items
+ -- | Returns the references for the position in the document.
+ getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
+               -> Position -- ^ The position to lookup. 
+               -> Bool -- ^ Whether to include declarations as references.
+               -> Session [Location] -- ^ The locations of the references.
+ getReferences doc pos inclDecl =
+   let ctx = ReferenceContext inclDecl
+       params = ReferenceParams doc pos ctx
+   in fromMaybe [] . (^. result) <$> sendRequest TextDocumentReferences params 
+ -- ^ Renames the term at the specified position.
+ rename :: TextDocumentIdentifier -> Position -> String -> Session ()
+ rename doc pos newName = do
+   let params = RenameParams doc pos (T.pack newName)
+   rsp <- sendRequest TextDocumentRename params :: Session RenameResponse
+   let wEdit = getResponseResult rsp
+       req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
+   updateState (ReqApplyWorkspaceEdit req)
+ -- | Checks the response for errors and throws an exception if needed.
+ -- Returns the result if successful.
+ getResponseResult :: ResponseMessage a -> a 
+ getResponseResult rsp = fromMaybe exc (rsp ^. result)
+   where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
+                                               (fromJust $ rsp ^. LSP.error)
index 7e0a78d247a41838014a7e099245480d4242a35e,0000000000000000000000000000000000000000..2f513c498fc9724a3783cd33f0cece35a38b7fa7
mode 100644,000000..100644
--- /dev/null
@@@ -1,37 -1,0 +1,36 @@@
- {-# LANGUAGE OverloadedStrings #-}
 +module Language.Haskell.LSP.Test.Machine where
 +
 +import Control.Monad.IO.Class
 +import Language.Haskell.LSP.Messages
 +import Language.Haskell.LSP.Test
 +
 +data State = State String (FromServerMessage -> Bool) [Session ()] State
 +           | Passed
 +           | Failed
 +
- data Event = Timeout | Received FromServerMessage
++data Event = TimeoutEvent | Received FromServerMessage
 +
 +advance :: State -> Event -> Session State
- advance _ Timeout = return Failed
++advance _ TimeoutEvent = return Failed
 +advance s@(State name f actions next) (Received msg)
 +  | f msg = do
 +    liftIO $ putStrLn name
 +    sequence_ actions
 +    return next
 +  | otherwise = return s
 +advance s _ = return s
 +
 +mkStates [] = Passed
 +mkStates ((n, f, msgs):xs) = State n f msgs (mkStates xs)
 +
 +runMachine :: String -> FilePath -> [(String, FromServerMessage -> Bool, [Session ()])] -> IO Bool
 +runMachine cmd rootDir encodedStates =
 +  runSession cmd rootDir $ do
 +    let f Passed = return Passed
 +        f s = Received <$> anyMessage >>= advance s >>= f
 +        initState = mkStates encodedStates
 +    res <- f initState
 +    case res of
 +      Passed -> return True
 +      _ -> return False
 +
index b224be6cbf0132a6e50b6bc0380edd453ac94e2d,979b789149262c6947e195c58122310ef8a6d5cc..979b789149262c6947e195c58122310ef8a6d5cc
@@@ -145,7 -145,7 +145,7 @@@ listenServer expectedMsgs reqMap reqSem
        then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
        else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
                  ++ [head $ dropWhile isNotification expectedMsgs]
-                exc = ReplayOutOfOrderException msg remainingMsgs
+                exc = ReplayOutOfOrder msg remainingMsgs
              in liftIO $ throwTo mainThreadId exc
  
    where
index 88109a5155801e2ed3015861c019ee4fd93217d6,36349dae864f4fbd63aa82c6016d87da1bd52084..1d7f38e56e564104a4157f387ba9fea4d4350e3a
@@@ -53,9 -53,8 +53,8 @@@ satisfy pred = d
  message :: forall a. (Typeable a, FromJSON a) => Session a
  message =
    let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
-   in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $ do
-     x <- satisfy (isJust . parser)
-     return $ castMsg x
+   in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $
+     castMsg <$> satisfy (isJust . parser)
  
  -- | Matches if the message is a notification.
  anyNotification :: Session FromServerMessage
@@@ -85,10 -84,7 +84,10 @@@ castMsg = fromMaybe (error "Failed cast
  -- | A version of encode that encodes FromServerMessages as if they
  -- weren't wrapped.
  encodeMsg :: FromServerMessage -> B.ByteString
 -encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
 +encodeMsg = encode . toJSONMsg
 +
 +toJSONMsg :: FromServerMessage -> Value
 +toJSONMsg = genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
  
  -- | Matches if the message is a log message notification or a show message notification/request.
  loggingNotification :: Session FromServerMessage