Restore the ghcmod plugin command routing

Certain hie clients expect to be able to executeCommand the ghmod
plugin commands.

Make them available under the "ghcmod" name, routed to the new "generic"
plugin.

app/MainHie.hs

@@ -35,6 +35,7 @@ import           Haskell.Ide.Engine.Plugin.Package
 import           Haskell.Ide.Engine.Plugin.Pragmas
 import           Haskell.Ide.Engine.Plugin.Floskell
 import           Haskell.Ide.Engine.Plugin.Generic
+import           Haskell.Ide.Engine.Plugin.GhcMod
 
 -- ---------------------------------------------------------------------
 
@@ -56,6 +57,7 @@ plugins includeExamples = pluginDescToIdePlugins allPlugins
       , pragmasDescriptor     "pragmas"
       , floskellDescriptor    "floskell"
       , genericDescriptor     "generic"
+      , ghcmodDescriptor      "ghcmod"
       ]
     examplePlugins =
       [example2Descriptor "eg2"

haskell-ide-engine.cabal

@@ -37,6 +37,7 @@ library
                        Haskell.Ide.Engine.Plugin.Package.Compat
                        Haskell.Ide.Engine.Plugin.Pragmas
                        Haskell.Ide.Engine.Plugin.Generic
+                       Haskell.Ide.Engine.Plugin.GhcMod
                        Haskell.Ide.Engine.Scheduler
                        Haskell.Ide.Engine.Support.FromHaRe
                        Haskell.Ide.Engine.Support.Hoogle
@@ -180,6 +181,7 @@ test-suite unit-test
                        DiffSpec
                        ExtensibleStateSpec
                        GenericPluginSpec
+                       GhcModPluginSpec
                        -- HaRePluginSpec
                        HooglePluginSpec
                        JsonSpec

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

@@ -0,0 +1,95 @@
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE TypeFamilies        #-}
+module Haskell.Ide.Engine.Plugin.GhcMod
+  (
+    ghcmodDescriptor
+
+  -- * For tests
+  -- , Bindings(..)
+  -- , FunctionSig(..)
+  -- , TypeDef(..)
+  -- , TypeParams(..)
+  -- , TypedHoles(..) -- only to keep the GHC 8.4 and below unused field warning happy
+  -- , ValidSubstitutions(..)
+  -- , extractHoleSubstitutions
+  -- , extractMissingSignature
+  -- , extractRenamableTerms
+  -- , extractUnusedTerm
+  -- , newTypeCmd
+  -- , symbolProvider
+  , splitCaseCmd
+  ) where
+
+import           Data.Aeson
+import           Data.Monoid ((<>))
+import           GHC.Generics
+import qualified Haskell.Ide.Engine.Ghc as HIE
+import           Haskell.Ide.Engine.MonadTypes
+import qualified Haskell.Ide.Engine.Plugin.Generic as PG
+import qualified Haskell.Ide.Engine.Support.HieExtras as Hie
+
+-- ---------------------------------------------------------------------
+
+ghcmodDescriptor :: PluginId -> PluginDescriptor
+ghcmodDescriptor plId = PluginDescriptor
+  { pluginId = plId
+  , pluginName = "ghc-mod"
+  , pluginDesc = "ghc-mod is a backend program to enrich Haskell programming "
+              <> "in editors. It strives to offer most of the features one has come to expect "
+              <> "from modern IDEs in any editor."
+  , pluginCommands =
+      [
+        -- This one is used in the dispatcher tests, and is a wrapper around what we are already using anyway
+        PluginCommand "check" "check a file for GHC warnings and errors" checkCmd
+
+        -- PluginCommand "info" "Look up an identifier in the context of FILE (like ghci's `:info')" infoCmd
+      , PluginCommand "type" "Get the type of the expression under (LINE,COL)" PG.typeCmd
+
+        -- This one is registered in the vscode plugin, for some reason
+      , PluginCommand "casesplit" "Generate a pattern match for a binding under (LINE,COL)" splitCaseCmd
+      ]
+  , pluginCodeActionProvider = Nothing
+  , pluginDiagnosticProvider = Nothing
+  , pluginHoverProvider = Nothing
+  , pluginSymbolProvider = Nothing
+  , pluginFormattingProvider = Nothing
+  }
+
+-- ---------------------------------------------------------------------
+
+-- checkCmd :: CommandFunc Uri (Diagnostics, AdditionalErrs)
+-- checkCmd = CmdSync setTypecheckedModule
+
+checkCmd :: Uri -> IdeGhcM (IdeResult (HIE.Diagnostics, HIE.AdditionalErrs))
+checkCmd = HIE.setTypecheckedModule
+
+-- ---------------------------------------------------------------------
+
+splitCaseCmd :: Hie.HarePoint -> IdeGhcM (IdeResult WorkspaceEdit)
+splitCaseCmd (Hie.HP _uri _pos)
+  = return (IdeResultFail (IdeError PluginError "splitCaseCmd not implemented" Null))
+
+-- ---------------------------------------------------------------------
+
+customOptions :: Options
+customOptions = defaultOptions { fieldLabelModifier = camelTo2 '_' . drop 2}
+
+-- ---------------------------------------------------------------------
+
+data TypeParams =
+  TP { tpIncludeConstraints :: Bool
+     , tpFile               :: Uri
+     , tpPos                :: Position
+     } deriving (Eq,Show,Generic)
+
+instance FromJSON TypeParams where
+  parseJSON = genericParseJSON customOptions
+instance ToJSON TypeParams where
+  toJSON = genericToJSON customOptions
+
+-- -- ---------------------------------------------------------------------

test/unit/GhcModPluginSpec.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE OverloadedStrings #-}
+module GhcModPluginSpec where
+
+import qualified Data.Map                            as Map
+import qualified Data.Set                            as S
+import qualified Data.Text                           as T
+import           Haskell.Ide.Engine.Ghc
+import           Haskell.Ide.Engine.MonadTypes
+import           Haskell.Ide.Engine.Plugin.Generic
+import           Haskell.Ide.Engine.Plugin.GhcMod
+import           Haskell.Ide.Engine.PluginUtils
+import           Language.Haskell.LSP.Types          ( toNormalizedUri )
+import           System.Directory
+import           TestUtils
+
+import           Test.Hspec
+
+-- ---------------------------------------------------------------------
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+  describe "ghc-mod plugin" ghcmodSpec
+
+-- ---------------------------------------------------------------------
+
+testPlugins :: IdePlugins
+testPlugins = pluginDescToIdePlugins [ghcmodDescriptor "ghcmod"]
+
+-- ---------------------------------------------------------------------
+
+ghcmodSpec :: Spec
+ghcmodSpec =
+  describe "ghc-mod plugin commands(old plugin api)" $ do
+    it "runs the check command" $ withCurrentDirectory "./test/testdata" $ do
+      fp <- makeAbsolute "./FileWithWarning.hs"
+      let act = setTypecheckedModule arg
+          arg = filePathToUri fp
+      IdeResultOk (_,env) <- runSingle testPlugins act
+      case env of
+        [] -> return ()
+        [s] -> T.unpack s `shouldStartWith` "Loaded package environment from"
+        ss -> fail $ "got:" ++ show ss
+      let
+          res = IdeResultOk $
+            (Diagnostics (Map.singleton (toNormalizedUri arg) (S.singleton diag)), env)
+          diag = Diagnostic (Range (toPos (4,7))
+                                   (toPos (4,8)))
+                            (Just DsError)
+                            Nothing
+                            (Just "bios")
+                            "Variable not in scope: x"
+                            Nothing
+
+      testCommand testPlugins act "ghcmod" "check" arg res
+
+
+-- ----------------------------------------------------------------------------
+
+    it "runs the type command, find type" $ withCurrentDirectory "./test/testdata" $ do
+      fp <- makeAbsolute "HaReRename.hs"
+      let uri = filePathToUri fp
+          act = do
+            _ <- setTypecheckedModule uri
+            liftToGhc $ newTypeCmd (toPos (5,9)) uri
+          arg = TP False uri (toPos (5,9))
+          res = IdeResultOk
+            [ (Range (toPos (5,9)) (toPos (5,10)), "Int")
+            , (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int")
+            ]
+
+      testCommand testPlugins act "ghcmod" "type" arg res
+
+
+-- ----------------------------------------------------------------------------
+
+    -- it "runs the casesplit command" $ withCurrentDirectory "./test/testdata" $ do
+    --   fp <- makeAbsolute "GhcModCaseSplit.hs"
+    --   let uri = filePathToUri fp
+    --       act = do
+    --         _ <- setTypecheckedModule uri
+    --         -- splitCaseCmd' uri (toPos (5,5))
+    --         splitCaseCmd uri (toPos (5,5))
+    --       arg = HP uri (toPos (5,5))
+    --       res = IdeResultOk $ WorkspaceEdit
+    --         (Just $ H.singleton uri
+    --                             $ List [TextEdit (Range (Position 4 0) (Position 4 10))
+    --                                       "foo Nothing = ()\nfoo (Just x) = ()"])
+    --         Nothing
+    --   testCommand testPlugins act "ghcmod" "casesplit" arg res