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

Commit 4606d5b

Browse files
alanzalanz
committed
Starting to add extensible state as per xmonad
1 parent 2947e3a commit 4606d5b

File tree

8 files changed

+187
-21
lines changed

8 files changed

+187
-21
lines changed

‎app/MainHie.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -118,7 +118,7 @@ run opts = do
118118
Nothing -> return ()
119119

120120
-- launch the dispatcher.
121-
_ <- forkIO (runIdeM (IdeState plugins) (dispatcher cin))
121+
_ <- forkIO (runIdeM (IdeState plugins Map.empty) (dispatcher cin))
122122

123123
-- TODO: pass port in as a param from GlobalOpts
124124
when (optHttp opts) $

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

+123
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,123 @@
1+
{-# LANGUAGE PatternGuards #-}
2+
-- Based on the one in xmonad-contrib, original header below
3+
-----------------------------------------------------------------------------
4+
-- |
5+
-- Module : XMonad.Util.ExtensibleState
6+
-- Copyright : (c) Daniel Schoepe 2009
7+
-- License : BSD3-style (see LICENSE)
8+
--
9+
-- Maintainer : [email protected]
10+
-- Stability : unstable
11+
-- Portability : not portable
12+
--
13+
-- Module for storing custom mutable state in xmonad.
14+
--
15+
-----------------------------------------------------------------------------
16+
17+
module Haskell.Ide.Engine.ExtensibleState (
18+
-- * Usage
19+
-- $usage
20+
put
21+
, modify
22+
, remove
23+
, get
24+
, gets
25+
) where
26+
27+
import Control.Applicative
28+
import Data.Typeable (typeOf,Typeable,cast)
29+
import qualified Data.Map as M
30+
import Haskell.Ide.Engine.PluginDescriptor
31+
-- import XMonad.Core
32+
-- import qualified Control.Monad.State as State
33+
import qualified Control.Monad.State.Strict as State
34+
import Data.Maybe (fromMaybe)
35+
import Control.Monad
36+
import Control.Monad.Trans.Class
37+
38+
-- ---------------------------------------------------------------------
39+
-- $usage
40+
--
41+
-- To utilize this feature in a contrib module, create a data type
42+
-- and make it an instance of ExtensionClass. You can then use
43+
-- the functions from this module for storing and retrieving your data:
44+
--
45+
-- > {-# LANGUAGE DeriveDataTypeable #-}
46+
-- > import qualified XMonad.Util.ExtensibleState as XS
47+
-- >
48+
-- > data ListStorage = ListStorage [Integer] deriving Typeable
49+
-- > instance ExtensionClass ListStorage where
50+
-- > initialValue = ListStorage []
51+
-- >
52+
-- > .. XS.put (ListStorage [23,42])
53+
--
54+
-- To retrieve the stored value call:
55+
--
56+
-- > .. XS.get
57+
--
58+
-- If the type can't be inferred from the usage of the retrieved data, you
59+
-- have to add an explicit type signature:
60+
--
61+
-- > .. XS.get :: X ListStorage
62+
--
63+
-- To make your data persistent between restarts, the data type needs to be
64+
-- an instance of Read and Show and the instance declaration has to be changed:
65+
--
66+
-- > data ListStorage = ListStorage [Integer] deriving (Typeable,Read,Show)
67+
-- >
68+
-- > instance ExtensionClass ListStorage where
69+
-- > initialValue = ListStorage []
70+
-- > extensionType = PersistentExtension
71+
--
72+
-- One should take care that the string representation of the chosen type
73+
-- is unique among the stored values, otherwise it will be overwritten.
74+
-- Normally these string representations contain fully qualified module names
75+
-- when automatically deriving Typeable, so
76+
-- name collisions should not be a problem in most cases.
77+
-- A module should not try to store common datatypes(e.g. a list of Integers)
78+
-- without a custom data type as a wrapper to avoid collisions with other modules
79+
-- trying to store the same data type without a wrapper.
80+
--
81+
82+
-- | Modify the map of state extensions by applying the given function.
83+
modifyStateExts :: (M.Map String (Either String StateExtension)
84+
-> M.Map String (Either String StateExtension))
85+
-> IdeM ()
86+
modifyStateExts f = lift $ lift $ State.modify $ \st -> st { extensibleState = f (extensibleState st) }
87+
88+
-- | Apply a function to a stored value of the matching type or the initial value if there
89+
-- is none.
90+
modify :: ExtensionClass a => (a -> a) -> IdeM ()
91+
modify f = put . f =<< get
92+
93+
-- | Add a value to the extensible state field. A previously stored value with the same
94+
-- type will be overwritten. (More precisely: A value whose string representation of its type
95+
-- is equal to the new one's)
96+
put :: ExtensionClass a => a -> IdeM ()
97+
put v = modifyStateExts . M.insert (show . typeOf $ v) . Right . extensionType $ v
98+
99+
-- | Try to retrieve a value of the requested type, return an initial value if there is no such value.
100+
get :: ExtensionClass a => IdeM a
101+
get = getState' undefined -- `trick' to avoid needing -XScopedTypeVariables
102+
where toValue val = maybe initialValue id $ cast val
103+
getState' :: ExtensionClass a => a -> IdeM a
104+
getState' k = do
105+
v <- lift $ lift $ State.gets $ M.lookup (show . typeOf $ k) . extensibleState
106+
case v of
107+
Just (Right (StateExtension val)) -> return $ toValue val
108+
Just (Right (PersistentExtension val)) -> return $ toValue val
109+
Just (Left str) | PersistentExtension x <- extensionType k -> do
110+
let val = fromMaybe initialValue $ cast =<< safeRead str `asTypeOf` Just x
111+
put (val `asTypeOf` k)
112+
return val
113+
_ -> return $ initialValue
114+
safeRead str = case reads str of
115+
[(x,"")] -> Just x
116+
_ -> Nothing
117+
118+
gets :: ExtensionClass a => (a -> b) -> IdeM b
119+
gets = flip fmap get
120+
121+
-- | Remove the value from the extensible state field that has the same type as the supplied argument
122+
remove :: ExtensionClass a => a -> IdeM ()
123+
remove wit = modifyStateExts $ M.delete (show . typeOf $ wit)

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

+41
Original file line numberDiff line numberDiff line change
@@ -85,6 +85,8 @@ module Haskell.Ide.Engine.PluginDescriptor
8585
-- * The IDE monad
8686
, IdeM
8787
, IdeState(..)
88+
, StateExtension(..)
89+
, ExtensionClass(..)
8890
, getPlugins
8991
) where
9092

@@ -358,6 +360,12 @@ type SyncCommandFunc resp
358360
type AsyncCommandFunc resp = (IdeResponse resp -> IO ())
359361
-> [AcceptedContext] -> IdeRequest -> IdeM ()
360362

363+
-- ---------------------------------------------------------------------
364+
-- Based on
365+
-- http://xmonad.org/xmonad-docs/xmonad/XMonad-Core.html#t:ExtensionClass
366+
367+
368+
361369
-- ---------------------------------------------------------------------
362370
-- ValidResponse instances
363371

@@ -600,9 +608,42 @@ type IdeT m = GM.GhcModT (StateT IdeState m)
600608
data IdeState = IdeState
601609
{
602610
idePlugins :: Plugins
611+
, extensibleState :: !(Map.Map String (Either String StateExtension))
612+
-- ^ stores custom state information.
603613
} deriving (Show)
604614

605615
getPlugins :: IdeM Plugins
606616
getPlugins = lift $ lift $ idePlugins <$> get
607617

618+
-- ---------------------------------------------------------------------
619+
-- Extensible state, based on
620+
-- http://xmonad.org/xmonad-docs/xmonad/XMonad-Core.html#t:ExtensionClass
621+
--
622+
623+
-- | Every module must make the data it wants to store
624+
-- an instance of this class.
625+
--
626+
-- Minimal complete definition: initialValue
627+
class Typeable a => ExtensionClass a where
628+
-- | Defines an initial value for the state extension
629+
initialValue :: a
630+
-- | Specifies whether the state extension should be
631+
-- persistent. Setting this method to 'PersistentExtension'
632+
-- will make the stored data survive restarts, but
633+
-- requires a to be an instance of Read and Show.
634+
--
635+
-- It defaults to 'StateExtension', i.e. no persistence.
636+
extensionType :: a -> StateExtension
637+
extensionType = StateExtension
638+
639+
-- | Existential type to store a state extension.
640+
data StateExtension =
641+
forall a. ExtensionClass a => StateExtension a
642+
-- ^ Non-persistent state extension
643+
| forall a. (Read a, Show a, ExtensionClass a) => PersistentExtension a
644+
-- ^ Persistent extension
645+
646+
instance Show StateExtension where
647+
show _ = "StateExtension"
648+
608649
-- EOF

‎hie-plugin-api/hie-plugin-api.cabal

+3-1
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,9 @@ build-type: Simple
1212
cabal-version: >=1.10
1313

1414
library
15-
exposed-modules: Haskell.Ide.Engine.Monad
15+
exposed-modules:
16+
Haskell.Ide.Engine.ExtensibleState
17+
Haskell.Ide.Engine.Monad
1618
Haskell.Ide.Engine.MonadFunctions
1719
Haskell.Ide.Engine.PluginDescriptor
1820
Haskell.Ide.Engine.PluginUtils

‎test/ApplyRefactPluginSpec.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,7 @@ dispatchRequest :: IdeRequest -> IO (Maybe (IdeResponse Object))
4040
dispatchRequest req = do
4141
testChan <- atomically newTChan
4242
let cr = CReq "applyrefact" 1 req testChan
43-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch testPlugins cr)
43+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch testPlugins cr)
4444
return r
4545

4646
-- ---------------------------------------------------------------------

‎test/DispatcherSpec.hs

+16-16
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,7 @@ dispatcherSpec = do
4444
chSync <- atomically newTChan
4545
let req = IdeRequest "cmd1" (Map.fromList [])
4646
cr = CReq "test" 1 req chan
47-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
47+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
4848
r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxNone]"::String)]))
4949

5050
-- ---------------------------------
@@ -54,7 +54,7 @@ dispatcherSpec = do
5454
chSync <- atomically newTChan
5555
let req = IdeRequest "cmd2" (Map.fromList [])
5656
cr = CReq "test" 1 req chan
57-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
57+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
5858
r `shouldBe` Just (IdeResponseFail (IdeError {ideCode = MissingParameter, ideMessage = "need `file` parameter", ideInfo = Just (String "file")}))
5959

6060
-- ---------------------------------
@@ -64,7 +64,7 @@ dispatcherSpec = do
6464
chSync <- atomically newTChan
6565
let req = IdeRequest "cmd2" (Map.fromList [("file", ParamFileP "foo.hs")])
6666
cr = CReq "test" 1 req chan
67-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
67+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
6868
r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxFile]"::String)]))
6969

7070
-- ---------------------------------
@@ -74,7 +74,7 @@ dispatcherSpec = do
7474
chSync <- atomically newTChan
7575
let req = IdeRequest "cmd3" (Map.fromList [("file", ParamFileP "foo.hs"),("start_pos", ParamPosP (1,2))])
7676
cr = CReq "test" 1 req chan
77-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
77+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
7878
r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxPoint]"::String)]))
7979

8080
-- ---------------------------------
@@ -86,7 +86,7 @@ dispatcherSpec = do
8686
,("start_pos", ParamPosP (1,2))
8787
,("end_pos", ParamPosP (3,4))])
8888
cr = CReq "test" 1 req chan
89-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
89+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
9090
r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxRegion]"::String)]))
9191

9292
-- ---------------------------------
@@ -96,7 +96,7 @@ dispatcherSpec = do
9696
chSync <- atomically newTChan
9797
let req = IdeRequest "cmd5" (Map.fromList [("cabal", ParamTextP "lib")])
9898
cr = CReq "test" 1 req chan
99-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
99+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
100100
r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxCabalTarget]"::String)]))
101101

102102

@@ -107,7 +107,7 @@ dispatcherSpec = do
107107
chSync <- atomically newTChan
108108
let req = IdeRequest "cmd6" (Map.fromList [("dir", ParamFileP ".")])
109109
cr = CReq "test" 1 req chan
110-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
110+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
111111
r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxProject]"::String)]))
112112

113113
-- ---------------------------------
@@ -119,7 +119,7 @@ dispatcherSpec = do
119119
,("start_pos", ParamPosP (1,2))
120120
,("end_pos", ParamPosP (3,4))])
121121
cr = CReq "test" 1 req chan
122-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
122+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
123123
r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxFile,CtxPoint,CtxRegion]"::String)]))
124124

125125
-- ---------------------------------
@@ -130,7 +130,7 @@ dispatcherSpec = do
130130
let req = IdeRequest "cmdmultiple" (Map.fromList [("file", ParamFileP "foo.hs")
131131
,("start_pos", ParamPosP (1,2))])
132132
cr = CReq "test" 1 req chan
133-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
133+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
134134
r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxFile,CtxPoint]"::String)]))
135135

136136
-- ---------------------------------
@@ -140,7 +140,7 @@ dispatcherSpec = do
140140
chSync <- atomically newTChan
141141
let req = IdeRequest "cmdmultiple" (Map.fromList [("cabal", ParamTextP "lib")])
142142
cr = CReq "test" 1 req chan
143-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
143+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
144144
r `shouldBe`
145145
Just (IdeResponseFail (IdeError { ideCode = MissingParameter
146146
, ideMessage = "need `file` parameter"
@@ -159,7 +159,7 @@ dispatcherSpec = do
159159
,("pos", ParamPosP (1,2))
160160
])
161161
cr = CReq "test" 1 req chan
162-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
162+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
163163
r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxFile]"::String)]))
164164

165165

@@ -174,7 +174,7 @@ dispatcherSpec = do
174174
,("pos", ParamPosP (1,2))
175175
])
176176
cr = CReq "test" 1 req chan
177-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
177+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
178178
r `shouldBe`
179179
Just (IdeResponseFail
180180
(IdeError
@@ -194,7 +194,7 @@ dispatcherSpec = do
194194
,("poso", ParamPosP (1,2))
195195
])
196196
cr = CReq "test" 1 req chan
197-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
197+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
198198
r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxNone]"::String)]))
199199

200200
-- ---------------------------------
@@ -207,7 +207,7 @@ dispatcherSpec = do
207207
,("poso", ParamPosP (1,2))
208208
])
209209
cr = CReq "test" 1 req chan
210-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
210+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr)
211211
r `shouldBe`
212212
Just (IdeResponseFail
213213
(IdeError { ideCode = IncorrectParameterType
@@ -229,8 +229,8 @@ dispatcherSpec = do
229229
req2 = IdeRequest "cmdasync2" Map.empty
230230
cr1 = CReq "test" 1 req1 chan
231231
cr2 = CReq "test" 2 req2 chan
232-
r1 <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr1)
233-
r2 <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr2)
232+
r1 <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr1)
233+
r2 <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch (testPlugins chSync) cr2)
234234
r1 `shouldBe` Nothing
235235
r2 `shouldBe` Nothing
236236
rc1 <- atomically $ readTChan chan

‎test/GhcModPluginSpec.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,7 @@ dispatchRequest :: IdeRequest -> IO (Maybe (IdeResponse Object))
4444
dispatchRequest req = do
4545
testChan <- atomically newTChan
4646
let cr = CReq "ghcmod" 1 req testChan
47-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch testPlugins cr)
47+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch testPlugins cr)
4848
return r
4949

5050
-- ---------------------------------------------------------------------

‎test/HaRePluginSpec.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,7 @@ dispatchRequest :: IdeRequest -> IO (Maybe (IdeResponse Object))
4040
dispatchRequest req = do
4141
testChan <- atomically newTChan
4242
let cr = CReq "hare" 1 req testChan
43-
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch testPlugins cr)
43+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty Map.empty) (doDispatch testPlugins cr)
4444
return r
4545

4646
-- ---------------------------------------------------------------------

0 commit comments

Comments
 (0)