Merge pull request #1505 from alanz/ghc-mod-plugin-proxy

Restore the ghcmod plugin command routing

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