WIP on deferred functional tests

For some reason we are getting the result from req 0, when it should
be from req 3

cabal.project

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

hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs

@@ -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

src/Haskell/Ide/Engine/Dispatcher.hs

@@ -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)

src/Haskell/Ide/Engine/Types.hs

@@ -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 (Uri, Int)
-                -> Maybe J.LspId
+             -> Maybe J.LspId
-                -> RequestCallback m a1
+             -> RequestCallback m a1
-                -> IdeGhcM (IdeResult a1)
+             -> IdeGhcM (IdeResult a1)
-                -> PluginRequest m
+             -> 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)

stack.yaml

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

test/Functional.hs

@@ -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)
+  void $ forkIO $ dispatcherP cin plugins testOptions dispatcherEnv
-  return cin
+                    (\_ _ _ -> 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
+data Cached = Cached | NotCached deriving (Show,Eq,Generic)
-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
 
-dispatchIdeRequest :: TChan (PluginRequest IO) -> LspId -> IdeM (IdeResponse a) -> IO a
+-- Don't care instances via GHC.Generic
-dispatchIdeRequest cin lid f = do
+instance FromJSON Cached where
-  mv <- newEmptyMVar
+instance ToJSON   Cached where
-  let req = IReq lid (putMVar mv) f
-  atomically $ writeTChan cin req
-  takeMVar mv
-
--- ---------------------------------------------------------------------
 
 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 1) (logger "req1") $ getSymbols testUri
-      let req = IReq (IdInt 0) (putMVar reqVar) $ 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
+      let Just ss = fromDynJSON res :: Maybe [SymbolInformation]
-        `shouldBe` [ SymbolInformation
+      head ss `shouldBe`
+                  SymbolInformation
                      { _name          = "main"
                      , _kind          = SkFunction
                      , _location      = Location
@@ -144,61 +199,26 @@ functionalSpec = do
                        }
                      , _containerName = Nothing
                      }
-                   , SymbolInformation
+
-                     { _name          = "foo"
+      -- pick up the diagnostics ...
-                     , _kind          = SkFunction
+      ("req2",Right res) <- atomically $ readTChan logChan
-                     , _location      = Location
+
-                       { _uri   = testUri
+      rrr <- atomically $ tryReadTChan logChan
-                       , _range = Range
+      (show rrr) `shouldBe` "Nothing"
-                         { _start = Position {_line = 5, _character = 0}
+
-                         , _end   = Position {_line = 5, _character = 3}
+      -- Returns immediately, there is a cached value
-                         }
+      atomically $ writeTChan cin $ hreq (IdInt 3) testUri
-                       }
+      hr2 <- atomically $ readTChan logChan
-                     , _containerName = Nothing
+      unpackRes hr1 `shouldBe` ("IReq IdInt 3",Just Cached)
-                     }
+      -- unpackRes hr1 `shouldBe` ("IReq IdInt 0",Just NotCached)
-                   , 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
-                     }
-                   ]
 
     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"
 

test/Main.hs

@@ -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

test/MainDispatcher.hs

@@ -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