diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index fdd9609a..f184e236 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -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 diff --git a/src/Haskell/Ide/Engine/Plugin/Package.hs b/src/Haskell/Ide/Engine/Plugin/Package.hs index be578b80..d12c46b4 100644 --- a/src/Haskell/Ide/Engine/Plugin/Package.hs +++ b/src/Haskell/Ide/Engine/Plugin/Package.hs @@ -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] diff --git a/src/Haskell/Ide/Engine/Server.hs b/src/Haskell/Ide/Engine/Server.hs index e6f8fa20..2a23f44e 100644 --- a/src/Haskell/Ide/Engine/Server.hs +++ b/src/Haskell/Ide/Engine/Server.hs @@ -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 diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index 446441cf..b0387600 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -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) diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index ee7ebe0c..b1edb382 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -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