mirror of
https://github.com/haskell/haskell-ide-engine.git
synced 2024-08-15 22:10:31 +03:00
Add tests for ExtensibleState
This commit is contained in:
parent
4606d5b744
commit
42ebc40e73
@ -98,6 +98,7 @@ test-suite haskell-ide-test
|
|||||||
other-modules:
|
other-modules:
|
||||||
ApplyRefactPluginSpec
|
ApplyRefactPluginSpec
|
||||||
DispatcherSpec
|
DispatcherSpec
|
||||||
|
ExtensibleStateSpec
|
||||||
GhcModPluginSpec
|
GhcModPluginSpec
|
||||||
HaRePluginSpec
|
HaRePluginSpec
|
||||||
JsonStdioSpec
|
JsonStdioSpec
|
||||||
|
@ -28,8 +28,6 @@ import Control.Applicative
|
|||||||
import Data.Typeable (typeOf,Typeable,cast)
|
import Data.Typeable (typeOf,Typeable,cast)
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Haskell.Ide.Engine.PluginDescriptor
|
import Haskell.Ide.Engine.PluginDescriptor
|
||||||
-- import XMonad.Core
|
|
||||||
-- import qualified Control.Monad.State as State
|
|
||||||
import qualified Control.Monad.State.Strict as State
|
import qualified Control.Monad.State.Strict as State
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
@ -20,25 +20,9 @@ import System.Directory
|
|||||||
import System.IO.Unsafe
|
import System.IO.Unsafe
|
||||||
-- ---------------------------------------------------------------------
|
-- ---------------------------------------------------------------------
|
||||||
|
|
||||||
runLock :: MVar ThreadId
|
|
||||||
runLock = unsafePerformIO $ newEmptyMVar
|
|
||||||
{-# NOINLINE runLock #-}
|
|
||||||
|
|
||||||
runIdeM :: IdeState -> IdeM a -> IO a
|
runIdeM :: IdeState -> IdeM a -> IO a
|
||||||
runIdeM s0 f = do
|
runIdeM s0 f = do
|
||||||
let errorIO e = liftIO $ throwIO $ ErrorCall e
|
((eres, _),_s) <- runStateT (GM.runGhcModT GM.defaultOptions f) s0
|
||||||
|
|
||||||
-- 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)
|
|
||||||
case eres of
|
case eres of
|
||||||
Left err -> liftIO $ throwIO err
|
Left err -> liftIO $ throwIO err
|
||||||
Right res -> return res
|
Right res -> return res
|
||||||
|
@ -134,7 +134,8 @@ data Command = forall a. (ValidResponse a) => Command
|
|||||||
instance Show Command where
|
instance Show Command where
|
||||||
show (Command desc _func) = "(Command " ++ show desc ++ ")"
|
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)
|
buildCommand :: forall a. (ValidResponse a)
|
||||||
=> CommandFunc a
|
=> CommandFunc a
|
||||||
-> CommandName
|
-> CommandName
|
||||||
@ -143,9 +144,18 @@ buildCommand :: forall a. (ValidResponse a)
|
|||||||
-> [AcceptedContext]
|
-> [AcceptedContext]
|
||||||
-> [ParamDescription]
|
-> [ParamDescription]
|
||||||
-> Command
|
-> Command
|
||||||
buildCommand fun n d exts ctxs parm = Command
|
buildCommand fun n d exts ctxs parm =
|
||||||
(CommandDesc n d exts ctxs parm (T.pack $ show $ typeOf (undefined::a)))
|
Command
|
||||||
fun
|
{ 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
|
-- | Return type of a function
|
||||||
|
29
licenses/xmonad-contrib
Normal file
29
licenses/xmonad-contrib
Normal file
@ -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.
|
105
test/ExtensibleStateSpec.hs
Normal file
105
test/ExtensibleStateSpec.hs
Normal file
@ -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
|
||||||
|
}
|
||||||
|
|
||||||
|
-- ---------------------------------------------------------------------
|
Loading…
Reference in New Issue
Block a user