1- {-# LANGUAGE PolyKinds #-}
2- {-# LANGUAGE TypeOperators #-}
3- {-# LANGUAGE GADTs #-}
41{-# LANGUAGE DataKinds #-}
5- {-# LANGUAGE KindSignatures #-}
6- {-# LANGUAGE OverloadedStrings #-}
2+ {-# LANGUAGE DeriveFunctor #-}
73{-# LANGUAGE DeriveGeneric #-}
8- {-# LANGUAGE TypeSynonymInstances #-}
94{-# LANGUAGE FlexibleInstances #-}
10- {-# LANGUAGE RankNTypes #-}
11- {-# LANGUAGE StandaloneDeriving #-}
5+ {-# LANGUAGE GADTs #-}
6+ {-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+ {-# LANGUAGE KindSignatures #-}
8+ {-# LANGUAGE MultiParamTypeClasses #-}
9+ {-# LANGUAGE OverloadedStrings #-}
1210{-# LANGUAGE PatternSynonyms #-}
11+ {-# LANGUAGE PolyKinds #-}
12+ {-# LANGUAGE RankNTypes #-}
1313{-# LANGUAGE ScopedTypeVariables #-}
14+ {-# LANGUAGE StandaloneDeriving #-}
15+ {-# LANGUAGE TypeOperators #-}
16+ {-# LANGUAGE TypeSynonymInstances #-}
1417-- | Experimenting with a data structure to define a plugin.
1518--
1619-- The general idea is that a given plugin returns this structure during the
2730-- shared resource management, e.g. default Calendar app, default SMS app,
2831-- all making use of Contacts service.
2932
30- module Haskell.Ide.Engine.PluginDescriptor where
33+ module Haskell.Ide.Engine.PluginDescriptor
34+ (
35+ PluginDescriptor (.. )
36+ , Service (.. )
37+ , AcceptedContext (.. )
38+ , CabalSection (.. )
39+ , contextMapping
40+
41+ , fileParam
42+ , startPosParam
43+ , endPosParam
44+ , cabalParam
45+
46+ -- * Parameters
47+ , ParamDescription (.. )
48+ , ParamHelp
49+ , ParamName
50+ , ParamType (.. )
51+ , ParamVal (.. )
52+ , ParamValP (.. )
53+ , ParamMap
54+ , pattern ParamTextP
55+ , pattern ParamFileP
56+ , pattern ParamPosP
57+ , ParamId
58+ , TaggedParamId (.. )
59+
60+ -- * Commands
61+ , CommandDescriptor (.. )
62+ , Command (.. )
63+ , CommandFunc (.. ), SyncCommandFunc , AsyncCommandFunc
64+ , CommandName
65+ , PluginName
66+ , ExtendedCommandDescriptor (.. )
67+ , buildCommand
68+ , ValidResponse (.. )
69+
70+ -- * Interface types
71+ , IdeRequest (.. )
72+ , IdeResponse (.. )
73+ , IdeError (.. )
74+ , IdeErrorCode (.. )
75+
76+ , Pos
77+ , posToJSON
78+ , jsonToPos
79+
80+ -- * Plugins
81+ , Plugins
82+ , PluginId
83+ , IdePlugins (.. )
84+
85+ -- * The IDE monad
86+ , IdeM (.. )
87+ , IdeState (.. )
88+ , HasIdeState (.. )
89+ ) where
90+
91+ import qualified DynFlags as GHC
92+ import qualified GHC as GHC
93+ import qualified HscTypes as GHC
3194
3295import Control.Applicative
33- import Control.Monad
34- import Control.Monad.IO.Class
3596import Data.Aeson
3697import Data.Aeson.Types
3798import qualified Data.Map as Map
3899import Data.Maybe
39100import qualified Data.HashMap.Strict as H
40101import qualified Data.Text as T
41102import Data.Typeable
42- import qualified GHC
103+ import Control.Monad.IO.Class
104+ import Control.Monad.State
105+ import Control.Monad.Trans.Control ( control , liftBaseOp , liftBaseOp_ )
106+ import Exception
43107import GHC.Generics
44-
108+ import qualified Language.Haskell.GhcMod.Monad as GM
45109
46110-- ---------------------------------------------------------------------
47111
@@ -113,8 +177,8 @@ data ExtendedCommandDescriptor =
113177
114178-- | Subset type extracted from 'Plugins' to be sent to the IDE as
115179-- a description of the available commands
116- data IdePlugins = IdePlugins {
117- ipMap :: Map. Map PluginId [CommandDescriptor ]
180+ data IdePlugins = IdePlugins
181+ { ipMap :: Map. Map PluginId [CommandDescriptor ]
118182 } deriving (Show ,Eq ,Generic )
119183
120184-- | Define what context will be accepted from the frontend for the specific
@@ -131,7 +195,9 @@ data AcceptedContext
131195type Pos = (Int ,Int )
132196
133197-- | It will simplify things to always work with an absolute file path
134- type AbsFilePath = FilePath
198+
199+ -- AZ:TODO: reinstate this
200+ -- type AbsFilePath = FilePath
135201
136202data CabalSection = CabalSection T. Text deriving (Show ,Eq ,Generic )
137203
@@ -279,12 +345,6 @@ data IdeError = IdeError
279345 }
280346 deriving (Show ,Read ,Eq ,Generic )
281347
282- class (Monad m ) => HasIdeState m where
283- getPlugins :: m Plugins
284- -- | Set up an underlying GHC session for the specific targets. Should map
285- -- down to ghc-mod setTargets.
286- setTargets :: [FilePath ] -> m ()
287-
288348-- | The 'CommandFunc' is called once the dispatcher has checked that it
289349-- satisfies at least one of the `AcceptedContext` values for the command
290350-- descriptor, and has all the required parameters. Where a command has only one
@@ -295,11 +355,11 @@ data CommandFunc resp = CmdSync (SyncCommandFunc resp)
295355 -- ^ Note: does not forkIO, the command must decide when
296356 -- to do this.
297357
298- type SyncCommandFunc resp = forall m . ( MonadIO m , GHC. GhcMonad m , HasIdeState m )
299- = > [AcceptedContext ] -> IdeRequest -> m (IdeResponse resp )
358+ type SyncCommandFunc resp
359+ = [AcceptedContext ] -> IdeRequest -> IdeM (IdeResponse resp )
300360
301- type AsyncCommandFunc resp = forall m . ( MonadIO m , GHC. GhcMonad m , HasIdeState m )
302- = > ( IdeResponse resp -> IO () ) -> [AcceptedContext ] -> IdeRequest -> m ()
361+ type AsyncCommandFunc resp = ( IdeResponse resp -> IO () )
362+ -> [AcceptedContext ] -> IdeRequest -> IdeM ()
303363
304364-- ---------------------------------------------------------------------
305365-- ValidResponse instances
@@ -535,4 +595,58 @@ instance (ValidResponse a) => FromJSON (IdeResponse a) where
535595 return $ fromJust $ mf <|> me <|> mo
536596 parseJSON _ = empty
537597
598+ -- ---------------------------------------------------------------------
599+
600+ newtype IdeM a = IdeM { unIdeM :: GM. GhcModT (GM. GmOutT (StateT IdeState IO )) a }
601+ deriving ( Functor
602+ , Applicative
603+ , Alternative
604+ , Monad
605+ , MonadPlus
606+ , MonadIO
607+ , GM.GmEnv
608+ , GM.GmOut
609+ , GM.MonadIO
610+ , ExceptionMonad
611+ )
612+
613+ data IdeState = IdeState
614+ {
615+ idePlugins :: Plugins
616+ } deriving (Show )
617+
618+ class (Monad m ) => HasIdeState m where
619+ getPlugins :: m Plugins
620+ -- | Set up an underlying GHC session for the specific targets. Should map
621+ -- down to ghc-mod setTargets.
622+ setTargets :: [FilePath ] -> m ()
623+
624+ -- ---------------------------------------------------------------------
625+
626+ instance GM. MonadIO (StateT IdeState IO ) where
627+ liftIO = liftIO
628+
629+ instance MonadState IdeState IdeM where
630+ get = IdeM (lift $ lift $ lift get)
631+ put s = IdeM (lift $ lift $ lift (put s))
632+
633+ instance GHC. GhcMonad IdeM where
634+ getSession = IdeM $ GM. unGmlT GM. gmlGetSession
635+ setSession env = IdeM $ GM. unGmlT (GM. gmlSetSession env)
636+
637+ instance GHC. HasDynFlags IdeM where
638+ getDynFlags = GHC. hsc_dflags <$> GHC. getSession
639+
640+ instance ExceptionMonad (StateT IdeState IO ) where
641+ gcatch act handler = control $ \ run ->
642+ run act `gcatch` (run . handler)
643+
644+ gmask = liftBaseOp gmask . liftRestore
645+ where liftRestore f r = f $ liftBaseOp_ r
646+
647+ -- AZ:TODO: These can become just MonadFunctions
648+ instance HasIdeState IdeM where
649+ getPlugins = gets idePlugins
650+ setTargets targets = IdeM $ GM. runGmlT (map Left targets) (return () )
651+
538652-- EOF
0 commit comments