HaRe hie plugin api

app/MainHie.hs

@@ -5,7 +5,6 @@ module Main where
 import           Control.Monad
 import           Data.Monoid                           ((<>))
 import           Data.Version                          (showVersion)
-import qualified GhcMod.Types                          as GM
 import           Haskell.Ide.Engine.MonadFunctions
 import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.Options
@@ -121,13 +120,12 @@ run opts = do
   d <- getCurrentDirectory
   logm $ "Current directory:" ++ d
 
-  let vomitOptions = GM.defaultOptions { GM.optOutput = oo { GM.ooptLogLevel = GM.GmVomit}}
-      oo = GM.optOutput GM.defaultOptions
-  let defaultOpts = if optGhcModVomit opts then vomitOptions else GM.defaultOptions
+  let vomitOptions = defaultOptions { boLogging = BlVomit}
+  let defaultOpts = if optGhcModVomit opts then vomitOptions else defaultOptions
       -- Running HIE on projects with -Werror breaks most of the features since all warnings
       -- will be treated with the same severity of type errors. In order to offer a more useful
       -- experience, we make sure warnings are always reported as warnings by setting -Wwarn
-      ghcModOptions = defaultOpts { GM.optGhcUserOptions = ["-Wwarn"] }
+      biosOptions = defaultOpts { boGhcUserOptions = ["-Wwarn"] }
 
   when (optGhcModVomit opts) $
     logm "Enabling --vomit for ghc-mod. Output will be on stderr"
@@ -139,8 +137,8 @@ run opts = do
 
   -- launch the dispatcher.
   if optJson opts then do
-    scheduler <- newScheduler plugins' ghcModOptions
+    scheduler <- newScheduler plugins' biosOptions
     jsonStdioTransport scheduler
   else do
-    scheduler <- newScheduler plugins' ghcModOptions
+    scheduler <- newScheduler plugins' biosOptions
     lspStdioTransport scheduler origDir plugins' (optCaptureFile opts)

cabal.project

@@ -8,5 +8,6 @@ packages:
          ./submodules/floskell
          ./submodules/ghc-mod/
          ./submodules/ghc-mod/core/
+         ./submodules/ghc-mod/ghc-project-types
 
 tests: true

hie-plugin-api/Haskell/Ide/Engine/Ghc.hs

@@ -0,0 +1,238 @@
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE TypeFamilies        #-}
+-- | This module provides the interface to GHC, mainly for loading
+-- modules while updating the module cache.
+
+module Haskell.Ide.Engine.Ghc
+  (
+    setTypecheckedModule
+  , Diagnostics
+  , AdditionalErrs
+  , cabalModuleGraphs
+  , makeRevRedirMapFunc
+  ) where
+
+import           Bag
+import           Control.Monad.IO.Class
+import           Data.IORef
+import qualified Data.Map.Strict                   as Map
+import qualified Data.Set                          as Set
+import qualified Data.Text                         as T
+import           ErrUtils
+import qualified GhcMod.DynFlags                   as GM
+import qualified GhcMod.Error                      as GM
+import qualified GhcMod.Gap                        as GM
+import qualified GhcMod.ModuleLoader               as GM
+import qualified GhcMod.Monad                      as GM
+import           Data.Monoid ((<>))
+import qualified GhcMod.Target                     as GM
+import qualified GhcMod.Types                      as GM
+import qualified GhcMod.Utils                      as GM
+import           Haskell.Ide.Engine.MonadFunctions
+import           Haskell.Ide.Engine.MonadTypes
+import           Haskell.Ide.Engine.PluginUtils
+import           System.FilePath
+
+import           DynFlags
+import           GHC
+import           IOEnv                             as G
+import           HscTypes
+import           Outputable                        (renderWithStyle)
+
+-- ---------------------------------------------------------------------
+
+type Diagnostics = Map.Map Uri (Set.Set Diagnostic)
+type AdditionalErrs = [T.Text]
+
+-- ---------------------------------------------------------------------
+
+lspSev :: Severity -> DiagnosticSeverity
+lspSev SevWarning = DsWarning
+lspSev SevError   = DsError
+lspSev SevFatal   = DsError
+lspSev SevInfo    = DsInfo
+lspSev _          = DsInfo
+
+-- ---------------------------------------------------------------------
+-- type LogAction = DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
+logDiag :: (FilePath -> FilePath) -> IORef AdditionalErrs -> IORef Diagnostics -> LogAction
+logDiag rfm eref dref df _reason sev spn style msg = do
+  eloc <- srcSpan2Loc rfm spn
+  let msgTxt = T.pack $ renderWithStyle df msg style
+  case eloc of
+    Right (Location uri range) -> do
+      let update = Map.insertWith Set.union uri l
+            where l = Set.singleton diag
+          diag = Diagnostic range (Just $ lspSev sev) Nothing (Just "ghcmod") msgTxt Nothing
+      modifyIORef' dref update
+    Left _ -> do
+      modifyIORef' eref (msgTxt:)
+      return ()
+
+-- ---------------------------------------------------------------------
+
+-- unhelpfulSrcSpanErr :: T.Text -> IdeError
+-- unhelpfulSrcSpanErr err =
+--   IdeError PluginError
+--             ("Unhelpful SrcSpan" <> ": \"" <> err <> "\"")
+--             Null
+
+-- ---------------------------------------------------------------------
+
+srcErrToDiag :: MonadIO m
+  => DynFlags
+  -> (FilePath -> FilePath)
+  -> SourceError -> m (Diagnostics, AdditionalErrs)
+srcErrToDiag df rfm se = do
+  debugm "in srcErrToDiag"
+  let errMsgs = bagToList $ srcErrorMessages se
+      processMsg err = do
+        let sev = Just DsError
+            unqual = errMsgContext err
+            st = GM.mkErrStyle' df unqual
+            msgTxt = T.pack $ renderWithStyle df (pprLocErrMsg err) st
+        eloc <- srcSpan2Loc rfm $ errMsgSpan err
+        case eloc of
+          Right (Location uri range) ->
+            return $ Right (uri, Diagnostic range sev Nothing (Just "ghcmod") msgTxt Nothing)
+          Left _ -> return $ Left msgTxt
+      processMsgs [] = return (Map.empty,[])
+      processMsgs (x:xs) = do
+        res <- processMsg x
+        (m,es) <- processMsgs xs
+        case res of
+          Right (uri, diag) ->
+            return (Map.insertWith Set.union uri (Set.singleton diag) m, es)
+          Left e -> return (m, e:es)
+  processMsgs errMsgs
+
+-- ---------------------------------------------------------------------
+
+myWrapper :: GM.IOish m
+  => (FilePath -> FilePath)
+  -> GM.GmlT m ()
+  -> GM.GmlT m (Diagnostics, AdditionalErrs)
+myWrapper rfm action = do
+  env <- getSession
+  diagRef <- liftIO $ newIORef Map.empty
+  errRef <- liftIO $ newIORef []
+  let setLogger df = df { log_action = logDiag rfm errRef diagRef }
+      setDeferTypedHoles = setGeneralFlag' Opt_DeferTypedHoles
+      ghcErrRes msg = (Map.empty, [T.pack msg])
+      handlers = errorHandlers ghcErrRes (srcErrToDiag (hsc_dflags env) rfm )
+      action' = do
+        GM.withDynFlags (setLogger . setDeferTypedHoles) action
+        diags <- liftIO $ readIORef diagRef
+        errs <- liftIO $ readIORef errRef
+        return (diags,errs)
+  GM.gcatches action' handlers
+
+-- ---------------------------------------------------------------------
+
+errorHandlers :: (Monad m) => (String -> a) -> (SourceError -> m a) -> [GM.GHandler m a]
+errorHandlers ghcErrRes renderSourceError = handlers
+  where
+      -- ghc throws GhcException, SourceError, GhcApiError and
+      -- IOEnvFailure. ghc-mod-core throws GhcModError.
+      handlers =
+        [ GM.GHandler $ \(ex :: GM.GhcModError) ->
+            return $ ghcErrRes (show ex)
+        , GM.GHandler $ \(ex :: IOEnvFailure) ->
+            return $ ghcErrRes (show ex)
+        , GM.GHandler $ \(ex :: GhcApiError) ->
+            return $ ghcErrRes (show ex)
+        , GM.GHandler $ \(ex :: SourceError) ->
+            renderSourceError ex
+        , GM.GHandler $ \(ex :: GhcException) ->
+            return $ ghcErrRes $ GM.renderGm $ GM.ghcExceptionDoc ex
+        , GM.GHandler $ \(ex :: IOError) ->
+            return $ ghcErrRes (show ex)
+        -- , GM.GHandler $ \(ex :: GM.SomeException) ->
+        --     return $ ghcErrRes (show ex)
+        ]
+
+-- ---------------------------------------------------------------------
+
+setTypecheckedModule :: Uri -> IdeGhcM (IdeResult (Diagnostics, AdditionalErrs))
+setTypecheckedModule uri =
+  pluginGetFile "setTypecheckedModule: " uri $ \fp -> do
+    fileMap <- GM.getMMappedFiles
+    debugm $ "setTypecheckedModule: file mapping state is: " ++ show fileMap
+    rfm <- GM.mkRevRedirMapFunc
+    let
+      ghcErrRes msg = ((Map.empty, [T.pack msg]),Nothing,Nothing)
+      progTitle = "Typechecking " <> T.pack (takeFileName fp)
+    debugm "setTypecheckedModule: before ghc-mod"
+    -- TODO:AZ: loading this one module may/should trigger loads of any
+    -- other modules which currently have a VFS entry.  Need to make
+    -- sure that their diagnostics are reported, and their module
+    -- cache entries are updated.
+    -- TODO: Are there any hooks we can use to report back on the progress?
+    ((diags', errs), mtm, mpm) <- withIndefiniteProgress progTitle NotCancellable $ GM.gcatches
+      (GM.getModulesGhc' (myWrapper rfm) fp)
+      (errorHandlers ghcErrRes (return . ghcErrRes . show))
+    debugm "setTypecheckedModule: after ghc-mod"
+
+    canonUri <- canonicalizeUri uri
+    let diags = Map.insertWith Set.union canonUri Set.empty diags'
+    diags2 <- case (mpm,mtm) of
+      (Just pm, Nothing) -> do
+        debugm $ "setTypecheckedModule: Did get parsed module for: " ++ show fp
+        cacheModule fp (Left pm)
+        debugm "setTypecheckedModule: done"
+        return diags
+
+      (_, Just tm) -> do
+        debugm $ "setTypecheckedModule: Did get typechecked module for: " ++ show fp
+        sess <- fmap GM.gmgsSession . GM.gmGhcSession <$> GM.gmsGet
+
+        -- set the session before we cache the module, so that deferred
+        -- responses triggered by cacheModule can access it
+        modifyMTS (\s -> s {ghcSession = sess})
+        cacheModule fp (Right tm)
+        debugm "setTypecheckedModule: done"
+        return diags
+
+      _ -> do
+        debugm $ "setTypecheckedModule: Didn't get typechecked or parsed module for: " ++ show fp
+        debugm $ "setTypecheckedModule: errs: " ++ show errs
+
+        failModule fp
+
+        let sev = Just DsError
+            range = Range (Position 0 0) (Position 1 0)
+            msgTxt = T.unlines errs
+        let d = Diagnostic range sev Nothing (Just "ghcmod") msgTxt Nothing
+        return $ Map.insertWith Set.union canonUri (Set.singleton d) diags
+
+    return $ IdeResultOk (diags2,errs)
+
+-- ---------------------------------------------------------------------
+
+cabalModuleGraphs :: IdeGhcM [GM.GmModuleGraph]
+cabalModuleGraphs = doCabalModuleGraphs
+  where
+    doCabalModuleGraphs :: (GM.IOish m) => GM.GhcModT m [GM.GmModuleGraph]
+    doCabalModuleGraphs = do
+      crdl <- GM.cradle
+      case GM.cradleCabalFile crdl of
+        Just _ -> do
+          mcs <- GM.cabalResolvedComponents
+          let graph = map GM.gmcHomeModuleGraph $ Map.elems mcs
+          return graph
+        Nothing -> return []
+
+-- ---------------------------------------------------------------------
+
+makeRevRedirMapFunc :: IdeGhcM (FilePath -> FilePath)
+makeRevRedirMapFunc = make
+  where
+    make :: (GM.IOish m) => GM.GhcModT m (FilePath -> FilePath)
+    make = GM.mkRevRedirMapFunc
+
+-- ---------------------------------------------------------------------

hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs

@@ -114,7 +114,8 @@ withCachedInfo fp def callback = deferIfNotCached fp go
 -- If you need custom data, see also 'ifCachedModuleAndData'.
 -- If you are in IdeDeferM and would like to wait until a cached module is available,
 -- see also 'withCachedModule'.
-ifCachedModule :: (HasGhcModuleCache m, GM.MonadIO m, CacheableModule b) => FilePath -> a -> (b -> CachedInfo -> m a) -> m a
+ifCachedModule :: (HasGhcModuleCache m, MonadIO m, CacheableModule b)
+               => FilePath -> a -> (b -> CachedInfo -> m a) -> m a
 ifCachedModule fp def callback = do
   muc <- getUriCache fp
   let x = do
@@ -177,7 +178,7 @@ withCachedModuleAndData fp def callback = deferIfNotCached fp go
         go (UriCacheSuccess (UriCache _ _ Nothing _)) = wrap (Defer fp go)
         go UriCacheFailed = return def
 
-getUriCache :: (HasGhcModuleCache m, GM.MonadIO m) => FilePath -> m (Maybe UriCacheResult)
+getUriCache :: (HasGhcModuleCache m, MonadIO m) => FilePath -> m (Maybe UriCacheResult)
 getUriCache fp = do
   uri' <- liftIO $ canonicalizePath fp
   fmap (Map.lookup uri' . uriCaches) getModuleCache
@@ -211,7 +212,7 @@ lookupCachedData fp tm info dat = do
 
 -- | Saves a module to the cache and executes any deferred
 -- responses waiting on that module.
-cacheModule :: FilePath -> (Either GHC.ParsedModule GHC.TypecheckedModule) -> IdeGhcM ()
+cacheModule :: FilePath -> Either GHC.ParsedModule GHC.TypecheckedModule -> IdeGhcM ()
 cacheModule uri modul = do
   uri' <- liftIO $ canonicalizePath uri
   rfm <- GM.mkRevRedirMapFunc

hie-plugin-api/Haskell/Ide/Engine/PluginApi.hs

@@ -0,0 +1,71 @@
+-- | This module provides an API that software intented to be
+-- integrated into HIE can use, so that they can make use of the
+-- shared BIOS features.
+
+{-
+-- Stuff used in HaRe currently
+Options(..)
+defaultOptions
+GmModuleGraph(..)
+ModulePath(..)
+GmComponent(..)
+GmComponentType(..)
+
+CachedInfo(..)
+HasGhcModuleCache(..)
+IdeGhcM
+
+cabalModuleGraphs
+filePathToUri
+makeRevRedirMapFunc
+
+MonadIO(..)
+ifCachedModule
+runIdeGhcMBare
+setTypecheckedModule
+-}
+
+
+module Haskell.Ide.Engine.PluginApi
+  (
+  -- ** Re-exported from ghc-mod via ghc-project-types
+    GP.GmModuleGraph(..)
+  , GP.ModulePath(..)
+  , GP.GmComponent(..)
+  , GP.GmComponentType(..)
+
+  -- * IDE monads
+  , HIE.IdeState(..)
+  , HIE.IdeGhcM
+  , HIE.runIdeGhcM
+  , HIE.runIdeGhcMBare
+  , HIE.IdeM
+  , HIE.runIdeM
+  , HIE.IdeDeferM
+  , HIE.MonadIde
+  , HIE.iterT
+  , HIE.LiftsToGhc(..)
+  , HIE.HasGhcModuleCache(..)
+  , HIE.cabalModuleGraphs
+  , HIE.makeRevRedirMapFunc
+
+  -- * Using the HIE module cache etc
+  , HIE.setTypecheckedModule
+  , HIE.Diagnostics
+  , HIE.AdditionalErrs
+  , LSP.filePathToUri
+  , HIE.ifCachedModule
+  , HIE.CachedInfo(..)
+
+  -- * used for tests in HaRe
+  , HIE.BiosLogLevel(..)
+  , HIE.BiosOptions(..)
+  , HIE.defaultOptions
+  ) where
+
+import qualified GhcProject.Types                    as GP
+import qualified Haskell.Ide.Engine.Ghc              as HIE
+import qualified Haskell.Ide.Engine.GhcModuleCache   as HIE (CachedInfo(..),HasGhcModuleCache(..))
+import qualified Haskell.Ide.Engine.ModuleCache      as HIE (ifCachedModule)
+import qualified Haskell.Ide.Engine.PluginsIdeMonads as HIE
+import qualified Language.Haskell.LSP.Types          as LSP ( filePathToUri )

hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs

@@ -92,6 +92,8 @@ srcSpan2Range :: SrcSpan -> Either T.Text Range
 srcSpan2Range spn =
   realSrcSpan2Range <$> getRealSrcSpan spn
 
+
+
 reverseMapFile :: MonadIO m => (FilePath -> FilePath) -> FilePath -> m FilePath
 reverseMapFile rfm fp = do
   fp' <- liftIO $ canonicalizePath fp
@@ -288,4 +290,4 @@ rangeLinesFromVfs (VirtualFile _ yitext) (Range (Position lf _cf) (Position lt _
   where
     (_ ,s1) = Yi.splitAtLine lf yitext
     (s2, _) = Yi.splitAtLine (lt - lf) s1
-    r = Yi.toText s2
+    r = Yi.toText s2