mirror of
https://github.com/haskell/haskell-ide-engine.git
synced 2024-10-26 11:18:42 +03:00
CommandName -> CommandId, make that and PluginId newtypes
We definitely do not want to get those mixed up with plain old texts
This commit is contained in:
parent
0a347bb57f
commit
7ca12934dd
@ -24,8 +24,8 @@ module Haskell.Ide.Engine.PluginsIdeMonads
|
||||
, allLspCmdIds
|
||||
, mkLspCmdId
|
||||
-- * Plugins
|
||||
, PluginId
|
||||
, CommandName
|
||||
, PluginId(..)
|
||||
, CommandId(..)
|
||||
, PluginDescriptor(..)
|
||||
, pluginDescToIdePlugins
|
||||
, PluginCommand(..)
|
||||
@ -105,6 +105,7 @@ import UnliftIO
|
||||
import Control.Applicative
|
||||
|
||||
import Data.Aeson hiding (defaultOptions)
|
||||
import Data.Coerce
|
||||
import qualified Data.ConstrainedDynamic as CD
|
||||
import Data.Default
|
||||
import qualified Data.List as List
|
||||
@ -113,6 +114,7 @@ import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
import Data.Monoid ( (<>) )
|
||||
import qualified Data.Set as S
|
||||
import Data.String
|
||||
import qualified Data.Text as T
|
||||
import Data.Typeable ( TypeRep
|
||||
, Typeable
|
||||
@ -175,7 +177,7 @@ instance HasPidCache IO where
|
||||
instance HasPidCache m => HasPidCache (IdeResultT m) where
|
||||
getPidCache = lift getPidCache
|
||||
|
||||
mkLspCommand :: HasPidCache m => PluginId -> CommandName -> T.Text -> Maybe [Value] -> m Command
|
||||
mkLspCommand :: HasPidCache m => PluginId -> CommandId -> T.Text -> Maybe [Value] -> m Command
|
||||
mkLspCommand plid cn title args' = do
|
||||
cmdId <- mkLspCmdId plid cn
|
||||
let args = List <$> args'
|
||||
@ -184,12 +186,12 @@ mkLspCommand plid cn title args' = do
|
||||
allLspCmdIds :: HasPidCache m => IdePlugins -> m [T.Text]
|
||||
allLspCmdIds (IdePlugins m) = concat <$> mapM go (Map.toList (pluginCommands <$> m))
|
||||
where
|
||||
go (plid, cmds) = mapM (mkLspCmdId plid . commandName) cmds
|
||||
go (plid, cmds) = mapM (mkLspCmdId plid . commandId) cmds
|
||||
|
||||
mkLspCmdId :: HasPidCache m => PluginId -> CommandName -> m T.Text
|
||||
mkLspCmdId plid cn = do
|
||||
mkLspCmdId :: HasPidCache m => PluginId -> CommandId -> m T.Text
|
||||
mkLspCmdId plid cid = do
|
||||
pid <- T.pack . show <$> getPidCache
|
||||
return $ pid <> ":" <> plid <> ":" <> cn
|
||||
return $ pid <> ":" <> coerce plid <> ":" <> coerce cid
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- Plugins
|
||||
@ -260,6 +262,11 @@ type FormattingProvider = T.Text -- ^ Text to format
|
||||
-> FormattingOptions -- ^ Options for the formatter
|
||||
-> IdeM (IdeResult [TextEdit]) -- ^ Result of the formatting or the unchanged text.
|
||||
|
||||
newtype PluginId = PluginId T.Text
|
||||
deriving (Show, Read, Eq, Ord)
|
||||
instance IsString PluginId where
|
||||
fromString = PluginId . T.pack
|
||||
|
||||
data PluginDescriptor =
|
||||
PluginDescriptor { pluginId :: PluginId
|
||||
, pluginCommands :: [PluginCommand]
|
||||
@ -271,13 +278,15 @@ data PluginDescriptor =
|
||||
} deriving (Generic)
|
||||
|
||||
instance Show PluginCommand where
|
||||
show (PluginCommand name _) = "PluginCommand { name = " ++ T.unpack name ++ " }"
|
||||
show (PluginCommand i _) = "PluginCommand { name = " ++ show i ++ " }"
|
||||
|
||||
type PluginId = T.Text
|
||||
type CommandName = T.Text
|
||||
newtype CommandId = CommandId T.Text
|
||||
deriving (Show, Read, Eq, Ord)
|
||||
instance IsString CommandId where
|
||||
fromString = CommandId . T.pack
|
||||
|
||||
data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) =>
|
||||
PluginCommand { commandName :: CommandName
|
||||
PluginCommand { commandId :: CommandId
|
||||
, commandFunc :: a -> IdeGhcM (IdeResult b)
|
||||
}
|
||||
|
||||
@ -295,21 +304,21 @@ fromDynJSON = CD.fromDynamic
|
||||
toDynJSON :: (Typeable a, ToJSON a) => a -> DynamicJSON
|
||||
toDynJSON = CD.toDyn
|
||||
|
||||
-- | Runs a plugin command given a PluginId, CommandName and
|
||||
-- | Runs a plugin command given a PluginId, CommandId and
|
||||
-- arguments in the form of a JSON object.
|
||||
runPluginCommand :: PluginId -> CommandName -> Value
|
||||
runPluginCommand :: PluginId -> CommandId -> Value
|
||||
-> IdeGhcM (IdeResult DynamicJSON)
|
||||
runPluginCommand p com arg = do
|
||||
IdePlugins m <- getPlugins
|
||||
case Map.lookup p m of
|
||||
Nothing -> return $
|
||||
IdeResultFail $ IdeError UnknownPlugin ("Plugin " <> p <> " doesn't exist") Null
|
||||
Just PluginDescriptor { pluginCommands = xs } -> case List.find ((com ==) . commandName) xs of
|
||||
IdeResultFail $ IdeError UnknownPlugin ("Plugin " <> coerce p <> " doesn't exist") Null
|
||||
Just PluginDescriptor { pluginCommands = xs } -> case List.find ((com ==) . commandId) xs of
|
||||
Nothing -> return $ IdeResultFail $
|
||||
IdeError UnknownCommand ("Command " <> com <> " isn't defined for plugin " <> p <> ". Legal commands are: " <> T.pack(show $ map commandName xs)) Null
|
||||
IdeError UnknownCommand ("Command " <> coerce com <> " isn't defined for plugin " <> coerce p <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Null
|
||||
Just (PluginCommand _ f) -> case fromJSON arg of
|
||||
Error err -> return $ IdeResultFail $
|
||||
IdeError ParameterError ("error while parsing args for " <> com <> " in plugin " <> p <> ": " <> T.pack err) Null
|
||||
IdeError ParameterError ("error while parsing args for " <> coerce com <> " in plugin " <> coerce p <> ": " <> T.pack err) Null
|
||||
Success a -> do
|
||||
res <- f a
|
||||
return $ fmap toDynJSON res
|
||||
@ -319,11 +328,6 @@ newtype IdePlugins = IdePlugins
|
||||
{ ipMap :: Map.Map PluginId PluginDescriptor
|
||||
} deriving (Generic)
|
||||
|
||||
-- TODO:AZ this is a defective instance, do we actually need it?
|
||||
-- Perhaps rather make a separate type explicitly for this purpose.
|
||||
instance ToJSON IdePlugins where
|
||||
toJSON (IdePlugins m) = toJSON $ fmap commandName <$> fmap pluginCommands m
|
||||
|
||||
-- | For the diagnostic providers in the config, return a map of
|
||||
-- current enabled state, indexed by the plugin id.
|
||||
getDiagnosticProvidersConfig :: Config -> Map.Map PluginId Bool
|
||||
|
@ -50,7 +50,7 @@ import Distribution.Types.CondTree
|
||||
import qualified Distribution.PackageDescription.PrettyPrint as PP
|
||||
import qualified Data.Yaml as Y
|
||||
|
||||
packageDescriptor :: T.Text -> PluginDescriptor
|
||||
packageDescriptor :: PluginId -> PluginDescriptor
|
||||
packageDescriptor plId = PluginDescriptor
|
||||
{ pluginId = plId
|
||||
, pluginCommands = [PluginCommand "add" addCmd]
|
||||
|
@ -558,10 +558,10 @@ reactor inp diagIn = do
|
||||
|
||||
let params = req ^. J.params
|
||||
|
||||
parseCmdId :: T.Text -> Maybe (T.Text, T.Text)
|
||||
parseCmdId :: T.Text -> Maybe (PluginId, CommandId)
|
||||
parseCmdId x = case T.splitOn ":" x of
|
||||
[plugin, command] -> Just (plugin, command)
|
||||
[_, plugin, command] -> Just (plugin, command)
|
||||
[plugin, command] -> Just (PluginId plugin, CommandId command)
|
||||
[_, plugin, command] -> Just (PluginId plugin, CommandId command)
|
||||
_ -> Nothing
|
||||
|
||||
callback obj = do
|
||||
@ -854,22 +854,23 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer
|
||||
forM_ dss $ \(pid,ds) -> do
|
||||
debugm $ "requestDiagnostics: calling diagFunc for plugin:" ++ show pid
|
||||
let
|
||||
pid' = coerce pid
|
||||
enabled = Map.findWithDefault True pid dpsEnabled
|
||||
publishDiagnosticsIO = Core.publishDiagnosticsFunc lf
|
||||
maxToSend = maxNumberOfProblems clientConfig
|
||||
sendOne (fileUri,ds') = do
|
||||
debugm $ "LspStdio.sendone:(fileUri,ds')=" ++ show(fileUri,ds')
|
||||
publishDiagnosticsIO maxToSend (J.toNormalizedUri fileUri) Nothing (Map.fromList [(Just pid,SL.toSortedList ds')])
|
||||
publishDiagnosticsIO maxToSend (J.toNormalizedUri fileUri) Nothing (Map.fromList [(Just pid',SL.toSortedList ds')])
|
||||
|
||||
sendEmpty = do
|
||||
debugm "LspStdio.sendempty"
|
||||
publishDiagnosticsIO maxToSend (J.toNormalizedUri file) Nothing (Map.fromList [(Just pid,SL.toSortedList [])])
|
||||
publishDiagnosticsIO maxToSend (J.toNormalizedUri file) Nothing (Map.fromList [(Just pid',SL.toSortedList [])])
|
||||
|
||||
-- fv = case documentVersion of
|
||||
-- Nothing -> Nothing
|
||||
-- Just v -> Just (file,v)
|
||||
-- let fakeId = J.IdString "fake,remove" -- TODO:AZ: IReq should take a Maybe LspId
|
||||
let fakeId = J.IdString ("fake,remove:pid=" <> pid) -- TODO:AZ: IReq should take a Maybe LspId
|
||||
let fakeId = J.IdString ("fake,remove:pid=" <> pid') -- TODO:AZ: IReq should take a Maybe LspId
|
||||
let reql = case ds of
|
||||
DiagnosticProviderSync dps ->
|
||||
IReq trackingNumber "diagnostics" fakeId callbackl
|
||||
|
@ -436,7 +436,7 @@ splitCaseCmd' uri newPos =
|
||||
getFormattingPlugin :: Config -> IdePlugins -> Maybe (PluginDescriptor, FormattingProvider)
|
||||
getFormattingPlugin config plugins = do
|
||||
let providerName = formattingProvider config
|
||||
fmtPlugin <- Map.lookup providerName (ipMap plugins)
|
||||
fmtPlugin <- Map.lookup (PluginId providerName) (ipMap plugins)
|
||||
fmtProvider <- pluginFormattingProvider fmtPlugin
|
||||
return (fmtPlugin, fmtProvider)
|
||||
|
||||
|
@ -51,7 +51,7 @@ testOptions = HIE.defaultOptions { cradleOptsVerbosity = Verbose }
|
||||
|
||||
|
||||
testCommand :: (ToJSON a, Typeable b, ToJSON b, Show b, Eq b)
|
||||
=> IdePlugins -> IdeGhcM (IdeResult b) -> PluginId -> CommandName -> a -> IdeResult b -> IO ()
|
||||
=> IdePlugins -> IdeGhcM (IdeResult b) -> PluginId -> CommandId -> a -> IdeResult b -> IO ()
|
||||
testCommand testPlugins act plugin cmd arg res = do
|
||||
flushStackEnvironment
|
||||
(newApiRes, oldApiRes) <- runIGM testPlugins $ do
|
||||
@ -65,10 +65,10 @@ runSingle :: IdePlugins -> IdeGhcM (IdeResult b) -> IO (IdeResult b)
|
||||
runSingle testPlugins act = runIGM testPlugins act
|
||||
|
||||
runSingleReq :: ToJSON a
|
||||
=> IdePlugins -> PluginId -> CommandName -> a -> IO (IdeResult DynamicJSON)
|
||||
=> IdePlugins -> PluginId -> CommandId -> a -> IO (IdeResult DynamicJSON)
|
||||
runSingleReq testPlugins plugin com arg = runIGM testPlugins (makeRequest plugin com arg)
|
||||
|
||||
makeRequest :: ToJSON a => PluginId -> CommandName -> a -> IdeGhcM (IdeResult DynamicJSON)
|
||||
makeRequest :: ToJSON a => PluginId -> CommandId -> a -> IdeGhcM (IdeResult DynamicJSON)
|
||||
makeRequest plugin com arg = runPluginCommand plugin com (toJSON arg)
|
||||
|
||||
runIGM :: IdePlugins -> IdeGhcM a -> IO a
|
||||
|
Loading…
Reference in New Issue
Block a user