Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Commit 42ebc40

Browse files
alanzalanz
committed
Add tests for ExtensibleState
1 parent 4606d5b commit 42ebc40

File tree

6 files changed

+150
-23
lines changed

6 files changed

+150
-23
lines changed

Diff for: ‎haskell-ide-engine.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -98,6 +98,7 @@ test-suite haskell-ide-test
9898
other-modules:
9999
ApplyRefactPluginSpec
100100
DispatcherSpec
101+
ExtensibleStateSpec
101102
GhcModPluginSpec
102103
HaRePluginSpec
103104
JsonStdioSpec

Diff for: ‎hie-plugin-api/Haskell/Ide/Engine/ExtensibleState.hs

-2
Original file line numberDiff line numberDiff line change
@@ -28,8 +28,6 @@ import Control.Applicative
2828
import Data.Typeable (typeOf,Typeable,cast)
2929
import qualified Data.Map as M
3030
import Haskell.Ide.Engine.PluginDescriptor
31-
-- import XMonad.Core
32-
-- import qualified Control.Monad.State as State
3331
import qualified Control.Monad.State.Strict as State
3432
import Data.Maybe (fromMaybe)
3533
import Control.Monad

Diff for: ‎hie-plugin-api/Haskell/Ide/Engine/Monad.hs

+1-17
Original file line numberDiff line numberDiff line change
@@ -20,25 +20,9 @@ import System.Directory
2020
import System.IO.Unsafe
2121
-- ---------------------------------------------------------------------
2222

23-
runLock :: MVar ThreadId
24-
runLock = unsafePerformIO $ newEmptyMVar
25-
{-# NOINLINE runLock #-}
26-
2723
runIdeM :: IdeState -> IdeM a -> IO a
2824
runIdeM s0 f = do
29-
let errorIO e = liftIO $ throwIO $ ErrorCall e
30-
31-
-- FIXME: this is very racy do some fancy stuff with masking
32-
-- _ <- liftIO $ (\case Just tid -> errorIO $ "locked by " ++ show tid)
33-
-- =<< tryReadMVar runLock
34-
-- liftIO $ putMVar runLock =<< myThreadId
35-
36-
-- root <- either (error "could not get project root") (GM.dropWhileEnd isSpace) . fst
37-
-- <$> GM.runGhcModT GM.defaultOptions GM.rootInfo
38-
39-
-- liftIO $ setCurrentDirectory root
40-
41-
((eres, _),_s) <- flip runStateT s0 (GM.runGhcModT GM.defaultOptions f)
25+
((eres, _),_s) <- runStateT (GM.runGhcModT GM.defaultOptions f) s0
4226
case eres of
4327
Left err -> liftIO $ throwIO err
4428
Right res -> return res

Diff for: ‎hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs

+14-4
Original file line numberDiff line numberDiff line change
@@ -134,7 +134,8 @@ data Command = forall a. (ValidResponse a) => Command
134134
instance Show Command where
135135
show (Command desc _func) = "(Command " ++ show desc ++ ")"
136136

137-
-- | Build a command, ensuring the command response type name and the command function match
137+
-- | Build a command, ensuring the command response type name and the command
138+
-- function match
138139
buildCommand :: forall a. (ValidResponse a)
139140
=> CommandFunc a
140141
-> CommandName
@@ -143,9 +144,18 @@ buildCommand :: forall a. (ValidResponse a)
143144
-> [AcceptedContext]
144145
-> [ParamDescription]
145146
-> Command
146-
buildCommand fun n d exts ctxs parm = Command
147-
(CommandDesc n d exts ctxs parm (T.pack $ show $ typeOf (undefined::a)))
148-
fun
147+
buildCommand fun n d exts ctxs parm =
148+
Command
149+
{ cmdDesc = CommandDesc
150+
{ cmdName = n
151+
, cmdUiDescription = d
152+
, cmdFileExtensions = exts
153+
, cmdContexts = ctxs
154+
, cmdAdditionalParams = parm
155+
, cmdReturnType = T.pack $ show $ typeOf (undefined::a)
156+
}
157+
, cmdFunc = fun
158+
}
149159

150160

151161
-- | Return type of a function

Diff for: ‎licenses/xmonad-contrib

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

Diff for: ‎test/ExtensibleStateSpec.hs

+105
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,105 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
module ExtensibleStateSpec where
3+
4+
import Control.Concurrent
5+
import Control.Concurrent.STM.TChan
6+
import Control.Monad.IO.Class
7+
import Control.Monad.STM
8+
import Data.Aeson
9+
import qualified Data.HashMap.Strict as H
10+
import qualified Data.Text as T
11+
import qualified Data.HashMap.Strict as HM
12+
import qualified Data.Map as Map
13+
import Data.Typeable
14+
import Haskell.Ide.Engine.Dispatcher
15+
import Haskell.Ide.Engine.ExtensibleState
16+
import Haskell.Ide.Engine.Monad
17+
import Haskell.Ide.Engine.MonadFunctions
18+
import Haskell.Ide.Engine.PluginDescriptor
19+
import Haskell.Ide.Engine.Types
20+
import Haskell.Ide.Engine.Utils
21+
import Haskell.Ide.Engine.PluginDescriptor
22+
23+
import Test.Hspec
24+
25+
main :: IO ()
26+
main = hspec spec
27+
28+
spec :: Spec
29+
spec = do
30+
describe "ExtensibleState" extensibleStateSpec
31+
32+
extensibleStateSpec :: Spec
33+
extensibleStateSpec = do
34+
describe "stores and retrieves in the state" $ do
35+
it "stores the first one" $ do
36+
chan <- atomically newTChan
37+
chSync <- atomically newTChan
38+
let req1 = IdeRequest "cmd1" (Map.fromList [])
39+
cr1 = CReq "test" 1 req1 chan
40+
let req2 = IdeRequest "cmd2" (Map.fromList [])
41+
cr2 = CReq "test" 1 req2 chan
42+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty)
43+
(do
44+
r1 <- doDispatch (testPlugins chSync) cr1
45+
r2 <- doDispatch (testPlugins chSync) cr2
46+
return (r1,r2))
47+
fst r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:put foo"::String)]))
48+
snd r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:got:\"foo\""::String)]))
49+
50+
-- ---------------------------------
51+
52+
-- ---------------------------------------------------------------------
53+
54+
testPlugins :: TChan () -> Plugins
55+
testPlugins chSync = Map.fromList [("test",testDescriptor chSync)]
56+
57+
testDescriptor :: TChan () -> PluginDescriptor
58+
testDescriptor chSync = PluginDescriptor
59+
{
60+
pdUIShortName = "testDescriptor"
61+
, pdUIOverview = "PluginDescriptor for testing Dispatcher"
62+
, pdCommands =
63+
[
64+
mkCmdWithContext cmd1 "cmd1" [CtxNone] []
65+
, mkCmdWithContext cmd2 "cmd2" [CtxNone] []
66+
]
67+
, pdExposedServices = []
68+
, pdUsedServices = []
69+
}
70+
71+
-- ---------------------------------------------------------------------
72+
73+
cmd1 :: CommandFunc T.Text
74+
cmd1 = CmdSync $ \_ctxs _req -> do
75+
put (MS1 "foo")
76+
return (IdeResponseOk (T.pack $ "result:put foo"))
77+
78+
cmd2 :: CommandFunc T.Text
79+
cmd2 = CmdSync $ \_ctxs _req -> do
80+
(MS1 v) <- get
81+
return (IdeResponseOk (T.pack $ "result:got:" ++ show v))
82+
83+
data MyState1 = MS1 T.Text deriving Typeable
84+
85+
instance ExtensionClass MyState1 where
86+
initialValue = MS1 "initial"
87+
88+
-- ---------------------------------------------------------------------
89+
90+
mkCmdWithContext ::(ValidResponse a)
91+
=> CommandFunc a -> CommandName -> [AcceptedContext] -> [ParamDescription] -> Command
92+
mkCmdWithContext cmd n cts pds =
93+
Command
94+
{ cmdDesc = CommandDesc
95+
{ cmdName = n
96+
, cmdUiDescription = "description"
97+
, cmdFileExtensions = []
98+
, cmdContexts = cts
99+
, cmdAdditionalParams = pds
100+
, cmdReturnType = "Text"
101+
}
102+
, cmdFunc = cmd
103+
}
104+
105+
-- ---------------------------------------------------------------------

0 commit comments

Comments
 (0)