From 9ebaf037a235a3a94d8f499144bf16053750432c Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 28 Dec 2019 21:19:45 +0000 Subject: [PATCH] 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 | 2 + haskell-ide-engine.cabal | 2 + src/Haskell/Ide/Engine/Plugin/GhcMod.hs | 95 +++++++++++++++++++++++++ test/unit/GhcModPluginSpec.hs | 93 ++++++++++++++++++++++++ 4 files changed, 192 insertions(+) create mode 100644 src/Haskell/Ide/Engine/Plugin/GhcMod.hs create mode 100644 test/unit/GhcModPluginSpec.hs diff --git a/app/MainHie.hs b/app/MainHie.hs index dd7833567..ca851d635 100644 --- a/app/MainHie.hs +++ b/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" diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index a229137fa..32d713f48 100644 --- a/haskell-ide-engine.cabal +++ b/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 diff --git a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs new file mode 100644 index 000000000..b73a4bb07 --- /dev/null +++ b/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 + +-- -- --------------------------------------------------------------------- diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs new file mode 100644 index 000000000..93d229fdd --- /dev/null +++ b/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