From 4606d5b7441befe4421f3da93df8a5ed8d6b66b9 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 15 Dec 2015 23:56:52 +0200 Subject: [PATCH] Starting to add extensible state as per xmonad --- app/MainHie.hs | 2 +- .../Haskell/Ide/Engine/ExtensibleState.hs | 123 ++++++++++++++++++ .../Haskell/Ide/Engine/PluginDescriptor.hs | 41 ++++++ hie-plugin-api/hie-plugin-api.cabal | 4 +- test/ApplyRefactPluginSpec.hs | 2 +- test/DispatcherSpec.hs | 32 ++--- test/GhcModPluginSpec.hs | 2 +- test/HaRePluginSpec.hs | 2 +- 8 files changed, 187 insertions(+), 21 deletions(-) create mode 100644 hie-plugin-api/Haskell/Ide/Engine/ExtensibleState.hs diff --git a/app/MainHie.hs b/app/MainHie.hs index 10dfa257..8b1a1d9b 100644 --- a/app/MainHie.hs +++ b/app/MainHie.hs @@ -118,7 +118,7 @@ run opts = do Nothing -> return () -- launch the dispatcher. - _ <- forkIO (runIdeM (IdeState plugins) (dispatcher cin)) + _ <- forkIO (runIdeM (IdeState plugins Map.empty) (dispatcher cin)) -- TODO: pass port in as a param from GlobalOpts when (optHttp opts) $ diff --git a/hie-plugin-api/Haskell/Ide/Engine/ExtensibleState.hs b/hie-plugin-api/Haskell/Ide/Engine/ExtensibleState.hs new file mode 100644 index 00000000..46a5a912 --- /dev/null +++ b/hie-plugin-api/Haskell/Ide/Engine/ExtensibleState.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE PatternGuards #-} +-- Based on the one in xmonad-contrib, original header below +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.ExtensibleState +-- Copyright : (c) Daniel Schoepe 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : daniel.schoepe@gmail.com +-- Stability : unstable +-- Portability : not portable +-- +-- Module for storing custom mutable state in xmonad. +-- +----------------------------------------------------------------------------- + +module Haskell.Ide.Engine.ExtensibleState ( + -- * Usage + -- $usage + put + , modify + , remove + , get + , gets + ) where + +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 +import Control.Monad.Trans.Class + +-- --------------------------------------------------------------------- +-- $usage +-- +-- To utilize this feature in a contrib module, create a data type +-- and make it an instance of ExtensionClass. You can then use +-- the functions from this module for storing and retrieving your data: +-- +-- > {-# LANGUAGE DeriveDataTypeable #-} +-- > import qualified XMonad.Util.ExtensibleState as XS +-- > +-- > data ListStorage = ListStorage [Integer] deriving Typeable +-- > instance ExtensionClass ListStorage where +-- > initialValue = ListStorage [] +-- > +-- > .. XS.put (ListStorage [23,42]) +-- +-- To retrieve the stored value call: +-- +-- > .. XS.get +-- +-- If the type can't be inferred from the usage of the retrieved data, you +-- have to add an explicit type signature: +-- +-- > .. XS.get :: X ListStorage +-- +-- To make your data persistent between restarts, the data type needs to be +-- an instance of Read and Show and the instance declaration has to be changed: +-- +-- > data ListStorage = ListStorage [Integer] deriving (Typeable,Read,Show) +-- > +-- > instance ExtensionClass ListStorage where +-- > initialValue = ListStorage [] +-- > extensionType = PersistentExtension +-- +-- One should take care that the string representation of the chosen type +-- is unique among the stored values, otherwise it will be overwritten. +-- Normally these string representations contain fully qualified module names +-- when automatically deriving Typeable, so +-- name collisions should not be a problem in most cases. +-- A module should not try to store common datatypes(e.g. a list of Integers) +-- without a custom data type as a wrapper to avoid collisions with other modules +-- trying to store the same data type without a wrapper. +-- + +-- | Modify the map of state extensions by applying the given function. +modifyStateExts :: (M.Map String (Either String StateExtension) + -> M.Map String (Either String StateExtension)) + -> IdeM () +modifyStateExts f = lift $ lift $ State.modify $ \st -> st { extensibleState = f (extensibleState st) } + +-- | Apply a function to a stored value of the matching type or the initial value if there +-- is none. +modify :: ExtensionClass a => (a -> a) -> IdeM () +modify f = put . f =<< get + +-- | Add a value to the extensible state field. A previously stored value with the same +-- type will be overwritten. (More precisely: A value whose string representation of its type +-- is equal to the new one's) +put :: ExtensionClass a => a -> IdeM () +put v = modifyStateExts . M.insert (show . typeOf $ v) . Right . extensionType $ v + +-- | Try to retrieve a value of the requested type, return an initial value if there is no such value. +get :: ExtensionClass a => IdeM a +get = getState' undefined -- `trick' to avoid needing -XScopedTypeVariables + where toValue val = maybe initialValue id $ cast val + getState' :: ExtensionClass a => a -> IdeM a + getState' k = do + v <- lift $ lift $ State.gets $ M.lookup (show . typeOf $ k) . extensibleState + case v of + Just (Right (StateExtension val)) -> return $ toValue val + Just (Right (PersistentExtension val)) -> return $ toValue val + Just (Left str) | PersistentExtension x <- extensionType k -> do + let val = fromMaybe initialValue $ cast =<< safeRead str `asTypeOf` Just x + put (val `asTypeOf` k) + return val + _ -> return $ initialValue + safeRead str = case reads str of + [(x,"")] -> Just x + _ -> Nothing + +gets :: ExtensionClass a => (a -> b) -> IdeM b +gets = flip fmap get + +-- | Remove the value from the extensible state field that has the same type as the supplied argument +remove :: ExtensionClass a => a -> IdeM () +remove wit = modifyStateExts $ M.delete (show . typeOf $ wit) diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs index 095583dd..4494e4af 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs @@ -85,6 +85,8 @@ module Haskell.Ide.Engine.PluginDescriptor -- * The IDE monad , IdeM , IdeState(..) + , StateExtension(..) + , ExtensionClass(..) , getPlugins ) where @@ -358,6 +360,12 @@ type SyncCommandFunc resp type AsyncCommandFunc resp = (IdeResponse resp -> IO ()) -> [AcceptedContext] -> IdeRequest -> IdeM () +-- --------------------------------------------------------------------- +-- Based on +-- http://xmonad.org/xmonad-docs/xmonad/XMonad-Core.html#t:ExtensionClass + + + -- --------------------------------------------------------------------- -- ValidResponse instances @@ -600,9 +608,42 @@ type IdeT m = GM.GhcModT (StateT IdeState m) data IdeState = IdeState { idePlugins :: Plugins + , extensibleState :: !(Map.Map String (Either String StateExtension)) + -- ^ stores custom state information. } deriving (Show) getPlugins :: IdeM Plugins getPlugins = lift $ lift $ idePlugins <$> get +-- --------------------------------------------------------------------- +-- Extensible state, based on +-- http://xmonad.org/xmonad-docs/xmonad/XMonad-Core.html#t:ExtensionClass +-- + +-- | Every module must make the data it wants to store +-- an instance of this class. +-- +-- Minimal complete definition: initialValue +class Typeable a => ExtensionClass a where + -- | Defines an initial value for the state extension + initialValue :: a + -- | Specifies whether the state extension should be + -- persistent. Setting this method to 'PersistentExtension' + -- will make the stored data survive restarts, but + -- requires a to be an instance of Read and Show. + -- + -- It defaults to 'StateExtension', i.e. no persistence. + extensionType :: a -> StateExtension + extensionType = StateExtension + +-- | Existential type to store a state extension. +data StateExtension = + forall a. ExtensionClass a => StateExtension a + -- ^ Non-persistent state extension + | forall a. (Read a, Show a, ExtensionClass a) => PersistentExtension a + -- ^ Persistent extension + +instance Show StateExtension where + show _ = "StateExtension" + -- EOF diff --git a/hie-plugin-api/hie-plugin-api.cabal b/hie-plugin-api/hie-plugin-api.cabal index 221d2e46..ec5aa624 100644 --- a/hie-plugin-api/hie-plugin-api.cabal +++ b/hie-plugin-api/hie-plugin-api.cabal @@ -12,7 +12,9 @@ build-type: Simple cabal-version: >=1.10 library - exposed-modules: Haskell.Ide.Engine.Monad + exposed-modules: + Haskell.Ide.Engine.ExtensibleState + Haskell.Ide.Engine.Monad Haskell.Ide.Engine.MonadFunctions Haskell.Ide.Engine.PluginDescriptor Haskell.Ide.Engine.PluginUtils diff --git a/test/ApplyRefactPluginSpec.hs b/test/ApplyRefactPluginSpec.hs index 0a803277..f16e6a34 100644 --- a/test/ApplyRefactPluginSpec.hs +++ b/test/ApplyRefactPluginSpec.hs @@ -40,7 +40,7 @@ dispatchRequest :: IdeRequest -> IO (Maybe (IdeResponse Object)) dispatchRequest req = do testChan <- atomically newTChan let cr = CReq "applyrefact" 1 req testChan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch testPlugins cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch testPlugins cr) return r -- --------------------------------------------------------------------- diff --git a/test/DispatcherSpec.hs b/test/DispatcherSpec.hs index 2e581cec..0826ed88 100644 --- a/test/DispatcherSpec.hs +++ b/test/DispatcherSpec.hs @@ -44,7 +44,7 @@ dispatcherSpec = do chSync <- atomically newTChan let req = IdeRequest "cmd1" (Map.fromList []) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxNone]"::String)])) -- --------------------------------- @@ -54,7 +54,7 @@ dispatcherSpec = do chSync <- atomically newTChan let req = IdeRequest "cmd2" (Map.fromList []) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseFail (IdeError {ideCode = MissingParameter, ideMessage = "need `file` parameter", ideInfo = Just (String "file")})) -- --------------------------------- @@ -64,7 +64,7 @@ dispatcherSpec = do chSync <- atomically newTChan let req = IdeRequest "cmd2" (Map.fromList [("file", ParamFileP "foo.hs")]) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxFile]"::String)])) -- --------------------------------- @@ -74,7 +74,7 @@ dispatcherSpec = do chSync <- atomically newTChan let req = IdeRequest "cmd3" (Map.fromList [("file", ParamFileP "foo.hs"),("start_pos", ParamPosP (1,2))]) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxPoint]"::String)])) -- --------------------------------- @@ -86,7 +86,7 @@ dispatcherSpec = do ,("start_pos", ParamPosP (1,2)) ,("end_pos", ParamPosP (3,4))]) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxRegion]"::String)])) -- --------------------------------- @@ -96,7 +96,7 @@ dispatcherSpec = do chSync <- atomically newTChan let req = IdeRequest "cmd5" (Map.fromList [("cabal", ParamTextP "lib")]) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxCabalTarget]"::String)])) @@ -107,7 +107,7 @@ dispatcherSpec = do chSync <- atomically newTChan let req = IdeRequest "cmd6" (Map.fromList [("dir", ParamFileP ".")]) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxProject]"::String)])) -- --------------------------------- @@ -119,7 +119,7 @@ dispatcherSpec = do ,("start_pos", ParamPosP (1,2)) ,("end_pos", ParamPosP (3,4))]) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxFile,CtxPoint,CtxRegion]"::String)])) -- --------------------------------- @@ -130,7 +130,7 @@ dispatcherSpec = do let req = IdeRequest "cmdmultiple" (Map.fromList [("file", ParamFileP "foo.hs") ,("start_pos", ParamPosP (1,2))]) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxFile,CtxPoint]"::String)])) -- --------------------------------- @@ -140,7 +140,7 @@ dispatcherSpec = do chSync <- atomically newTChan let req = IdeRequest "cmdmultiple" (Map.fromList [("cabal", ParamTextP "lib")]) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseFail (IdeError { ideCode = MissingParameter , ideMessage = "need `file` parameter" @@ -159,7 +159,7 @@ dispatcherSpec = do ,("pos", ParamPosP (1,2)) ]) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxFile]"::String)])) @@ -174,7 +174,7 @@ dispatcherSpec = do ,("pos", ParamPosP (1,2)) ]) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseFail (IdeError @@ -194,7 +194,7 @@ dispatcherSpec = do ,("poso", ParamPosP (1,2)) ]) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxNone]"::String)])) -- --------------------------------- @@ -207,7 +207,7 @@ dispatcherSpec = do ,("poso", ParamPosP (1,2)) ]) cr = CReq "test" 1 req chan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr) r `shouldBe` Just (IdeResponseFail (IdeError { ideCode = IncorrectParameterType @@ -229,8 +229,8 @@ dispatcherSpec = do req2 = IdeRequest "cmdasync2" Map.empty cr1 = CReq "test" 1 req1 chan cr2 = CReq "test" 2 req2 chan - r1 <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr1) - r2 <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr2) + r1 <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr1) + r2 <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr2) r1 `shouldBe` Nothing r2 `shouldBe` Nothing rc1 <- atomically $ readTChan chan diff --git a/test/GhcModPluginSpec.hs b/test/GhcModPluginSpec.hs index e9dede45..79fb55ec 100644 --- a/test/GhcModPluginSpec.hs +++ b/test/GhcModPluginSpec.hs @@ -44,7 +44,7 @@ dispatchRequest :: IdeRequest -> IO (Maybe (IdeResponse Object)) dispatchRequest req = do testChan <- atomically newTChan let cr = CReq "ghcmod" 1 req testChan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch testPlugins cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch testPlugins cr) return r -- --------------------------------------------------------------------- diff --git a/test/HaRePluginSpec.hs b/test/HaRePluginSpec.hs index baec3968..33ba6fd7 100644 --- a/test/HaRePluginSpec.hs +++ b/test/HaRePluginSpec.hs @@ -40,7 +40,7 @@ dispatchRequest :: IdeRequest -> IO (Maybe (IdeResponse Object)) dispatchRequest req = do testChan <- atomically newTChan let cr = CReq "hare" 1 req testChan - r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch testPlugins cr) + r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch testPlugins cr) return r -- ---------------------------------------------------------------------