haskell/haskell-ide-engine
1
1
Fork 0
mirror of https://github.com/haskell/haskell-ide-engine.git synced 2024-09-19 14:57:47 +03:00
Code Issues Projects Releases Wiki Activity

WIP on deferred functional tests

Browse Source 
For some reason we are getting the result from req 0, when it should
be from req 3
This commit is contained in:
Alan Zimmerman 2018-05-26 19:07:44 +02:00
parent 08cb53ef38
commit c1f3b35a86
8 changed files with 134 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cabal.project
View File

@ -7,5 +7,7 @@ packages:
./submodules/ghc-mod/
./submodules/ghc-mod//core/
./submodules/yi-rope/
./submodules/haskell-lsp/
./submodules/haskell-lsp/haskell-lsp-types

2
hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs
View File

@ -98,7 +98,7 @@ isCached uri = do
mc <- getCachedModule uri
case mc of
ModuleCached _ _ -> return True
_ -> return False
_ -> return False
-- | Version of `withCachedModuleAndData` that doesn't provide
-- any extra cached data

12
src/Haskell/Ide/Engine/Dispatcher.hs
View File

@ -105,14 +105,14 @@ ghcDispatcher :: forall void m. DispatcherEnv -> ErrorHandler -> CallbackHandler
ghcDispatcher env@DispatcherEnv{docVersionTVar} errorHandler callbackHandler pin = forever $ do
debugm "ghcDispatcher: top of loop"
(GhcRequest context mver mid callback action) <- liftIO $ atomically $ readTChan pin
debugm $ "got request with id: " ++ show mid
debugm $ "ghcDispatcher:got request with id: " ++ show mid
let runner = case context of
Nothing -> runActionWithContext Nothing
Just uri -> case uriToFilePath uri of
Just fp -> runActionWithContext (Just fp)
Nothing -> \act -> do
debugm "Got malformed uri, running action with default context"
debugm "ghcDispatcher:Got malformed uri, running action with default context"
runActionWithContext Nothing act
let runWithCallback = do
@ -122,16 +122,16 @@ ghcDispatcher env@DispatcherEnv{docVersionTVar} errorHandler callbackHandler pin
IdeResultFail err ->
case mid of
Just lid -> errorHandler lid J.InternalError (show err)
Nothing -> debugm $ "Got error for a request: " ++ show err
Nothing -> debugm $ "ghcDispatcher:Got error for a request: " ++ show err
let runIfVersionMatch = case mver of
Nothing -> runWithCallback
Just (uri, reqver) -> do
curver <- liftIO $ atomically $ Map.lookup uri <$> readTVar docVersionTVar
if Just reqver /= curver then
debugm "not processing request as it is for old version"
debugm "ghcDispatcher:not processing request as it is for old version"
else do
debugm "Processing request as version matches"
debugm "ghcDispatcher:Processing request as version matches"
runWithCallback
case mid of
@ -153,4 +153,4 @@ checkCancelled env lid errorHandler callback = do
where isCancelled = S.member lid <$> readTVar (cancelReqsTVar env)
completedReq :: DispatcherEnv -> J.LspId -> IO ()
completedReq env lid = atomically $ modifyTVar' (wipReqsTVar env) (S.delete lid)
completedReq env lid = atomically $ modifyTVar' (wipReqsTVar env) (S.delete lid)

12
src/Haskell/Ide/Engine/Types.hs
View File

@ -16,14 +16,14 @@ type RequestCallback m a = a -> m ()
-- | Requests are parametric in the monad m
-- that their callback expects to be in.
pattern GReq :: Maybe Uri
-> Maybe (Uri, Int)
-> Maybe J.LspId
-> RequestCallback m a1
-> IdeGhcM (IdeResult a1)
-> PluginRequest m
-> Maybe (Uri, Int)
-> Maybe J.LspId
-> RequestCallback m a1
-> IdeGhcM (IdeResult a1)
-> PluginRequest m
pattern GReq a b c d e = Right (GhcRequest a b c d e)
pattern IReq :: J.LspId -> (RequestCallback m a) -> IdeM (IdeResponse a) -> Either (IdeRequest m) b
pattern IReq :: J.LspId -> RequestCallback m a -> IdeM (IdeResponse a) -> Either (IdeRequest m) b
pattern IReq a b c = Left (IdeRequest a b c)
type PluginRequest m = Either (IdeRequest m) (GhcRequest m)

2
stack.yaml
View File

@ -26,7 +26,7 @@ packages:
./submodules/haskell-lsp
extra-dep: true
subdirs:
- .
- .
- haskell-lsp-types
extra-deps:

186
test/Functional.hs
View File

@ -1,6 +1,7 @@
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
@ -9,6 +10,7 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-
Start up an actual instance of the HIE server, and interact with it.
@ -24,11 +26,15 @@ import Control.Concurrent
import Control.Concurrent.STM.TChan
import Control.Concurrent.STM.TVar
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.STM
import Data.Aeson
import qualified Data.HashMap.Strict as H
import qualified Data.Map as Map
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Typeable
import GHC.Generics
import Haskell.Ide.Engine.Dispatcher
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginDescriptor
@ -61,12 +67,12 @@ plugins = pluginDescToIdePlugins
,("ghcmod" , ghcmodDescriptor)
,("hare" , hareDescriptor)
,("base" , baseDescriptor)
,("hieextras" , baseDescriptor)
]
startServer :: IO (TChan (PluginRequest IO))
startServer :: IO (TChan (PluginRequest IO),TChan LogVal)
startServer = do
cin <- atomically newTChan
cin <- atomically newTChan
logChan <- atomically newTChan
cancelTVar <- atomically $ newTVar S.empty
wipTVar <- atomically $ newTVar S.empty
@ -77,15 +83,53 @@ startServer = do
, docVersionTVar = versionTVar
}
void $ forkIO $ dispatcherP cin plugins testOptions dispatcherEnv (\_ _ _ -> error "received an error") (\g x -> g x)
return cin
void $ forkIO $ dispatcherP cin plugins testOptions dispatcherEnv
(\_ _ _ -> logToChan logChan ("received an error",Left ""))
(\g x -> g x)
return (cin,logChan)
-- ---------------------------------------------------------------------
type LogVal = (String,Either String DynamicJSON)
logToChan :: TChan LogVal -> LogVal -> IO ()
logToChan c t = atomically $ writeTChan c t
-- ---------------------------------------------------------------------
dispatchGhcRequest :: ToJSON a
=> String -> Int
-> TChan (PluginRequest IO) -> TChan LogVal
-> PluginId -> CommandName -> a -> IO ()
dispatchGhcRequest ctx n cin lc plugin com arg = do
let
logger :: RequestCallback IO DynamicJSON
logger x = logToChan lc (ctx, Right x)
let req = GReq Nothing Nothing (Just (IdInt n)) logger $
runPluginCommand plugin com (toJSON arg)
atomically $ writeTChan cin req
dispatchIdeRequest :: (Typeable a, ToJSON a)
=> String -> TChan (PluginRequest IO)
-> TChan LogVal -> LspId -> IdeM (IdeResponse a) -> IO ()
dispatchIdeRequest ctx cin lc lid f = do
let
logger :: (Typeable a, ToJSON a) => RequestCallback IO a
logger x = logToChan lc (ctx, Right (toDynJSON x))
let req = IReq lid logger f
atomically $ writeTChan cin req
-- ---------------------------------------------------------------------
main :: IO ()
main = do
setupStackFiles
withFileLogging "./test-functional.log" $ cdAndDo "./test/testdata" $ hspec spec
let logfile = "./test-functional.log"
exists <- doesFileExist logfile
when exists $ removeFile logfile
withFileLogging logfile $ cdAndDo "./test/testdata" $ hspec spec
spec :: Spec
spec = do
@ -94,45 +138,56 @@ spec = do
-- ---------------------------------------------------------------------
dispatchGhcRequest :: ToJSON a => TChan (PluginRequest IO) -> PluginId -> CommandName -> a -> IO DynamicJSON
dispatchGhcRequest cin plugin com arg = do
mv <- newEmptyMVar
let req = GReq Nothing Nothing Nothing (putMVar mv) $
runPluginCommand plugin com (toJSON arg)
atomically $ writeTChan cin req
takeMVar mv
data Cached = Cached | NotCached deriving (Show,Eq,Generic)
dispatchIdeRequest :: TChan (PluginRequest IO) -> LspId -> IdeM (IdeResponse a) -> IO a
dispatchIdeRequest cin lid f = do
mv <- newEmptyMVar
let req = IReq lid (putMVar mv) f
atomically $ writeTChan cin req
takeMVar mv
-- ---------------------------------------------------------------------
-- Don't care instances via GHC.Generic
instance FromJSON Cached where
instance ToJSON Cached where
functionalSpec :: Spec
functionalSpec = do
cin <- runIO startServer
(cin,logChan) <- runIO startServer
cwd <- runIO getCurrentDirectory
let testUri = filePathToUri $ cwd </> "FuncTest.hs"
let
logger :: (Typeable a, ToJSON a) => String -> RequestCallback IO a
logger ctx x = logToChan logChan (ctx, Right (toDynJSON x))
hreq idVal doc = IReq idVal (logger ("IReq " ++ (show idVal))) $ do
pluginGetFileResponse ("Req:" <> (T.pack $ show idVal)) doc $ \fp -> do
liftIO $ putStrLn $ "hreq:" ++ show idVal
cached <- isCached fp
if cached
then return (IdeResponseOk Cached)
else return (IdeResponseOk NotCached)
unpackRes (r,Right md) = (r, fromDynJSON md)
describe "consecutive plugin commands" $ do
it "defers responses until module is loaded" $ do
-- Returns immediately, no cached value
atomically $ writeTChan cin $ hreq (IdInt 0) testUri
hr1 <- atomically $ readTChan logChan
unpackRes hr1 `shouldBe` ("IReq IdInt 0",Just NotCached)
reqVar <- newEmptyMVar
let req = IReq (IdInt 0) (putMVar reqVar) $ getSymbols testUri
let req = IReq (IdInt 1) (logger "req1") $ getSymbols testUri
atomically $ writeTChan cin req
rrr <- atomically $ tryReadTChan logChan
(show rrr) `shouldBe` "Nothing"
-- need to typecheck the module to trigger deferred response
_ <- dispatchGhcRequest cin "ghcmod" "check" (toJSON testUri)
dispatchGhcRequest "req2" 2 cin logChan "ghcmod" "check" (toJSON testUri)
res <- takeMVar reqVar
("req1",Right res) <- atomically $ readTChan logChan
res
`shouldBe` [ SymbolInformation
let Just ss = fromDynJSON res :: Maybe [SymbolInformation]
head ss `shouldBe`
SymbolInformation
{ _name = "main"
, _kind = SkFunction
, _location = Location
@ -144,61 +199,26 @@ functionalSpec = do
}
, _containerName = Nothing
}
, SymbolInformation
{ _name = "foo"
, _kind = SkFunction
, _location = Location
{ _uri = testUri
, _range = Range
{ _start = Position {_line = 5, _character = 0}
, _end = Position {_line = 5, _character = 3}
}
}
, _containerName = Nothing
}
, SymbolInformation
{ _name = "bb"
, _kind = SkFunction
, _location = Location
{ _uri = testUri
, _range = Range
{ _start = Position {_line = 7, _character = 0}
, _end = Position {_line = 7, _character = 2}
}
}
, _containerName = Nothing
}
, SymbolInformation
{ _name = "baz"
, _kind = SkFunction
, _location = Location
{ _uri = testUri
, _range = Range
{ _start = Position {_line = 9, _character = 0}
, _end = Position {_line = 9, _character = 3}
}
}
, _containerName = Nothing
}
, SymbolInformation
{ _name = "f"
, _kind = SkFunction
, _location = Location
{ _uri = testUri
, _range = Range
{ _start = Position {_line = 12, _character = 0}
, _end = Position {_line = 12, _character = 1}
}
}
, _containerName = Nothing
}
]
-- pick up the diagnostics ...
("req2",Right res) <- atomically $ readTChan logChan
rrr <- atomically $ tryReadTChan logChan
(show rrr) `shouldBe` "Nothing"
-- Returns immediately, there is a cached value
atomically $ writeTChan cin $ hreq (IdInt 3) testUri
hr2 <- atomically $ readTChan logChan
unpackRes hr1 `shouldBe` ("IReq IdInt 3",Just Cached)
-- unpackRes hr1 `shouldBe` ("IReq IdInt 0",Just NotCached)
it "instantly responds to deferred requests if cache is available" $ do
-- deferred responses should return something now immediately
-- as long as the above test ran before
references <- dispatchIdeRequest cin (IdInt 1)
references <- dispatchIdeRequest "references" cin logChan (IdInt 4)
$ getReferencesInDoc testUri (Position 7 0)
"references" `shouldBe` "update"
{-
references
`shouldBe` [ DocumentHighlight
{ _range = Range
@ -243,10 +263,12 @@ functionalSpec = do
, _kind = Just HkRead
}
]
-}
it "returns hints as diagnostics" $ do
r1 <- dispatchGhcRequest cin "applyrefact" "lint" testUri
r1 <- dispatchGhcRequest "r1" 5 cin logChan "applyrefact" "lint" testUri
{-
fromDynJSON r1
`shouldBe` (Just $ PublishDiagnosticsParams
{ _uri = filePathToUri $ cwd </> "FuncTest.hs"
@ -261,9 +283,11 @@ functionalSpec = do
]
}
)
-}
let req3 = HP testUri (toPos (8, 1))
r3 <- dispatchGhcRequest cin "hare" "demote" req3
r3 <- dispatchGhcRequest "r3" 6 cin logChan "hare" "demote" req3
{-
fromDynJSON r3 `shouldBe` Just
(WorkspaceEdit
( Just
@ -275,4 +299,6 @@ functionalSpec = do
)
Nothing
)
-}
"r3" `shouldBe` "update"

7
test/Main.hs
View File

@ -1,5 +1,7 @@
module Main where
import Control.Monad
import System.Directory
-- import Test.Hspec.Formatters.Jenkins
import Test.Hspec.Runner
import TestUtils
@ -10,7 +12,10 @@ import qualified Spec
main :: IO ()
main = do
setupStackFiles
withFileLogging "./test-main.log" $ hspec Spec.spec
let logfile = "./test-main.log"
exists <- doesFileExist logfile
when exists $ removeFile logfile
withFileLogging logfile $ hspec Spec.spec
-- main :: IO ()
-- main = do

7
test/MainDispatcher.hs
View File

@ -2,6 +2,8 @@
module Main where
-- import Test.Hspec.Formatters.Jenkins
import Control.Monad
import System.Directory
import Control.Concurrent
import Control.Concurrent.STM.TChan
import Control.Concurrent.STM.TVar
@ -24,7 +26,10 @@ import Test.Hspec
main :: IO ()
main = do
setupStackFiles
withFileLogging "./test-main-dispatcher.log" $ hspec spec
let logfile = "./test-main-dispatcher.log"
exists <- doesFileExist logfile
when exists $ removeFile logfile
withFileLogging logfile $ hspec spec
-- main :: IO ()
-- main = do