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