haskell/haskell-ide-engine
1
1
Fork 0
mirror of https://github.com/haskell/haskell-ide-engine.git synced 2024-10-26 11:18:42 +03:00
Code Issues Projects Releases Wiki Activity

CommandName -> CommandId, make that and PluginId newtypes

Browse Source 
We definitely do not want to get those mixed up with plain old texts
This commit is contained in:
Luke Lau 2019-12-22 01:55:50 +00:00
parent 0a347bb57f
commit 7ca12934dd
5 changed files with 38 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs
View File

@ -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

2
src/Haskell/Ide/Engine/Plugin/Package.hs
View File

@ -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]

13
src/Haskell/Ide/Engine/Server.hs
View File

@ -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

2
src/Haskell/Ide/Engine/Support/HieExtras.hs
View File

@ -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)

6
test/utils/TestUtils.hs
View File

@ -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