mirror of
https://github.com/haskell/haskell-ide-engine.git
synced 2024-09-11 11:05:30 +03:00
Add proper support for the 'none' cradle
The main change here is making `runActionWithContext` take an additional default argument which can be returned in the case that we discover that we shouldn't try to understand or process a specific file we are asked to understand.
This commit is contained in:
Matthew Pickering
parent
d79e033fb1
commit
6a9b727621
@ -77,24 +77,34 @@ modifyCache f = do
|
||||
-- Executing an action without context is useful, if you want to only
|
||||
-- mutate ModuleCache or something similar without potentially loading
|
||||
-- the whole GHC session for a component.
|
||||
--
|
||||
-- There are three possibilities for loading a cradle
|
||||
-- 1. Load succeeds and we get a new cradle to execute the action in
|
||||
-- 2. Load fails, so we report an error using IdeResultFail
|
||||
-- 3. The bios reports CradleNone, which means we should completely ignore
|
||||
-- the file.
|
||||
--
|
||||
-- In the third case, we
|
||||
-- 1. Don't execute the action which we told to run, as we should behave as
|
||||
-- though we know nothing about the file.
|
||||
-- 2. Return the default value for the specific action.
|
||||
runActionWithContext :: (MonadIde m, GHC.GhcMonad m, HasGhcModuleCache m, MonadBaseControl IO m)
|
||||
=> GHC.DynFlags
|
||||
-> Maybe FilePath -- ^ Context for the Action
|
||||
-> a -- ^ Default value for none cradle
|
||||
-> m a -- ^ Action to execute
|
||||
-> m (IdeResult a) -- ^ Result of the action or error in
|
||||
-- the context initialisation.
|
||||
runActionWithContext _df Nothing action =
|
||||
runActionWithContext _df Nothing _def action =
|
||||
-- Cradle with no additional flags
|
||||
-- dir <- liftIO $ getCurrentDirectory
|
||||
--This causes problems when loading a later package which sets the
|
||||
--packageDb
|
||||
-- loadCradle df (BIOS.defaultCradle dir)
|
||||
fmap IdeResultOk action
|
||||
runActionWithContext df (Just uri) action = do
|
||||
runActionWithContext df (Just uri) def action = do
|
||||
mcradle <- getCradle uri
|
||||
loadCradle df mcradle >>= \case
|
||||
IdeResultOk () -> fmap IdeResultOk action
|
||||
IdeResultFail err -> return $ IdeResultFail err
|
||||
loadCradle df mcradle def action
|
||||
|
||||
|
||||
-- | Load the Cradle based on the given DynFlags and Cradle lookup Result.
|
||||
@ -102,23 +112,28 @@ runActionWithContext df (Just uri) action = do
|
||||
-- if needed.
|
||||
-- This function may take a long time to execute, since it potentially has
|
||||
-- to set up the Session, including downloading all dependencies of a Cradle.
|
||||
loadCradle :: (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m
|
||||
, MonadBaseControl IO m) => GHC.DynFlags -> LookupCradleResult -> m (IdeResult ())
|
||||
loadCradle _ ReuseCradle = do
|
||||
loadCradle :: forall a m . (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m
|
||||
, MonadBaseControl IO m)
|
||||
=> GHC.DynFlags
|
||||
-> LookupCradleResult
|
||||
-> a
|
||||
-> m a
|
||||
-> m (IdeResult a)
|
||||
loadCradle _ ReuseCradle _def action = do
|
||||
-- Since we expect this message to show up often, only show in debug mode
|
||||
debugm "Reusing cradle"
|
||||
return (IdeResultOk ())
|
||||
IdeResultOk <$> action
|
||||
|
||||
loadCradle _iniDynFlags (LoadCradle (CachedCradle crd env)) = do
|
||||
loadCradle _iniDynFlags (LoadCradle (CachedCradle crd env)) _def action = do
|
||||
-- Reloading a cradle happens on component switch
|
||||
logm $ "Switch to cradle: " ++ show crd
|
||||
-- Cache the existing cradle
|
||||
maybe (return ()) cacheCradle =<< (currentCradle <$> getModuleCache)
|
||||
GHC.setSession env
|
||||
setCurrentCradle crd
|
||||
return (IdeResultOk ())
|
||||
IdeResultOk <$> action
|
||||
|
||||
loadCradle iniDynFlags (NewCradle fp) = do
|
||||
loadCradle iniDynFlags (NewCradle fp) def action = do
|
||||
-- If this message shows up a lot in the logs, it is an indicator for a bug
|
||||
logm $ "New cradle: " ++ fp
|
||||
-- Cache the existing cradle
|
||||
@ -127,19 +142,20 @@ loadCradle iniDynFlags (NewCradle fp) = do
|
||||
-- Now load the new cradle
|
||||
cradle <- liftIO $ findLocalCradle fp
|
||||
logm $ "Found cradle: " ++ show cradle
|
||||
liftIO (GHC.newHscEnv iniDynFlags) >>= GHC.setSession
|
||||
liftIO $ setCurrentDirectory (BIOS.cradleRootDir cradle)
|
||||
withProgress "Initialising Cradle" NotCancellable (initialiseCradle cradle)
|
||||
|
||||
where
|
||||
-- | Initialise the given cradle. This might fail and return an error via `IdeResultFail`.
|
||||
-- Reports its progress to the client.
|
||||
initialiseCradle :: (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m, MonadBaseControl IO m)
|
||||
=> BIOS.Cradle -> (Progress -> IO ()) -> m (IdeResult ())
|
||||
=> BIOS.Cradle -> (Progress -> IO ()) -> m (IdeResult a)
|
||||
initialiseCradle cradle f = do
|
||||
res <- BIOS.initializeFlagsWithCradleWithMessage (Just (toMessager f)) fp cradle
|
||||
case res of
|
||||
BIOS.CradleNone -> return (IdeResultOk ())
|
||||
BIOS.CradleNone ->
|
||||
-- Note: The action is not run if we are in the none cradle, we
|
||||
-- just pretend the file doesn't exist.
|
||||
return $ IdeResultOk def
|
||||
BIOS.CradleFail err -> do
|
||||
logm $ "GhcException on cradle initialisation: " ++ show err
|
||||
return $ IdeResultFail $ IdeError
|
||||
@ -152,6 +168,8 @@ loadCradle iniDynFlags (NewCradle fp) = do
|
||||
-- So, it can still provide Progress Reports.
|
||||
-- Therefore, invocation of 'init_session' must happen
|
||||
-- while 'f' is still valid.
|
||||
liftIO (GHC.newHscEnv iniDynFlags) >>= GHC.setSession
|
||||
liftIO $ setCurrentDirectory (BIOS.cradleRootDir cradle)
|
||||
init_res <- gcatches (Right <$> init_session)
|
||||
[ErrorHandler (\(ex :: GHC.GhcException)
|
||||
-> return $ Left (GHC.showGhcException ex ""))]
|
||||
@ -167,8 +185,9 @@ loadCradle iniDynFlags (NewCradle fp) = do
|
||||
-- it on a save whilst there are errors. Subsequent loads won't
|
||||
-- be that slow, even though the cradle isn't cached because the
|
||||
-- `.hi` files will be saved.
|
||||
Right () ->
|
||||
IdeResultOk <$> setCurrentCradle cradle
|
||||
Right () -> do
|
||||
setCurrentCradle cradle
|
||||
IdeResultOk <$> action
|
||||
|
||||
-- | Sets the current cradle for caching.
|
||||
-- Retrieves the current GHC Module Graph, to find all modules
|
||||
|
||||
@ -302,23 +302,24 @@ ghcDispatcher env@DispatcherEnv { docVersionTVar } errorHandler callbackHandler
|
||||
iniDynFlags <- getSessionDynFlags
|
||||
forever $ do
|
||||
debugm "ghcDispatcher: top of loop"
|
||||
GhcRequest tn context mver mid callback action <- liftIO
|
||||
GhcRequest tn context mver mid callback def action <- liftIO
|
||||
$ Channel.readChan pin
|
||||
debugm $ "ghcDispatcher:got request " ++ show tn ++ " with id: " ++ show mid
|
||||
|
||||
let
|
||||
runner act = case context of
|
||||
Nothing -> runActionWithContext iniDynFlags Nothing act
|
||||
runner :: a -> IdeGhcM a -> IdeGhcM (IdeResult a)
|
||||
runner d act = case context of
|
||||
Nothing -> runActionWithContext iniDynFlags Nothing d act
|
||||
Just uri -> case uriToFilePath uri of
|
||||
Just fp -> runActionWithContext iniDynFlags (Just fp) act
|
||||
Just fp -> runActionWithContext iniDynFlags (Just fp) d act
|
||||
Nothing -> do
|
||||
debugm
|
||||
"ghcDispatcher:Got malformed uri, running action with default context"
|
||||
runActionWithContext iniDynFlags Nothing act
|
||||
runActionWithContext iniDynFlags Nothing d act
|
||||
|
||||
let
|
||||
runWithCallback = do
|
||||
result <- runner action
|
||||
result <- runner (pure def) action
|
||||
liftIO $ case join result of
|
||||
IdeResultOk x -> callbackHandler callback x
|
||||
IdeResultFail err@(IdeError _ msg _) -> do
|
||||
|
||||
@ -99,7 +99,7 @@ run scheduler = flip E.catches handlers $ do
|
||||
case mreq of
|
||||
Nothing -> return()
|
||||
Just req -> do
|
||||
let preq = GReq 0 (context req) Nothing (Just $ J.IdInt rid) (liftIO . callback)
|
||||
let preq = GReq 0 (context req) Nothing (Just $ J.IdInt rid) (liftIO . callback) (toDynJSON (Nothing :: Maybe ()))
|
||||
$ runPluginCommand (plugin req) (command req) (arg req)
|
||||
rid = reqId req
|
||||
callback = sendResponse rid . dynToJSON
|
||||
@ -128,4 +128,4 @@ getNextReq = do
|
||||
else do
|
||||
rest <- readReqByteString
|
||||
let cur = B.charUtf8 char
|
||||
return $ Just $ maybe cur (cur <>) rest
|
||||
return $ Just $ maybe cur (cur <>) rest
|
||||
|
||||
@ -232,7 +232,7 @@ mapFileFromVfs tn vtdi = do
|
||||
-- TODO: @fendor, better document that, why do we even have this?
|
||||
-- We have it to cancel operations that would operate on stale file versions
|
||||
-- Maybe NotDidCloseDocument should call it, too?
|
||||
let req = GReq tn (Just uri) Nothing Nothing (const $ return ())
|
||||
let req = GReq tn (Just uri) Nothing Nothing (const $ return ()) ()
|
||||
$ return (IdeResultOk ())
|
||||
|
||||
updateDocumentRequest uri ver req
|
||||
@ -439,7 +439,7 @@ reactor inp diagIn = do
|
||||
|
||||
|
||||
lf <- ask
|
||||
let hreq = GReq tn Nothing Nothing Nothing callback $ IdeResultOk <$> Hoogle.initializeHoogleDb
|
||||
let hreq = GReq tn Nothing Nothing Nothing callback Nothing $ IdeResultOk <$> Hoogle.initializeHoogleDb
|
||||
callback Nothing = flip runReaderT lf $
|
||||
reactorSend $ NotShowMessage $
|
||||
fmServerShowMessageNotification J.MtWarning "No hoogle db found. Check the README for instructions to generate one"
|
||||
@ -495,7 +495,7 @@ reactor inp diagIn = do
|
||||
ver = vtdi ^. J.version
|
||||
J.List changes = params ^. J.contentChanges
|
||||
mapFileFromVfs tn vtdi
|
||||
makeRequest $ GReq tn (Just uri) Nothing Nothing (const $ return ()) $
|
||||
makeRequest $ GReq tn (Just uri) Nothing Nothing (const $ return ()) () $
|
||||
-- Important - Call this before requestDiagnostics
|
||||
updatePositionMap uri changes
|
||||
|
||||
@ -512,7 +512,7 @@ reactor inp diagIn = do
|
||||
let
|
||||
uri = notification ^. J.params . J.textDocument . J.uri
|
||||
-- unmapFileFromVfs versionTVar cin uri
|
||||
makeRequest $ GReq tn (Just uri) Nothing Nothing (const $ return ()) $ do
|
||||
makeRequest $ GReq tn (Just uri) Nothing Nothing (const $ return ()) () $ do
|
||||
forM_ (uriToFilePath uri)
|
||||
deleteCachedModule
|
||||
return $ IdeResultOk ()
|
||||
@ -524,7 +524,7 @@ reactor inp diagIn = do
|
||||
let (params, doc, pos) = reqParams req
|
||||
newName = params ^. J.newName
|
||||
callback = reactorSend . RspRename . Core.makeResponseMessage req
|
||||
let hreq = GReq tn (Just doc) Nothing (Just $ req ^. J.id) callback
|
||||
let hreq = GReq tn (Just doc) Nothing (Just $ req ^. J.id) callback mempty
|
||||
$ HaRe.renameCmd' doc pos newName
|
||||
makeRequest hreq
|
||||
|
||||
@ -624,7 +624,7 @@ reactor inp diagIn = do
|
||||
"Invalid fallbackCodeAction params"
|
||||
-- Just an ordinary HIE command
|
||||
Just (plugin, cmd) ->
|
||||
let preq = GReq tn Nothing Nothing (Just $ req ^. J.id) callback
|
||||
let preq = GReq tn Nothing Nothing (Just $ req ^. J.id) callback (toDynJSON (Nothing :: Maybe J.WorkspaceEdit))
|
||||
$ runPluginCommand plugin cmd cmdParams
|
||||
in makeRequest preq
|
||||
|
||||
@ -932,14 +932,14 @@ requestDiagnosticsNormal tn file mVer = do
|
||||
let sendHlint = hlintOn clientConfig
|
||||
when sendHlint $ do
|
||||
-- get hlint diagnostics
|
||||
let reql = GReq tn (Just file) (Just (file,ver)) Nothing callbackl
|
||||
let reql = GReq tn (Just file) (Just (file,ver)) Nothing callbackl (PublishDiagnosticsParams file mempty)
|
||||
$ ApplyRefact.lintCmd' file
|
||||
callbackl (PublishDiagnosticsParams fp (List ds))
|
||||
= sendOne "hlint" (J.toNormalizedUri fp, ds)
|
||||
makeRequest reql
|
||||
|
||||
-- get GHC diagnostics and loads the typechecked module into the cache
|
||||
let reqg = GReq tn (Just file) (Just (file,ver)) Nothing callbackg
|
||||
let reqg = GReq tn (Just file) (Just (file,ver)) Nothing callbackg mempty
|
||||
$ BIOS.setTypecheckedModule file
|
||||
callbackg (HIE.Diagnostics pd, errs) = do
|
||||
forM_ errs $ \e -> do
|
||||
|
||||
@ -22,9 +22,10 @@ pattern GReq :: TrackingNumber
|
||||
-> Maybe (Uri, Int)
|
||||
-> Maybe J.LspId
|
||||
-> RequestCallback m a1
|
||||
-> a1
|
||||
-> IdeGhcM (IdeResult a1)
|
||||
-> PluginRequest m
|
||||
pattern GReq a b c d e f = Right (GhcRequest a b c d e f)
|
||||
pattern GReq a b c d e f g= Right (GhcRequest a b c d e f g)
|
||||
|
||||
pattern IReq :: TrackingNumber -> J.LspId -> RequestCallback m a -> IdeDeferM (IdeResult a) -> Either (IdeRequest m) b
|
||||
pattern IReq a b c d = Left (IdeRequest a b c d)
|
||||
@ -37,6 +38,7 @@ data GhcRequest m = forall a. GhcRequest
|
||||
, pinDocVer :: Maybe (J.Uri, Int)
|
||||
, pinLspReqId :: Maybe J.LspId
|
||||
, pinCallback :: RequestCallback m a
|
||||
, pinDefault :: a
|
||||
, pinReq :: IdeGhcM (IdeResult a)
|
||||
}
|
||||
|
||||
|
||||
@ -101,7 +101,7 @@ dispatchGhcRequest tn uri ctx n scheduler lc plugin com arg = do
|
||||
logger :: RequestCallback IO DynamicJSON
|
||||
logger x = logToChan lc (ctx, Right x)
|
||||
|
||||
let req = GReq tn uri Nothing (Just (IdInt n)) logger $
|
||||
let req = GReq tn uri Nothing (Just (IdInt n)) logger (toDynJSON (Nothing :: Maybe ())) $
|
||||
runPluginCommand plugin com (toJSON arg)
|
||||
sendRequest scheduler Nothing req
|
||||
|
||||
|
||||
@ -34,11 +34,11 @@ newPluginSpec = do
|
||||
let defCallback = atomically . writeTChan outChan
|
||||
delayedCallback = \r -> threadDelay 10000 >> defCallback r
|
||||
|
||||
let req0 = GReq 0 Nothing Nothing (Just $ IdInt 0) (\_ -> return () :: IO ()) $ return $ IdeResultOk $ T.pack "text0"
|
||||
req1 = GReq 1 Nothing Nothing (Just $ IdInt 1) defCallback $ return $ IdeResultOk $ T.pack "text1"
|
||||
req2 = GReq 2 Nothing Nothing (Just $ IdInt 2) delayedCallback $ return $ IdeResultOk $ T.pack "text2"
|
||||
req3 = GReq 3 Nothing (Just (filePathToUri "test", 2)) Nothing defCallback $ return $ IdeResultOk $ T.pack "text3"
|
||||
req4 = GReq 4 Nothing Nothing (Just $ IdInt 3) defCallback $ return $ IdeResultOk $ T.pack "text4"
|
||||
let req0 = GReq 0 Nothing Nothing (Just $ IdInt 0) (\_ -> return () :: IO ()) "none" $ return $ IdeResultOk $ T.pack "text0"
|
||||
req1 = GReq 1 Nothing Nothing (Just $ IdInt 1) defCallback "none" $ return $ IdeResultOk $ T.pack "text1"
|
||||
req2 = GReq 2 Nothing Nothing (Just $ IdInt 2) delayedCallback "none" $ return $ IdeResultOk $ T.pack "text2"
|
||||
req3 = GReq 3 Nothing (Just (filePathToUri "test", 2)) Nothing defCallback "none" $ return $ IdeResultOk $ T.pack "text3"
|
||||
req4 = GReq 4 Nothing Nothing (Just $ IdInt 3) defCallback "none" $ return $ IdeResultOk $ T.pack "text4"
|
||||
|
||||
let makeReq = sendRequest scheduler Nothing
|
||||
|
||||
|
||||
@ -48,11 +48,11 @@ dispatchRequestPGoto =
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
runWithContext :: Uri -> IdeGhcM a -> IdeGhcM a
|
||||
runWithContext :: Monoid a => Uri -> IdeGhcM (IdeResult a) -> IdeGhcM (IdeResult a)
|
||||
runWithContext uri act = case uriToFilePath uri of
|
||||
Just fp -> do
|
||||
df <- getSessionDynFlags
|
||||
res <- runActionWithContext df (Just fp) act
|
||||
res <- runActionWithContext df (Just fp) (IdeResultOk mempty) act
|
||||
case res of
|
||||
IdeResultOk a -> return a
|
||||
IdeResultFail err -> error $ "Could not run in context: " ++ show err
|
||||
|
||||
Loading…
Reference in New Issue
Block a user