Refactor plugins and commands now that JSON transport is gone

app/MainHie.hs

@@ -26,7 +26,6 @@ import           System.IO
 import           Haskell.Ide.Engine.Plugin.ApplyRefact
 import           Haskell.Ide.Engine.Plugin.Brittany
 import           Haskell.Ide.Engine.Plugin.Example2
-import           Haskell.Ide.Engine.Plugin.Bios
 -- import           Haskell.Ide.Engine.Plugin.HaRe
 import           Haskell.Ide.Engine.Plugin.Haddock
 import           Haskell.Ide.Engine.Plugin.HfaAlign
@@ -56,7 +55,6 @@ plugins includeExamples = pluginDescToIdePlugins allPlugins
       , packageDescriptor     "package"
       , pragmasDescriptor     "pragmas"
       , floskellDescriptor    "floskell"
-      , biosDescriptor        "bios"
       , genericDescriptor     "generic"
       ]
     examplePlugins =

haskell-ide-engine.cabal

@@ -28,7 +28,6 @@ library
                        Haskell.Ide.Engine.Plugin.Brittany
                        Haskell.Ide.Engine.Plugin.Example2
                        Haskell.Ide.Engine.Plugin.Floskell
-                       Haskell.Ide.Engine.Plugin.Bios
                        -- Haskell.Ide.Engine.Plugin.HaRe
                        Haskell.Ide.Engine.Plugin.Haddock
                        Haskell.Ide.Engine.Plugin.HfaAlign

hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs

@@ -24,12 +24,11 @@ module Haskell.Ide.Engine.PluginsIdeMonads
   , allLspCmdIds
   , mkLspCmdId
   -- * Plugins
-  , PluginId
-  , CommandName
+  , PluginId(..)
+  , CommandId(..)
   , PluginDescriptor(..)
   , pluginDescToIdePlugins
   , PluginCommand(..)
-  , CommandFunc(..)
   , runPluginCommand
   , DynamicJSON
   , dynToJSON
@@ -114,6 +113,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
@@ -176,7 +176,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'
@@ -185,12 +185,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 (PluginId plid) (CommandId cid) = do
   pid <- T.pack . show <$> getPidCache
-  return $ pid <> ":" <> plid <> ":" <> cn
+  return $ pid <> ":" <> plid <> ":" <> cid
 
 -- ---------------------------------------------------------------------
 -- Plugins
@@ -261,6 +261,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
                    , pluginName               :: T.Text
@@ -274,17 +279,17 @@ data PluginDescriptor =
                    } deriving (Generic)
 
 instance Show PluginCommand where
-  show (PluginCommand name _ _) = "PluginCommand { name = " ++ T.unpack name ++ " }"
-
-type PluginId = T.Text
-type CommandName = T.Text
+  show (PluginCommand i _ _) = "PluginCommand { name = " ++ show i ++ " }"
 
-newtype CommandFunc a b = CmdSync (a -> IdeGhcM (IdeResult b))
+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
                 , commandDesc :: T.Text
-                , commandFunc :: CommandFunc a b
+                , commandFunc :: a -> IdeGhcM (IdeResult b)
                 }
 
 pluginDescToIdePlugins :: [PluginDescriptor] -> IdePlugins
@@ -301,21 +306,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
+runPluginCommand p@(PluginId p') com@(CommandId 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 " <> 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
-      Just (PluginCommand _ _ (CmdSync f)) -> case fromJSON arg of
+        IdeError UnknownCommand ("Command " <> com' <> " isn't defined for plugin " <> 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 " <> com' <> " in plugin " <> p' <> ": " <> T.pack err) Null
         Success a -> do
             res <- f a
             return $ fmap toDynJSON res
@@ -325,11 +330,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 (\x -> (commandName x, commandDesc x)) <$> 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
@@ -599,7 +599,7 @@ instance ExceptionMonad m => ExceptionMonad (ReaderT e m) where
           q u (ReaderT b) = ReaderT (u . b)
 
 instance MonadTrans GhcT where
-  lift m = liftGhcT m
+  lift = liftGhcT
 
 
 instance MonadUnliftIO Ghc where

src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs

@@ -2,6 +2,9 @@
 {-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings     #-}
+-- | apply-refact applies refactorings specified by the refact package. It is
+-- currently integrated into hlint to enable the automatic application of
+-- suggestions.
 module Haskell.Ide.Engine.Plugin.ApplyRefact where
 
 import           Control.Arrow
@@ -46,7 +49,6 @@ applyRefactDescriptor plId = PluginDescriptor
   , pluginCommands =
       [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd
       , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd
-      , PluginCommand "lint" "Run hlint on the file to generate hints" lintCmd
       ]
   , pluginCodeActionProvider = Just codeActionProvider
   , pluginDiagnosticProvider = Nothing
@@ -69,12 +71,9 @@ data OneHint = OneHint
   , oneHintTitle :: HintTitle
   } deriving (Eq, Show)
 
-applyOneCmd :: CommandFunc ApplyOneParams WorkspaceEdit
-applyOneCmd = CmdSync $ \(AOP uri pos title) -> do
-  applyOneCmd' uri (OneHint pos title)
-
-applyOneCmd' :: Uri -> OneHint -> IdeGhcM (IdeResult WorkspaceEdit)
-applyOneCmd' uri oneHint = pluginGetFile "applyOne: " uri $ \fp -> do
+applyOneCmd :: ApplyOneParams -> IdeGhcM (IdeResult WorkspaceEdit)
+applyOneCmd (AOP uri pos title) = pluginGetFile "applyOne: " uri $ \fp -> do
+  let oneHint = OneHint pos title
   revMapp <- reverseFileMap
   let defaultResult = do
         debugm "applyOne: no access to the persisted file."
@@ -91,12 +90,8 @@ applyOneCmd' uri oneHint = pluginGetFile "applyOne: " uri $ \fp -> do
 
 -- ---------------------------------------------------------------------
 
-applyAllCmd :: CommandFunc Uri WorkspaceEdit
-applyAllCmd = CmdSync $ \uri -> do
-  applyAllCmd' uri
-
-applyAllCmd' :: Uri -> IdeGhcM (IdeResult WorkspaceEdit)
-applyAllCmd' uri = pluginGetFile "applyAll: " uri $ \fp -> do
+applyAllCmd :: Uri -> IdeGhcM (IdeResult WorkspaceEdit)
+applyAllCmd uri = pluginGetFile "applyAll: " uri $ \fp -> do
   let defaultResult = do
         debugm "applyAll: no access to the persisted file."
         return $ IdeResultOk mempty
@@ -111,26 +106,22 @@ applyAllCmd' uri = pluginGetFile "applyAll: " uri $ \fp -> do
 
 -- ---------------------------------------------------------------------
 
-lintCmd :: CommandFunc Uri PublishDiagnosticsParams
-lintCmd = CmdSync $ \uri -> do
-  lintCmd' uri
-
 -- AZ:TODO: Why is this in IdeGhcM?
-lintCmd' :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams)
-lintCmd' uri = pluginGetFile "lintCmd: " uri $ \fp -> do
+lint :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams)
+lint uri = pluginGetFile "lint: " uri $ \fp -> do
   let
     defaultResult = do
-      debugm "lintCmd: no access to the persisted file."
+      debugm "lint: no access to the persisted file."
       return
         $ IdeResultOk (PublishDiagnosticsParams (filePathToUri fp) $ List [])
   withMappedFile fp defaultResult $ \file' -> do
     eitherErrorResult <- liftIO
-      (try $ runExceptT $ runLintCmd file' [] :: IO
+      (try $ runExceptT $ runLint file' [] :: IO
           (Either IOException (Either [Diagnostic] [Idea]))
       )
     case eitherErrorResult of
       Left err -> return $ IdeResultFail
-        (IdeError PluginError (T.pack $ "lintCmd: " ++ show err) Null)
+        (IdeError PluginError (T.pack $ "lint: " ++ show err) Null)
       Right res -> case res of
         Left diags ->
           return
@@ -143,8 +134,8 @@ lintCmd' uri = pluginGetFile "lintCmd: " uri $ \fp -> do
             $ PublishDiagnosticsParams (filePathToUri fp)
             $ List (map hintToDiagnostic $ stripIgnores fs)
 
-runLintCmd :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea]
-runLintCmd fp args = do
+runLint :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea]
+runLint fp args = do
   (flags,classify,hint) <- liftIO $ argsSettings args
   let myflags = flags { hseFlags = (hseFlags flags) { extensions = EnableExtension TypeApplications:extensions (hseFlags flags)}}
   res <- bimapExceptT parseErrorToDiagnostic id $ ExceptT $ parseModuleEx myflags fp Nothing

src/Haskell/Ide/Engine/Plugin/Brittany.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+-- | Brittany is a tool to format source code.
 module Haskell.Ide.Engine.Plugin.Brittany where
 
 import           Control.Lens

src/Haskell/Ide/Engine/Plugin/Example2.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
+-- | An example of writing an HIE plugin
 module Haskell.Ide.Engine.Plugin.Example2 where
 
 import           Control.Lens
@@ -25,8 +26,8 @@ example2Descriptor plId = PluginDescriptor
   , pluginName = "Hello World"
   , pluginDesc = "An example of writing an HIE plugin"
   , pluginCommands =
-      [ PluginCommand "sayHello" "say hello" sayHelloCmd
-      , PluginCommand "sayHelloTo ""say hello to the passed in param" sayHelloToCmd
+      [ PluginCommand "sayHello" "Say hello" sayHelloCmd
+      , PluginCommand "sayHelloTo" "Say hello to the passed in param" sayHelloToCmd
       , PluginCommand "todo" "Add a TODO marker" todoCmd
       ]
   , pluginCodeActionProvider = Just codeActionProvider
@@ -39,11 +40,11 @@ example2Descriptor plId = PluginDescriptor
 
 -- ---------------------------------------------------------------------
 
-sayHelloCmd :: CommandFunc () T.Text
-sayHelloCmd = CmdSync $ \_ -> return (IdeResultOk sayHello)
+sayHelloCmd :: () -> IdeGhcM (IdeResult T.Text)
+sayHelloCmd () = return (IdeResultOk sayHello)
 
-sayHelloToCmd :: CommandFunc T.Text T.Text
-sayHelloToCmd = CmdSync $ \n -> do
+sayHelloToCmd :: T.Text -> IdeGhcM (IdeResult T.Text)
+sayHelloToCmd n = do
   r <- liftIO $ sayHelloTo n
   return $ IdeResultOk r
 
@@ -78,8 +79,8 @@ data TodoParams = TodoParams
   }
   deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
 
-todoCmd :: CommandFunc TodoParams J.WorkspaceEdit
-todoCmd = CmdSync $ \(TodoParams uri r) -> return $ IdeResultOk $ makeTodo uri r
+todoCmd :: TodoParams -> IdeGhcM (IdeResult J.WorkspaceEdit)
+todoCmd (TodoParams uri r) = return $ IdeResultOk $ makeTodo uri r
 
 makeTodo :: J.Uri -> J.Range -> J.WorkspaceEdit
 makeTodo uri (J.Range (J.Position startLine _) _) = res

src/Haskell/Ide/Engine/Plugin/Floskell.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 
+-- | A flexible Haskell source code pretty printer.
 module Haskell.Ide.Engine.Plugin.Floskell
   ( floskellDescriptor
   )

src/Haskell/Ide/Engine/Plugin/Generic.hs

@@ -5,7 +5,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections       #-}
 {-# LANGUAGE TypeFamilies        #-}
--- Generic actions which require a typechecked module
+-- | Generic actions which require a typechecked module
 module Haskell.Ide.Engine.Plugin.Generic where
 
 import           Control.Lens hiding (cons, children)
@@ -44,7 +44,7 @@ genericDescriptor :: PluginId -> PluginDescriptor
 genericDescriptor plId = PluginDescriptor
   { pluginId = plId
   , pluginName = "generic"
-  , pluginDesc = "generic actions"
+  , pluginDesc = "Generic actions which require a typechecked module."
   , pluginCommands = [PluginCommand "type" "Get the type of the expression under (LINE,COL)" typeCmd]
   , pluginCodeActionProvider = Just codeActionProvider
   , pluginDiagnosticProvider = Nothing
@@ -66,15 +66,14 @@ instance FromJSON TypeParams where
 instance ToJSON TypeParams where
   toJSON = genericToJSON customOptions
 
-typeCmd :: CommandFunc TypeParams [(Range,T.Text)]
-typeCmd = CmdSync $ \(TP _bool uri pos) ->
-  liftToGhc $ newTypeCmd pos uri
+typeCmd :: TypeParams -> IdeGhcM (IdeResult [(Range,T.Text)])
+typeCmd (TP _bool uri pos) = liftToGhc $ newTypeCmd pos uri
 
 newTypeCmd :: Position -> Uri -> IdeM (IdeResult [(Range, T.Text)])
 newTypeCmd newPos uri =
   pluginGetFile "newTypeCmd: " uri $ \fp ->
     ifCachedModule fp (IdeResultOk []) $ \tm info -> do
-      debugm $ "newTypeCmd: " <> (show (newPos, uri))
+      debugm $ "newTypeCmd: " <> show (newPos, uri)
       return $ IdeResultOk $ pureTypeCmd newPos tm info
 
 pureTypeCmd :: Position -> GHC.TypecheckedModule -> CachedInfo -> [(Range,T.Text)]