Apply progress reporting to setTypecheckedModule in its new home

It moved from the ghc-mod plugin to hie-plugin-api

Author: alanz

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

@@ -35,6 +35,7 @@ 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
@@ -164,14 +165,16 @@ setTypecheckedModule uri =
     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.
-    ((diags', errs), mtm, mpm) <- GM.gcatches
-                              (GM.getModulesGhc' (myWrapper rfm) fp)
-                              (errorHandlers ghcErrRes (return . ghcErrRes . show))
+    -- 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

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

@@ -42,7 +42,7 @@ module Haskell.Ide.Engine.PluginApi
   , HIE.IdeM
   , HIE.runIdeM
   , HIE.IdeDeferM
-  , HIE.MonadIde(..)
+  , HIE.MonadIde
   , HIE.iterT
   , HIE.LiftsToGhc(..)
   , HIE.HasGhcModuleCache(..)

src/Haskell/Ide/Engine/Plugin/GhcMod.hs

@@ -35,8 +35,6 @@ import           Data.List
 import           Data.Maybe
 import           Data.Monoid ((<>))
 import qualified Data.Text                         as T
-import           System.FilePath
-import           ErrUtils
 import           Name
 import           GHC.Generics
 import qualified GhcMod                            as GM
@@ -88,154 +86,6 @@ checkCmd = CmdSync setTypecheckedModule
 
 -- ---------------------------------------------------------------------
 
-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: 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)
-
--- ---------------------------------------------------------------------
-
 lintCmd :: CommandFunc Uri T.Text
 lintCmd = CmdSync lintCmd'