diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 502b3853..1da2ddd2 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -98,6 +98,7 @@ test-suite haskell-ide-test other-modules: ApplyRefactPluginSpec DispatcherSpec + ExtensibleStateSpec GhcModPluginSpec HaRePluginSpec JsonStdioSpec diff --git a/hie-plugin-api/Haskell/Ide/Engine/ExtensibleState.hs b/hie-plugin-api/Haskell/Ide/Engine/ExtensibleState.hs index 46a5a912..cef4093b 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ExtensibleState.hs +++ b/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 diff --git a/hie-plugin-api/Haskell/Ide/Engine/Monad.hs b/hie-plugin-api/Haskell/Ide/Engine/Monad.hs index 40d7ac33..3dada745 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Monad.hs +++ b/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 diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs index 4494e4af..032dbfa2 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs +++ b/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 diff --git a/licenses/xmonad-contrib b/licenses/xmonad-contrib new file mode 100644 index 00000000..d4c566ab --- /dev/null +++ b/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. diff --git a/test/ExtensibleStateSpec.hs b/test/ExtensibleStateSpec.hs new file mode 100644 index 00000000..cd03f6dd --- /dev/null +++ b/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 + } + +-- ---------------------------------------------------------------------