diff --git a/cabal.project b/cabal.project index 2a2ee425a6..338307994b 100644 --- a/cabal.project +++ b/cabal.project @@ -34,6 +34,7 @@ packages: ./plugins/hls-gadt-plugin ./plugins/hls-explicit-fixity-plugin ./plugins/hls-refactor-plugin + ./plugins/hls-diagrams-plugin -- Standard location for temporary packages needed for particular environments -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 72313a4661..cebe594a13 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -60,6 +60,7 @@ module Development.IDE.Core.Rules( GhcSessionDepsConfig(..), Log(..), DisplayTHWarning(..), + currentLinkables, ) where #if !MIN_VERSION_ghc(8,8,0) @@ -159,6 +160,7 @@ import qualified Development.IDE.Types.Shake as Shake import Development.IDE.GHC.CoreFile import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Control.Monad.IO.Unlift +import Debug.Trace #if MIN_VERSION_ghc(9,3,0) import GHC.Unit.Module.Graph import GHC.Unit.Env diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index d6a63b16a1..a1f7880141 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -195,6 +195,11 @@ flag refactor default: True manual: True +flag diagrams + description: Enable diagrams plugin + default: True + manual: True + flag dynamic description: Build with the dyn rts default: True @@ -271,7 +276,7 @@ common splice cpp-options: -Dhls_splice common alternateNumberFormat - if flag(alternateNumberFormat) + if flag(alternateNumberFormat) build-depends: hls-alternate-number-format-plugin ^>= 1.2 cpp-options: -Dhls_alternateNumberFormat @@ -332,6 +337,11 @@ common refactor build-depends: hls-refactor-plugin ^>= 1.0 cpp-options: -Dhls_refactor +common diagrams + if flag(diagrams) + build-depends: hls-diagrams-plugin >= 1.0 + cpp-options: -Dhls_diagrams + library import: common-deps -- configuration @@ -364,6 +374,7 @@ library , stylishHaskell , brittany , refactor + , diagrams exposed-modules: Ide.Arguments diff --git a/plugins/hls-diagrams-plugin/CHANGELOG.md b/plugins/hls-diagrams-plugin/CHANGELOG.md new file mode 100644 index 0000000000..64c87c98cb --- /dev/null +++ b/plugins/hls-diagrams-plugin/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hls-diagrams-plugin + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/plugins/hls-diagrams-plugin/LICENSE b/plugins/hls-diagrams-plugin/LICENSE new file mode 100644 index 0000000000..38f99dd5ef --- /dev/null +++ b/plugins/hls-diagrams-plugin/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2022, Edsko de Vries + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Edsko de Vries nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/plugins/hls-diagrams-plugin/hls-diagrams-plugin.cabal b/plugins/hls-diagrams-plugin/hls-diagrams-plugin.cabal new file mode 100644 index 0000000000..03f0abf39c --- /dev/null +++ b/plugins/hls-diagrams-plugin/hls-diagrams-plugin.cabal @@ -0,0 +1,72 @@ +cabal-version: 3.0 +name: hls-diagrams-plugin +version: 1.0 +license: BSD-3-Clause +license-file: LICENSE +author: Edsko de Vries +maintainer: edsko@well-typed.com +category: Development +build-type: Simple +extra-doc-files: CHANGELOG.md + +common lang + ghc-options: + -Wall + -Wredundant-constraints + build-depends: + base >= 4.12.0.0 + default-language: + Haskell2010 + default-extensions: + DataKinds + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DuplicateRecordFields + EmptyDataDeriving + FlexibleInstances + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + UndecidableInstances + +library + import: + lang + exposed-modules: + Ide.Plugin.Diagrams + other-modules: + Ide.Plugin.Diagrams.CatchErrors + hs-source-dirs: + src + build-depends: + containers + , deepseq + , exceptions + , ghc + , ghc-boot-th + , ghcide + , hashable + , hls-eval-plugin + , hls-plugin-api + , lsp + , lsp-types + , mmorph + , mtl + , temporary + , text + , time + , unliftio-core + + -- Only necessary for the example + -- TODO: Remove + , diagrams-svg + , diagrams-lib \ No newline at end of file diff --git a/plugins/hls-diagrams-plugin/src/Ide/Plugin/Diagrams.hs b/plugins/hls-diagrams-plugin/src/Ide/Plugin/Diagrams.hs new file mode 100644 index 0000000000..5a31341bb1 --- /dev/null +++ b/plugins/hls-diagrams-plugin/src/Ide/Plugin/Diagrams.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ide.Plugin.Diagrams (descriptor) where + +import Prelude hiding (mod) + +import Control.DeepSeq +import Control.Monad.Except +import Control.Monad.IO.Unlift +import Data.Hashable +import Data.List (intercalate) +import Data.List (isPrefixOf) +import Data.Maybe (mapMaybe) +import Data.String +import Data.Text (Text) +import Data.Time (UTCTime) +import Diagrams.Backend.SVG (B) +import Diagrams.Prelude (Diagram) +import GHC.Generics (Generic) +import System.IO.Temp + +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Diagrams.Prelude as D + +import Development.IDE.Core.Rules (IdeState) +import Development.IDE.GHC.Compat (HscEnv, Name, ModSummary, DynFlags, ModuleName, GhcMonad) +import Development.IDE.Types.Logger +import Language.LSP.Server (MonadLsp) + +import qualified Development.IDE as IDE +import qualified Development.IDE.Core.Compile as IDE +import qualified Development.IDE.Core.FileStore as IDE +import qualified Development.IDE.Core.Rules as IDE +import qualified Development.IDE.GHC.Compat as IDE +import qualified Development.IDE.Import.DependencyInformation as IDE +import qualified Development.IDE.Spans.AtPoint as IDE +import qualified Development.IDE.GHC.Compat as GHC +import qualified Development.IDE.GHC.Util as GHC +import qualified Development.IDE.Core.Shake as Shake +import qualified Development.IDE.Types.Shake as Shake + +import qualified Ide.Types as HLS +import qualified Ide.Plugin.Eval.Rules as Eval + +import qualified Language.LSP.Types as LSP + +-- TODO: The GHC.NoCompat imports will not work across multiple ghc versions +import qualified GHC as GHC.NoCompat +import qualified GHC.LanguageExtensions.Type as GHC.NoCompat + +import Ide.Plugin.Diagrams.CatchErrors + +descriptor :: + Recorder (WithPriority Log) + -> HLS.PluginId + -> HLS.PluginDescriptor IdeState +descriptor recorder pluginId = (HLS.defaultPluginDescriptor pluginId) { + HLS.pluginRules = rules recorder + , HLS.pluginHandlers = HLS.mkPluginHandler LSP.STextDocumentHover $ + handleHover recorder + } + +{------------------------------------------------------------------------------- + Logging +-------------------------------------------------------------------------------} + +data Log = + LogShake Shake.Log + | HoverOver [(Name, IDE.Type)] + | CreatedTempDir FilePath + | RenderedDiagram FilePath + | RenderingFailed + +instance Pretty Log where + pretty (LogShake l) = pretty l + pretty (HoverOver ids) = "hovering over" <+> pretty ids + pretty (CreatedTempDir fp) = "created temp dir" <+> pretty fp + pretty (RenderedDiagram fp) = "rendered diagram" <+> pretty fp + pretty RenderingFailed = "rendering failed" + +instance Pretty Name where + pretty = fromString . IDE.printWithoutUniques + +instance Pretty GHC.Type where + pretty = fromString . IDE.printWithoutUniques + +{------------------------------------------------------------------------------- + Plugin state + + TODO: Exit termination handler (to remove the temp dir again) +-------------------------------------------------------------------------------} + +data DiagramsTempDir = DiagramsTempDir + deriving stock (Show, Eq, Generic) + deriving anyclass (Hashable, NFData) + +type instance IDE.RuleResult DiagramsTempDir = FilePath + +rules :: Recorder (WithPriority Log) -> IDE.Rules () +rules recorder = do + Shake.defineNoFile (cmapWithPrio LogShake recorder) $ \DiagramsTempDir -> do + liftIO $ do + systemTempDir <- getCanonicalTemporaryDirectory + tempDir <- createTempDirectory systemTempDir "hls-diagrams" + logWith recorder Info $ CreatedTempDir tempDir + return tempDir + +{------------------------------------------------------------------------------- + Collect information about the current module +-------------------------------------------------------------------------------} + +data ModuleInfo = ModuleInfo { + moduleUri :: LSP.Uri + , moduleUriNorm :: LSP.NormalizedUri + , modulePath :: FilePath + , modulePathNorm :: LSP.NormalizedFilePath + , moduleSummary :: ModSummary + , moduleName :: ModuleName + , moduleText :: Text + } + +getModuleInfo :: + MonadLsp c m + => IdeState -> LSP.Uri -> CatchErrors c m ModuleInfo +getModuleInfo ide uri = do + pathNorm <- uriToNormalizedFilePath uriNorm + summary <- IDE.msrModSummary <$> getModSummary ide pathNorm + path <- uriToFilePath uri + text <- getVirtualFileText uriNorm + return ModuleInfo{ + moduleUri = uri + , moduleUriNorm = uriNorm + , modulePath = path + , modulePathNorm = pathNorm + , moduleSummary = summary + , moduleName = GHC.moduleName (GHC.ms_mod summary) + , moduleText = text + } + where + uriNorm :: LSP.NormalizedUri + uriNorm = LSP.toNormalizedUri uri + +{------------------------------------------------------------------------------- + Handler: hover +-------------------------------------------------------------------------------} + +handleHover :: + Recorder (WithPriority Log) + -> HLS.PluginMethodHandler IdeState 'LSP.TextDocumentHover +handleHover + recorder + ide + _pluginId + LSP.HoverParams{ + _textDocument = LSP.TextDocumentIdentifier{_uri} + , _position + } = pluginResponse $ do + + moduleInfo@ModuleInfo{..} <- getModuleInfo ide _uri + + -- Figure out what we hovered over + (IDE.HAR{hieAst, hieKind}, _posMap) <- getHieAst ide modulePathNorm + + case hieKind of + IDE.HieFresh -> do + let ids = getIdsAtPoint hieAst _position + logWith recorder Info $ HoverOver ids + case ids of + [(name, typ)] | looksLikeDiagram typ -> do + tempDir <- runAction ide $ IDE.useNoFile_ DiagramsTempDir + tempFile <- liftIO $ emptyTempFile tempDir "diagram.svg" + success <- renderDiagram ide moduleInfo tempFile name + if success then do + logWith recorder Info (RenderedDiagram tempFile) + return $ Just LSP.Hover { + _contents = LSP.HoverContents $ LSP.MarkupContent { + _kind = LSP.MkMarkdown + , _value = Text.unlines [ + Text.pack $ "![](" ++ tempFile ++ ")" + ] + } + , _range = Nothing -- Which range should be highlighted + } + else do + logWith recorder Info $ RenderingFailed + return Nothing + _otherwise -> + return Nothing + IDE.HieFromDisk{} -> + return Nothing + where + looksLikeDiagram :: IDE.Type -> Bool + looksLikeDiagram = ("Diagram" `isPrefixOf`) . IDE.printWithoutUniques + +{------------------------------------------------------------------------------- + Auxiliary: HLS +-------------------------------------------------------------------------------} + +getIdsAtPoint :: IDE.HieASTs GHC.Type -> LSP.Position -> [(Name, IDE.Type)] +getIdsAtPoint ast pos = + concatMap (mapMaybe (uncurry aux) . Map.toList . GHC.nodeIdentifiers) $ + IDE.pointCommand ast pos GHC.nodeInfo + where + aux :: + IDE.Identifier + -> IDE.IdentifierDetails IDE.Type + -> Maybe (Name, IDE.Type) + aux (Left _mod) _ = Nothing + aux (Right name) details = (name,) <$> GHC.identType details + +enableCodeGen :: MonadIO m => IdeState -> ModuleInfo -> m () +enableCodeGen ide ModuleInfo{modulePathNorm} = liftIO $ do + Eval.queueForEvaluation ide modulePathNorm + IDE.setSomethingModified + Shake.VFSUnmodified + ide + [Shake.toKey IDE.NeedsCompilation modulePathNorm] + "hls-diagrams-plugin" + +{------------------------------------------------------------------------------- + Auxiliary: GHC +-------------------------------------------------------------------------------} + +-- | Unload any modules that are out of date +unloadOutOfDate :: MonadIO m => IdeState -> HscEnv -> CatchErrors c m () +unloadOutOfDate ide env = runAction ide $ do + current <- IDE.currentLinkables + liftIO $ GHC.unload env $ map (uncurry aux) $ GHC.moduleEnvToList current + where + aux :: GHC.NoCompat.Module -> UTCTime -> GHC.Linkable + aux mod time = GHC.LM time mod [] + +initialiseSessionForEval :: + MonadIO m + => IdeState -> ModuleInfo -> CatchErrors c m HscEnv +initialiseSessionForEval ide ModuleInfo{..} = do + env <- runAction ide $ do + env <- IDE.hscEnv <$> + IDE.use_ IDE.GhcSessionDeps modulePathNorm + deps <- IDE.reachableModules <$> + IDE.use_ IDE.GetDependencyInformation modulePathNorm + addLinkables env <$> IDE.uses_ IDE.GetLinkable deps + unloadOutOfDate ide env + evalGhcEnv env $ do + GHC.setContext [GHC.IIModule moduleName] + GHC.modifyDynFlags (const $ exts $ GHC.ms_hspp_opts moduleSummary) + GHC.getSession + where + -- Add all dependencies as linkables to the 'HscEnv' + -- This will cause them to be compiled when we call 'GetLinkable' + addLinkables :: HscEnv -> [IDE.LinkableResult] -> HscEnv + addLinkables env linkables = + IDE.loadModulesHome (map IDE.linkableHomeMod linkables) env + + -- Default language extensions + exts :: DynFlags -> DynFlags + exts = + flip GHC.xopt_set GHC.NoCompat.ExtendedDefaultRules + . flip GHC.xopt_unset GHC.NoCompat.MonomorphismRestriction + +-- | Change the ghci rendering function for results +-- +-- We will set this to a rendering function specifically for diagrams. +setPrint :: GhcMonad m => String -> m () +setPrint fn = do + evalPrint <- head <$> GHC.NoCompat.runDecls fn + GHC.modifySession $ \hsc -> hsc { + GHC.hsc_IC = GHC.setInteractivePrintName (GHC.hsc_IC hsc) evalPrint + } + +addImports :: GhcMonad m => [String] -> m () +addImports modules = do + importDecls <- mapM GHC.NoCompat.parseImportDecl modules + context <- GHC.getContext + GHC.setContext $ map GHC.IIDecl importDecls ++ context + +{------------------------------------------------------------------------------- + Evaluating the diagram +-------------------------------------------------------------------------------} + +renderDiagram :: + MonadUnliftIO m + => IdeState -> ModuleInfo -> FilePath -> Name -> CatchErrors c m Bool +renderDiagram ide moduleInfo tempFile name = do + enableCodeGen ide moduleInfo + env <- initialiseSessionForEval ide moduleInfo + result <- evalGhcEnv env $ do + addImports imports + setPrint renderFunction + GHC.NoCompat.execStmt' stmt (IDE.printName name) opts + return $ case result of + GHC.NoCompat.ExecComplete{execResult = Right _} -> + True + _otherwise -> + False + where + stmt :: GHC.GhciLStmt GHC.GhcPs + stmt = GHC.noLoc $ GHC.BodyStmt + GHC.noExtField + (GHC.noLoc $ GHC.HsVar GHC.noExtField $ GHC.noLoc $ GHC.Exact name) + GHC.noSyntaxExpr + GHC.noSyntaxExpr + + -- TODO: Set filename and line number etc + opts :: GHC.NoCompat.ExecOptions + opts = GHC.NoCompat.execOptions + + imports :: [String] + imports = [ + "import qualified Diagrams.Backend.SVG" + , "import qualified Diagrams.TwoD.Size" + ] + + renderFunction :: String + renderFunction = + intercalate " " [ + "evalPrint x =" + , "Diagrams.Backend.SVG.renderSVG" + , show tempFile + , "(Diagrams.TwoD.Size.dims2D 100 100)" + , "x" + ] + +{------------------------------------------------------------------------------- + Example diagram +-------------------------------------------------------------------------------} + +_myCircle :: Diagram B +_myCircle = D.circle 1 diff --git a/plugins/hls-diagrams-plugin/src/Ide/Plugin/Diagrams/CatchErrors.hs b/plugins/hls-diagrams-plugin/src/Ide/Plugin/Diagrams/CatchErrors.hs new file mode 100644 index 0000000000..39ad4e9f3a --- /dev/null +++ b/plugins/hls-diagrams-plugin/src/Ide/Plugin/Diagrams/CatchErrors.hs @@ -0,0 +1,185 @@ +-- Annoyingly, this is needed for the MFunctor instance +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Ide.Plugin.Diagrams.CatchErrors ( + PluginError(..) + , CatchErrors -- opaque + -- * Error handlers + , handleMaybe + , handleMaybeM + -- * HLS utilities + , runAction + , pluginResponse + , getVirtualFileText + , uriToNormalizedFilePath + , uriToFilePath + -- * GHC utilities + , evalGhcEnv + , getModSummary + , getHieAst + ) where + +import Control.Monad.Catch +import Control.Monad.Except +import Control.Monad.IO.Unlift +import Control.Monad.Morph +import GHC.Stack +import Data.Text (Text) + +import qualified Control.Exception as Exception + +import Language.LSP.Server (MonadLsp) +import Development.IDE (IdeState) +import Development.IDE.GHC.Compat (HscEnv) +import Development.IDE.GHC.Compat.Core (Ghc) + +import qualified Development.IDE as IDE +import qualified Development.IDE.Core.PositionMapping as IDE +import qualified Development.IDE.GHC.Util as GHC + +import qualified Ide.PluginUtils as HLS + +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.VFS as LSP + +import qualified DynFlags as GHC.NoCompat +import qualified Exception as GHC.NoCompat +import qualified GHC as GHC.NoCompat + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +data PluginError = PluginError String + deriving stock (Show) + deriving anyclass (Exception) + +newtype CatchErrors c m a = CatchErrors { + unwrapCatchErrors :: m a + } + deriving newtype ( + Functor + , Applicative + , Monad + , MonadIO + , MonadMask + , MonadUnliftIO + , MonadLsp c + , GHC.NoCompat.ExceptionMonad + , GHC.NoCompat.GhcMonad + , GHC.NoCompat.HasDynFlags + ) + +runCatchErrors :: forall c m a. + MonadUnliftIO m + => CatchErrors c m a -> ExceptT SomeException m a +runCatchErrors act = ExceptT $ unwrapCatchErrors act' + where + act' :: CatchErrors c m (Either SomeException a) + act' = try act + +{------------------------------------------------------------------------------- + Standard instances +-------------------------------------------------------------------------------} + +instance MonadIO m => MonadThrow (CatchErrors c m) where + throwM :: Exception e => e -> CatchErrors c m a + throwM = liftIO . Exception.throw + +instance MonadUnliftIO m => MonadCatch (CatchErrors c m) where + catch :: + Exception e + => CatchErrors c m a -> (e -> CatchErrors c m a) -> CatchErrors c m a + catch x f = withRunInIO $ \runInIO -> do + ma <- try (runInIO x) + case ma of + Left e -> runInIO (f e) + Right a -> return a + +instance MonadUnliftIO m => MonadError String (CatchErrors c m) where + throwError :: String -> CatchErrors c m a + throwError = throwM . PluginError + + catchError :: + CatchErrors c m a + -> (String -> CatchErrors c m a) + -> CatchErrors c m a + catchError x f = catch x $ \(PluginError e) -> f e + +instance MFunctor (CatchErrors c) where + hoist :: + Monad m + => (forall a. m a -> n a) + -> CatchErrors c m b -> CatchErrors c n b + hoist nat = CatchErrors . nat . unwrapCatchErrors + +{------------------------------------------------------------------------------- + Error handlers +-------------------------------------------------------------------------------} + +data UnexpectedNothing = UnexpectedNothing CallStack + deriving stock (Show) + deriving anyclass (Exception) + +handleMaybe :: + (MonadUnliftIO m, HasCallStack) + => Maybe a -> CatchErrors c m a +handleMaybe = handleMaybeM . return + +handleMaybeM :: + (MonadUnliftIO m, HasCallStack) + => CatchErrors c m (Maybe a) -> CatchErrors c m a +handleMaybeM ma = ma >>= maybe (throwM $ UnexpectedNothing callStack) return + +{------------------------------------------------------------------------------- + HLS utilities +-------------------------------------------------------------------------------} + +runAction :: + (MonadIO m, HasCallStack) + => IDE.IdeState -> IDE.Action a -> CatchErrors c m a +runAction ide action = liftIO $ + IDE.runAction (prettyCallStack callStack) ide action + +pluginResponse :: + MonadUnliftIO m + => CatchErrors c m a -> m (Either LSP.ResponseError a) +pluginResponse = HLS.pluginResponse . withExceptT show . runCatchErrors + +getVirtualFileText :: + MonadLsp c m + => LSP.NormalizedUri -> CatchErrors c m Text +getVirtualFileText uri = handleMaybeM $ + fmap LSP.virtualFileText <$> LSP.getVirtualFile uri + +uriToNormalizedFilePath :: + MonadLsp c m + => LSP.NormalizedUri -> CatchErrors c m LSP.NormalizedFilePath +uriToNormalizedFilePath uri = handleMaybe $ LSP.uriToNormalizedFilePath uri + +uriToFilePath :: + MonadLsp c m + => LSP.Uri -> CatchErrors c m FilePath +uriToFilePath uri = handleMaybe $ IDE.uriToFilePath' uri + +{------------------------------------------------------------------------------- + GHC utilities +-------------------------------------------------------------------------------} + +evalGhcEnv :: MonadIO m => HscEnv -> CatchErrors c Ghc a -> CatchErrors c m a +evalGhcEnv env = hoist (liftIO . GHC.evalGhcEnv env) + +getModSummary :: + MonadIO m + => IdeState -> LSP.NormalizedFilePath -> CatchErrors c m IDE.ModSummaryResult +getModSummary ide nfp = runAction ide $ + IDE.use_ IDE.GetModSummary nfp + +getHieAst :: + MonadIO m + => IdeState + -> LSP.NormalizedFilePath + -> CatchErrors c m (IDE.HieAstResult, IDE.PositionMapping) +getHieAst ide source = runAction ide $ + IDE.useWithStale_ IDE.GetHieAst source diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index b923cf6517..3363c3cb06 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -44,17 +44,17 @@ library exposed-modules: Ide.Plugin.Eval Ide.Plugin.Eval.Types + Ide.Plugin.Eval.Rules + Ide.Plugin.Eval.CodeLens + Ide.Plugin.Eval.Util hs-source-dirs: src other-modules: Ide.Plugin.Eval.Code - Ide.Plugin.Eval.CodeLens Ide.Plugin.Eval.Config Ide.Plugin.Eval.GHC Ide.Plugin.Eval.Parse.Comments Ide.Plugin.Eval.Parse.Option - Ide.Plugin.Eval.Rules - Ide.Plugin.Eval.Util build-depends: , aeson diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 2ed90bab48..48c7dd0a1b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -21,6 +21,9 @@ For a full example see the "Ide.Plugin.Eval.Tutorial" module. module Ide.Plugin.Eval.CodeLens ( codeLens, evalCommand, + runGetSession, + setupDynFlagsForGHCiLike, + evals, ) where import Control.Applicative (Alternative ((<|>))) diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 5095a637c0..a91019cd83 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -120,6 +120,10 @@ import qualified Ide.Plugin.Brittany as Brittany import qualified Development.IDE.Plugin.CodeAction as Refactor #endif +#if hls_diagrams +import qualified Ide.Plugin.Diagrams as Diagrams +#endif + data Log = forall a. (Pretty a) => Log PluginId a instance Pretty Log where @@ -216,6 +220,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins let pId = "ghcide-code-actions-bindings" in Refactor.bindingsPluginDescriptor (pluginRecorder pId) pId : let pId = "ghcide-code-actions-fill-holes" in Refactor.fillHolePluginDescriptor (pluginRecorder pId) pId : let pId = "ghcide-extend-import-action" in Refactor.extendImportPluginDescriptor (pluginRecorder pId) pId : +#endif +#if hls_diagrams + let pId = "diagrams" in Diagrams.descriptor (pluginRecorder pId) pId : #endif GhcIde.descriptors (pluginRecorder "ghcide") #if explicitFixity