Add tests for ExtensibleState

haskell-ide-engine.cabal

@@ -98,6 +98,7 @@ test-suite haskell-ide-test
   other-modules:
                        ApplyRefactPluginSpec
                        DispatcherSpec
+                       ExtensibleStateSpec
                        GhcModPluginSpec
                        HaRePluginSpec
                        JsonStdioSpec

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

@@ -28,8 +28,6 @@ import Control.Applicative
 import Data.Typeable (typeOf,Typeable,cast)
 import qualified Data.Map as M
 import Haskell.Ide.Engine.PluginDescriptor
--- import XMonad.Core
--- import qualified Control.Monad.State as State
 import qualified Control.Monad.State.Strict as State
 import Data.Maybe (fromMaybe)
 import Control.Monad

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

@@ -20,25 +20,9 @@ import           System.Directory
 import           System.IO.Unsafe
 -- ---------------------------------------------------------------------
 
-runLock :: MVar ThreadId
-runLock = unsafePerformIO $ newEmptyMVar
-{-# NOINLINE runLock #-}
-
 runIdeM :: IdeState -> IdeM a -> IO a
 runIdeM s0 f = do
-    let errorIO e = liftIO $ throwIO $ ErrorCall e
-
-    -- FIXME: this is very racy do some fancy stuff with masking
-    -- _ <- liftIO $ (\case Just tid -> errorIO $ "locked by " ++ show tid)
-    --     =<< tryReadMVar runLock
-    -- liftIO $ putMVar runLock =<< myThreadId
-
-    -- root <- either (error "could not get project root") (GM.dropWhileEnd isSpace) . fst
-    --           <$> GM.runGhcModT GM.defaultOptions GM.rootInfo
-
-    -- liftIO $ setCurrentDirectory root
-
-    ((eres, _),_s) <- flip runStateT s0 (GM.runGhcModT GM.defaultOptions f)
+    ((eres, _),_s) <- runStateT (GM.runGhcModT GM.defaultOptions f) s0
     case eres of
         Left err -> liftIO $ throwIO err
         Right res -> return res

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

@@ -134,7 +134,8 @@ data Command = forall a. (ValidResponse a) => Command
 instance Show Command where
   show (Command desc _func) = "(Command " ++ show desc ++ ")"
 
--- | Build a command, ensuring the command response type name and the command function match
+-- | Build a command, ensuring the command response type name and the command
+-- function match
 buildCommand :: forall a. (ValidResponse a)
   => CommandFunc a
   -> CommandName
@@ -143,9 +144,18 @@ buildCommand :: forall a. (ValidResponse a)
   -> [AcceptedContext]
   -> [ParamDescription]
   -> Command
-buildCommand fun n d exts ctxs parm = Command
-  (CommandDesc n d exts ctxs parm (T.pack $ show $ typeOf (undefined::a)))
-  fun
+buildCommand fun n d exts ctxs parm =
+  Command
+  { cmdDesc = CommandDesc
+      { cmdName = n
+      , cmdUiDescription = d
+      , cmdFileExtensions = exts
+      , cmdContexts = ctxs
+      , cmdAdditionalParams = parm
+      , cmdReturnType = T.pack $ show $ typeOf (undefined::a)
+      }
+  , cmdFunc = fun
+  }
 
 
 -- | Return type of a function

licenses/xmonad-contrib

@@ -0,0 +1,29 @@
+-- For the ExtensibleState module
+
+Copyright (c) The Xmonad Community
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of his contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.

test/ExtensibleStateSpec.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE OverloadedStrings #-}
+module ExtensibleStateSpec where
+
+import           Control.Concurrent
+import           Control.Concurrent.STM.TChan
+import           Control.Monad.IO.Class
+import           Control.Monad.STM
+import           Data.Aeson
+import qualified Data.HashMap.Strict as H
+import qualified Data.Text as T
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Map as Map
+import           Data.Typeable
+import           Haskell.Ide.Engine.Dispatcher
+import           Haskell.Ide.Engine.ExtensibleState
+import           Haskell.Ide.Engine.Monad
+import           Haskell.Ide.Engine.MonadFunctions
+import           Haskell.Ide.Engine.PluginDescriptor
+import           Haskell.Ide.Engine.Types
+import           Haskell.Ide.Engine.Utils
+import           Haskell.Ide.Engine.PluginDescriptor
+
+import           Test.Hspec
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+  describe "ExtensibleState" extensibleStateSpec
+
+extensibleStateSpec :: Spec
+extensibleStateSpec = do
+  describe "stores and retrieves in the state" $ do
+    it "stores the first one" $ do
+      chan <- atomically newTChan
+      chSync <- atomically newTChan
+      let req1 = IdeRequest "cmd1" (Map.fromList [])
+          cr1 = CReq "test" 1 req1 chan
+      let req2 = IdeRequest "cmd2" (Map.fromList [])
+          cr2 = CReq "test" 1 req2 chan
+      r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty)
+        (do
+          r1 <- doDispatch (testPlugins chSync) cr1
+          r2 <- doDispatch (testPlugins chSync) cr2
+          return (r1,r2))
+      fst r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:put foo"::String)]))
+      snd r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:got:\"foo\""::String)]))
+
+    -- ---------------------------------
+
+-- ---------------------------------------------------------------------
+
+testPlugins :: TChan () -> Plugins
+testPlugins chSync = Map.fromList [("test",testDescriptor chSync)]
+
+testDescriptor :: TChan () -> PluginDescriptor
+testDescriptor chSync = PluginDescriptor
+  {
+    pdUIShortName = "testDescriptor"
+  , pdUIOverview = "PluginDescriptor for testing Dispatcher"
+  , pdCommands =
+      [
+        mkCmdWithContext cmd1 "cmd1" [CtxNone] []
+      , mkCmdWithContext cmd2 "cmd2" [CtxNone] []
+      ]
+  , pdExposedServices = []
+  , pdUsedServices    = []
+  }
+
+-- ---------------------------------------------------------------------
+
+cmd1 :: CommandFunc T.Text
+cmd1 = CmdSync $ \_ctxs _req -> do
+  put (MS1 "foo")
+  return (IdeResponseOk (T.pack $ "result:put foo"))
+
+cmd2 :: CommandFunc T.Text
+cmd2 = CmdSync $ \_ctxs _req -> do
+  (MS1 v) <- get
+  return (IdeResponseOk (T.pack $ "result:got:" ++ show v))
+
+data MyState1 = MS1 T.Text deriving Typeable
+
+instance ExtensionClass MyState1 where
+  initialValue = MS1 "initial"
+
+-- ---------------------------------------------------------------------
+
+mkCmdWithContext ::(ValidResponse a)
+                 => CommandFunc a -> CommandName -> [AcceptedContext] -> [ParamDescription] -> Command
+mkCmdWithContext cmd n cts pds =
+        Command
+          { cmdDesc = CommandDesc
+                        { cmdName = n
+                        , cmdUiDescription = "description"
+                        , cmdFileExtensions = []
+                        , cmdContexts = cts
+                        , cmdAdditionalParams = pds
+                        , cmdReturnType = "Text"
+                        }
+          , cmdFunc = cmd
+          }
+
+-- ---------------------------------------------------------------------