diff --git a/app/RunTest.hs b/app/RunTest.hs index 4478d7df5..26df98b80 100644 --- a/app/RunTest.hs +++ b/app/RunTest.hs @@ -103,8 +103,8 @@ runServer mlibdir ideplugins targets = do prettyPrintDiags :: FilePath -> IdeResult (Ghc.Diagnostics, Ghc.AdditionalErrs) -> T.Text prettyPrintDiags fp diags = T.pack fp <> ": " <> case diags of - IdeResultFail IdeError { ideMessage } -> "FAILED\n\t" <> ideMessage - IdeResultOk (_diags, errs) -> + Left IdeError { ideMessage } -> "FAILED\n\t" <> ideMessage + Right (_diags, errs) -> if null errs then "OK" else T.unlines (map (T.append "\t") errs) -- --------------------------------------------------------------------- diff --git a/docs/Architecture.md b/docs/Architecture.md index 07457646f..d9ad85482 100644 --- a/docs/Architecture.md +++ b/docs/Architecture.md @@ -188,7 +188,7 @@ If there is no cached module available, then it will automatically defer your re or return a default if that then fails to typecheck: ```haskell -withCachedModule file (IdeResultOk []) $ \cm -> do +withCachedModule file (Right []) $ \cm -> do -- poke about with cm here ``` diff --git a/docs/Dispatch.md b/docs/Dispatch.md index abc149f99..f122a9cd6 100644 --- a/docs/Dispatch.md +++ b/docs/Dispatch.md @@ -29,10 +29,10 @@ | IdeResult | | + + | | v | | - | IdeResultFail | | - | v | - | IdeResultOk | - | + | + | IdeError | | + | | | + | | | + | | | | v | | RequestCallback | v + v diff --git a/hie-plugin-api/Haskell/Ide/Engine/Ghc.hs b/hie-plugin-api/Haskell/Ide/Engine/Ghc.hs index e40514b30..35b719285 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Ghc.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Ghc.hs @@ -245,7 +245,7 @@ setTypecheckedModule_load uri = debugm "setTypecheckedModule: before ghc-mod" debugm "Loading file" getPersistedFile uri >>= \case - Nothing -> return $ IdeResultOk (Diagnostics mempty, []) + Nothing -> return $ Right (Diagnostics mempty, []) Just mapped_fp -> do liftIO $ copyHsBoot fp mapped_fp rfm <- reverseFileMap @@ -292,7 +292,7 @@ setTypecheckedModule_load uri = in Map.insertWith Set.union canonUri (Set.singleton d) diags Just {} -> diags - return $ IdeResultOk (Diagnostics diags2,errs) + return $ Right (Diagnostics diags2,errs) {- diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs index de81fc745..2279bf57a 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs @@ -32,7 +32,6 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Free -import qualified Data.Aeson as Aeson import qualified Data.ByteString.Char8 as B import Data.Dynamic (toDyn, fromDynamic, Dynamic) import Data.Generics (Proxy(..), TypeRep, typeRep, typeOf) @@ -85,7 +84,7 @@ type PublishDiagnostics = J.NormalizedUri -> J.TextDocumentVersion -> J.Diagnost -- -- 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 +-- 2. Load fails, so we report an error using ideRrror -- 3. The bios reports CradleNone, which means we should completely ignore -- the file. -- @@ -107,7 +106,7 @@ runActionWithContext _pub _df Nothing _def action = --This causes problems when loading a later package which sets the --packageDb -- loadCradle df (Bios.defaultCradle dir) - fmap IdeResultOk action + fmap Right action runActionWithContext publishDiagnostics df (Just uri) def action = do mcradle <- getCradle uri loadCradle publishDiagnostics df mcradle def action @@ -130,7 +129,7 @@ loadCradle :: forall a m . (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m loadCradle _ _ ReuseCradle _def action = do -- Since we expect this message to show up often, only show in debug mode debugm "Reusing cradle" - IdeResultOk <$> action + Right <$> action loadCradle _ _iniDynFlags (LoadCradle (CachedCradle crd env co)) _def action = do -- Reloading a cradle happens on component switch @@ -139,7 +138,7 @@ loadCradle _ _iniDynFlags (LoadCradle (CachedCradle crd env co)) _def action = d maybe (return ()) cacheCradle =<< (currentCradle <$> getModuleCache) GHC.setSession env setCurrentCradle crd co - IdeResultOk <$> action + Right <$> action loadCradle publishDiagnostics iniDynFlags (NewCradle fp) def action = do -- If this message shows up a lot in the logs, it is an indicator for a bug @@ -154,15 +153,10 @@ loadCradle publishDiagnostics iniDynFlags (NewCradle fp) def action = do Right cradle -> do logm $ "Found cradle: " ++ show cradle withProgress ("Initializing " <> cradleDisplay cradle) NotCancellable (initialiseCradle cradle) - Left yamlErr -> - return $ IdeResultFail $ IdeError - { ideCode = OtherError - , ideMessage = Text.pack $ "Couldn't parse hie.yaml: " <> yamlErr - , ideInfo = Aeson.Null - } + Left yamlErr -> ideErrorFrom OtherError "Couldn't parse hie.yaml" yamlErr where - -- | Initialise the given cradle. This might fail and return an error via `IdeResultFail`. + -- | Initialise the given cradle. This might fail and return an error via `ideError`. -- Reports its progress to the client. initialiseCradle :: Bios.Cradle -> (Progress -> IO ()) -> m (IdeResult a) initialiseCradle cradle f = do @@ -171,7 +165,7 @@ loadCradle publishDiagnostics iniDynFlags (NewCradle fp) def action = do 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 + return $ Right def Bios.CradleFail (Bios.CradleError code msg) -> do warningm $ "Fail on cradle initialisation: (" ++ show code ++ ")" ++ show msg @@ -189,11 +183,7 @@ loadCradle publishDiagnostics iniDynFlags (NewCradle fp) def action = do liftIO $ publishDiagnostics normalizedUri Nothing (Map.singleton source (SL.singleton diag)) - return $ IdeResultFail $ IdeError - { ideCode = OtherError - , ideMessage = Text.unwords (take 2 msgTxt) - , ideInfo = Aeson.Null - } + ideError OtherError $ Text.unwords $ take 2 msgTxt Bios.CradleSuccess (init_session, copts) -> do -- Note that init_session contains a Hook to 'f'. -- So, it can still provide Progress Reports. @@ -215,11 +205,7 @@ loadCradle publishDiagnostics iniDynFlags (NewCradle fp) def action = do case init_res of Left err -> do logm $ "Ghc error on cradle initialisation: " ++ show err - return $ IdeResultFail $ IdeError - { ideCode = OtherError - , ideMessage = Text.pack $ show err - , ideInfo = Aeson.Null - } + ideError OtherError $ Text.pack $ show err -- Note: Don't setCurrentCradle because we want to try to reload -- it on a save whilst there are errors. Subsequent loads won't -- be that slow, even though the cradle isn't cached because the @@ -227,12 +213,12 @@ loadCradle publishDiagnostics iniDynFlags (NewCradle fp) def action = do Right Bios.Succeeded -> do setCurrentCradle cradle copts logm "Cradle set succesfully" - IdeResultOk <$> action + Right <$> action Right Bios.Failed -> do setCurrentCradle cradle copts logm "Cradle did not load succesfully" - IdeResultOk <$> action + Right <$> action -- TODO remove after hie-bios update initializeFlagsWithCradleWithMessage :: diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginApi.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginApi.hs index 6e6a273d0..942d93d61 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginApi.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginApi.hs @@ -52,7 +52,7 @@ module Haskell.Ide.Engine.PluginApi , LSP.Uri , HIE.ifCachedModule , HIE.CachedInfo(..) - , HIE.IdeResult(..) + , HIE.IdeResult -- * used for tests in HaRe , BiosLogLevel diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs index aa21d692c..0813ab6be 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs @@ -40,7 +40,6 @@ module Haskell.Ide.Engine.PluginUtils import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Except -import Data.Aeson import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import qualified Data.HashMap.Strict as H @@ -124,15 +123,14 @@ srcSpan2Loc revMapp spn = runExceptT $ do -- | Helper function that extracts a filepath from a Uri if the Uri -- is well formed (i.e. begins with a file:// ) --- fails with an IdeResultFail otherwise +-- fails with an ideError otherwise pluginGetFile :: Monad m => T.Text -> Uri -> (FilePath -> m (IdeResult a)) -> m (IdeResult a) pluginGetFile name uri f = case uriToFilePath uri of Just file -> f file - Nothing -> return $ IdeResultFail (IdeError PluginError - (name <> "Couldn't resolve uri" <> getUri uri) Null) + Nothing -> ideError PluginError $ name <> "Couldn't resolve uri" <> getUri uri -- --------------------------------------------------------------------- -- courtesy of http://stackoverflow.com/questions/19891061/mapeithers-function-in-haskell diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index 78b33c42e..f3e22203a 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -73,8 +73,10 @@ module Haskell.Ide.Engine.PluginsIdeMonads , iterT , LiftsToGhc(..) -- * IdeResult - , IdeResult(..) - , IdeResultT(..) + , IdeResult + , IdeResultT + , ideError + , ideErrorFrom , Defer(..) , IdeError(..) , IdeErrorCode(..) @@ -94,11 +96,14 @@ module Haskell.Ide.Engine.PluginsIdeMonads , PublishDiagnosticsParams(..) , List(..) , FormattingOptions(..) + , ExceptT(..) + , runExceptT ) where import Control.Monad.IO.Class import Control.Monad.Reader +import Control.Monad.Trans.Except import Control.Monad.Trans.Free import Control.Monad.Trans.Control import Control.Monad.Base @@ -116,6 +121,8 @@ import Data.Maybe import qualified Data.Set as S import Data.String import qualified Data.Text as T +import Data.Text.Lens as T +import qualified Control.Lens as L import Data.Typeable ( TypeRep ) #if __GLASGOW_HASKELL__ < 808 @@ -251,7 +258,7 @@ data FormattingType = FormatText -- The Uri is mainly used to discover formatting configurations in the file's path. -- -- Fails if the formatter can not parse the source. --- Failing means here that a IdeResultFail is returned. +-- Failing means here that an ideError is returned. -- This can be used to display errors to the user, unless the error is an Internal one. -- The record 'IdeError' and 'IdeErrorCode' can be used to determine the type of error. -- @@ -317,14 +324,13 @@ runPluginCommand :: PluginId -> CommandId -> Value runPluginCommand p@(PluginId p') com@(CommandId com') arg = do IdePlugins m <- getPlugins case Map.lookup p m of - Nothing -> return $ - IdeResultFail $ IdeError UnknownPlugin ("Plugin " <> p' <> " doesn't exist") Null + Nothing -> ideError UnknownPlugin $ "Plugin " <> p' <> " doesn't exist" Just PluginDescriptor { pluginCommands = xs } -> case List.find ((com ==) . commandId) xs of - Nothing -> return $ IdeResultFail $ - IdeError UnknownCommand ("Command " <> com' <> " isn't defined for plugin " <> p' <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Null + Nothing -> ideError UnknownCommand + $ "Command " <> com' <> " isn't defined for plugin " <> p' <> ". Legal commands are: " <> T.pack (show $ map commandId xs) Just (PluginCommand _ _ f) -> case fromJSON arg of - Error err -> return $ IdeResultFail $ - IdeError ParameterError ("error while parsing args for " <> com' <> " in plugin " <> p' <> ": " <> T.pack err) Null + Error err -> ideError ParameterError + $ "error while parsing args for " <> com' <> " in plugin " <> p' <> ": " <> T.pack err Success a -> do res <- f a return $ fmap toDynJSON res @@ -508,45 +514,14 @@ instance HasGhcModuleCache IdeM where -- | The result of a plugin action, containing the result and an error if -- it failed. IdeGhcM usually skips IdeResponse and jumps straight to this. -data IdeResult a = IdeResultOk a - | IdeResultFail IdeError - deriving (Eq, Show, Generic, ToJSON, FromJSON) +type IdeResult = Either IdeError +type IdeResultT = ExceptT IdeError -instance Functor IdeResult where - fmap f (IdeResultOk x) = IdeResultOk (f x) - fmap _ (IdeResultFail err) = IdeResultFail err +ideError :: (IsText t, Monad m) => IdeErrorCode -> t -> m (IdeResult a) +ideError code msg = return $ Left $ IdeError code (T.pack $ msg L.^. L.re T.packed) Null -instance Applicative IdeResult where - pure = return - (IdeResultFail err) <*> _ = IdeResultFail err - _ <*> (IdeResultFail err) = IdeResultFail err - (IdeResultOk f) <*> (IdeResultOk x) = IdeResultOk (f x) - -instance Monad IdeResult where - return = IdeResultOk - IdeResultOk x >>= f = f x - IdeResultFail err >>= _ = IdeResultFail err - -newtype IdeResultT m a = IdeResultT { runIdeResultT :: m (IdeResult a) } - -instance Monad m => Functor (IdeResultT m) where - fmap = liftM - -instance Monad m => Applicative (IdeResultT m) where - pure = return - (<*>) = ap - -instance (Monad m) => Monad (IdeResultT m) where - return = IdeResultT . return . IdeResultOk - - m >>= f = IdeResultT $ do - v <- runIdeResultT m - case v of - IdeResultOk x -> runIdeResultT (f x) - IdeResultFail err -> return $ IdeResultFail err - -instance MonadTrans IdeResultT where - lift m = IdeResultT (fmap IdeResultOk m) +ideErrorFrom :: (IsText t, Monad m) => IdeErrorCode -> String -> t -> m (IdeResult a) +ideErrorFrom code source msg = return $ Left $ IdeError code (T.pack $ source ++ " :" ++ msg L.^. L.re T.packed) Null -- | Error codes. Add as required data IdeErrorCode diff --git a/hie-plugin-api/hie-plugin-api.cabal b/hie-plugin-api/hie-plugin-api.cabal index c20e9c5e5..82b48adda 100644 --- a/hie-plugin-api/hie-plugin-api.cabal +++ b/hie-plugin-api/hie-plugin-api.cabal @@ -56,6 +56,7 @@ library , haskell-lsp == 0.19.* , hslogger , unliftio + , lens , monad-control , mtl , process diff --git a/src/Haskell/Ide/Engine/CodeActions.hs b/src/Haskell/Ide/Engine/CodeActions.hs index 3939ae5d3..29f098ea8 100644 --- a/src/Haskell/Ide/Engine/CodeActions.hs +++ b/src/Haskell/Ide/Engine/CodeActions.hs @@ -38,7 +38,7 @@ handleCodeActionReq tn req = do let getProvider p = pluginCodeActionProvider p <*> return (pluginId p) getProviders = do IdePlugins m <- getPlugins - return $ IdeResultOk $ mapMaybe getProvider $ toList m + return $ Right $ mapMaybe getProvider $ toList m providersCb providers = let reqs = map (\f -> lift (f docId range context)) providers diff --git a/src/Haskell/Ide/Engine/Completions.hs b/src/Haskell/Ide/Engine/Completions.hs index 9e3ad2cf5..0db440877 100644 --- a/src/Haskell/Ide/Engine/Completions.hs +++ b/src/Haskell/Ide/Engine/Completions.hs @@ -329,7 +329,7 @@ getCompletions uri prefixInfo withSnippets = let enteredQual = if T.null prefixModule then "" else prefixModule <> "." fullPrefix = enteredQual <> prefixText - ifCachedModuleAndData file (IdeResultOk []) + ifCachedModuleAndData file (Right []) $ \tm CachedInfo { newPosToOld } CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules } -> let -- default to value context if no explicit context @@ -418,7 +418,7 @@ getCompletions uri prefixInfo withSnippets = = filtModNameCompls ++ map (toggleSnippets caps withSnippets . mkCompl . stripAutoGenerated) filtCompls in - return $ IdeResultOk result + return $ Right result where validPragmas :: [(T.Text, T.Text)] validPragmas = diff --git a/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs b/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs index 7f0ec83ff..0f6b43b2e 100644 --- a/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs +++ b/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs @@ -82,15 +82,13 @@ applyOneCmd (AOP uri pos title) = pluginGetFile "applyOne: " uri $ \fp -> do revMapp <- reverseFileMap let defaultResult = do debugm "applyOne: no access to the persisted file." - return $ IdeResultOk mempty + return $ Right mempty withMappedFile fp defaultResult $ \file' -> do res <- liftToGhc $ applyHint file' (Just oneHint) revMapp logm $ "applyOneCmd:file=" ++ show fp logm $ "applyOneCmd:res=" ++ show res - case res of - Left err -> return $ IdeResultFail - (IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null) - Right fs -> return (IdeResultOk fs) + return $ res & _Left %~ \err -> + IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null -- --------------------------------------------------------------------- @@ -99,15 +97,13 @@ applyAllCmd :: Uri -> IdeGhcM (IdeResult WorkspaceEdit) applyAllCmd uri = pluginGetFile "applyAll: " uri $ \fp -> do let defaultResult = do debugm "applyAll: no access to the persisted file." - return $ IdeResultOk mempty + return $ Right mempty revMapp <- reverseFileMap withMappedFile fp defaultResult $ \file' -> do res <- liftToGhc $ applyHint file' Nothing revMapp logm $ "applyAllCmd:res=" ++ show res - case res of - Left err -> return $ IdeResultFail (IdeError PluginError - (T.pack $ "applyAll: " ++ show err) Null) - Right fs -> return (IdeResultOk fs) + return $ res & _Left %~ \err -> + IdeError PluginError (T.pack $ "applyAll: " ++ show err) Null -- --------------------------------------------------------------------- @@ -118,26 +114,18 @@ lint uri = pluginGetFile "lint: " uri $ \fp -> do defaultResult = do debugm "lint: no access to the persisted file." return - $ IdeResultOk (PublishDiagnosticsParams (filePathToUri fp) $ List []) + $ Right $ PublishDiagnosticsParams (filePathToUri fp) $ List [] withMappedFile fp defaultResult $ \file' -> do eitherErrorResult <- liftIO (try $ runExceptT $ runLint file' [] :: IO (Either IOException (Either [Diagnostic] [Idea])) ) case eitherErrorResult of - Left err -> return $ IdeResultFail - (IdeError PluginError (T.pack $ "lint: " ++ show err) Null) - Right res -> case res of - Left diags -> - return - (IdeResultOk - (PublishDiagnosticsParams (filePathToUri fp) $ List diags) - ) - Right fs -> - return - $ IdeResultOk - $ PublishDiagnosticsParams (filePathToUri fp) - $ List (map hintToDiagnostic $ stripIgnores fs) + Left err -> ideErrorFrom PluginError "lint" $ show err + Right res -> return $ Right $ + PublishDiagnosticsParams (filePathToUri fp) $ List $ case res of + Left diags -> diags + Right fs -> map hintToDiagnostic $ stripIgnores fs runLint :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea] runLint fp args = do @@ -311,7 +299,7 @@ showParseError (Hlint.ParseError location message content) = -- --------------------------------------------------------------------- codeActionProvider :: CodeActionProvider -codeActionProvider plId docId _ context = IdeResultOk <$> hlintActions +codeActionProvider plId docId _ context = Right <$> hlintActions where hlintActions :: IdeM [LSP.CodeAction] diff --git a/src/Haskell/Ide/Engine/Plugin/Brittany.hs b/src/Haskell/Ide/Engine/Plugin/Brittany.hs index eb46310e9..ebc16169e 100644 --- a/src/Haskell/Ide/Engine/Plugin/Brittany.hs +++ b/src/Haskell/Ide/Engine/Plugin/Brittany.hs @@ -5,11 +5,9 @@ module Haskell.Ide.Engine.Plugin.Brittany where import Control.Lens import Control.Monad.IO.Class import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) -import Data.Aeson import Data.Coerce import Data.Semigroup import Data.Text (Text) -import qualified Data.Text as T import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.PluginUtils import Language.Haskell.Brittany @@ -50,14 +48,10 @@ provider text uri formatType opts = pluginGetFile "brittanyCmd: " uri $ \fp -> d res <- formatText confFile opts selectedContents case res of - Left err -> return $ IdeResultFail - (IdeError PluginError - (T.pack $ "brittanyCmd: " ++ unlines (map showErr err)) - Null - ) + Left err -> ideErrorFrom PluginError "brittanyCmd: " $ unlines $ map showErr err Right newText -> do let textEdit = J.TextEdit range newText - return $ IdeResultOk [textEdit] + return $ Right [textEdit] -- | Primitive to format text with the given option. -- May not throw exceptions but return a Left value. diff --git a/src/Haskell/Ide/Engine/Plugin/Example2.hs b/src/Haskell/Ide/Engine/Plugin/Example2.hs index 7c49e9371..225904e19 100644 --- a/src/Haskell/Ide/Engine/Plugin/Example2.hs +++ b/src/Haskell/Ide/Engine/Plugin/Example2.hs @@ -41,12 +41,12 @@ example2Descriptor plId = PluginDescriptor -- --------------------------------------------------------------------- sayHelloCmd :: () -> IdeGhcM (IdeResult T.Text) -sayHelloCmd () = return (IdeResultOk sayHello) +sayHelloCmd () = return (Right sayHello) sayHelloToCmd :: T.Text -> IdeGhcM (IdeResult T.Text) sayHelloToCmd n = do r <- liftIO $ sayHelloTo n - return $ IdeResultOk r + return $ Right r -- --------------------------------------------------------------------- @@ -69,7 +69,7 @@ diagnosticProvider trigger uri = do , _message = "Example plugin diagnostic, triggered by" <> T.pack (show trigger) , _relatedInformation = Nothing } - return $ IdeResultOk $ Map.fromList [(uri,S.singleton diag)] + return $ Right $ Map.fromList [(uri,S.singleton diag)] -- --------------------------------------------------------------------- @@ -80,7 +80,7 @@ data TodoParams = TodoParams deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) todoCmd :: TodoParams -> IdeGhcM (IdeResult J.WorkspaceEdit) -todoCmd (TodoParams uri r) = return $ IdeResultOk $ makeTodo uri r +todoCmd (TodoParams uri r) = return $ Right $ makeTodo uri r makeTodo :: J.Uri -> J.Range -> J.WorkspaceEdit makeTodo uri (J.Range (J.Position startLine _) _) = res @@ -100,7 +100,7 @@ makeTodo uri (J.Range (J.Position startLine _) _) = res codeActionProvider :: CodeActionProvider codeActionProvider plId docId r _context = do cmd <- mkLspCommand plId "todo" title (Just cmdParams) - return $ IdeResultOk [codeAction cmd] + return $ Right [codeAction cmd] where codeAction :: J.Command -> J.CodeAction codeAction cmd = J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) Nothing (Just cmd) diff --git a/src/Haskell/Ide/Engine/Plugin/Floskell.hs b/src/Haskell/Ide/Engine/Plugin/Floskell.hs index 25f72895d..4817b0b10 100644 --- a/src/Haskell/Ide/Engine/Plugin/Floskell.hs +++ b/src/Haskell/Ide/Engine/Plugin/Floskell.hs @@ -7,9 +7,7 @@ module Haskell.Ide.Engine.Plugin.Floskell where import Control.Monad.IO.Class (liftIO) -import Data.Aeson (Value (Null)) import qualified Data.ByteString.Lazy as BS -import qualified Data.Text as T import qualified Data.Text.Encoding as T import Floskell import Haskell.Ide.Engine.MonadTypes @@ -38,10 +36,9 @@ provider contents uri typ _opts = let (range, selectedContents) = case typ of FormatText -> (fullRange contents, contents) FormatRange r -> (r, extractRange r contents) - result = reformat config (Just file) (BS.fromStrict (T.encodeUtf8 selectedContents)) - case result of - Left err -> return $ IdeResultFail (IdeError PluginError (T.pack $ "floskellCmd: " ++ err) Null) - Right new -> return $ IdeResultOk [TextEdit range (T.decodeUtf8 (BS.toStrict new))] + case reformat config (Just file) $ BS.fromStrict $ T.encodeUtf8 selectedContents of + Left err -> ideErrorFrom PluginError "floskellCmd" err + Right new -> return $ Right [TextEdit range $ T.decodeUtf8 $ BS.toStrict new] -- | Find Floskell Config, user and system wide or provides a default style. -- Every directory of the filepath will be searched to find a user configuration. diff --git a/src/Haskell/Ide/Engine/Plugin/Generic.hs b/src/Haskell/Ide/Engine/Plugin/Generic.hs index 6f734ce60..cbb29f72f 100644 --- a/src/Haskell/Ide/Engine/Plugin/Generic.hs +++ b/src/Haskell/Ide/Engine/Plugin/Generic.hs @@ -74,9 +74,9 @@ typeCmd (TP _bool uri pos) = liftToGhc $ newTypeCmd pos uri newTypeCmd :: Position -> Uri -> IdeM (IdeResult [(Range, T.Text)]) newTypeCmd newPos uri = pluginGetFile "newTypeCmd: " uri $ \fp -> - ifCachedModule fp (IdeResultOk []) $ \tm info -> do + ifCachedModule fp (Right []) $ \tm info -> do debugm $ "newTypeCmd: " <> show (newPos, uri) - return $ IdeResultOk $ pureTypeCmd newPos tm info + return $ Right $ pureTypeCmd newPos tm info pureTypeCmd :: Position -> GHC.TypecheckedModule -> CachedInfo -> [(Range,T.Text)] pureTypeCmd newPos tm info = @@ -162,12 +162,12 @@ codeActionProvider' supportsDocChanges _ docId _ context = topLevelSignatureActions = map (uncurry mkMissingSignatureAction) missingSignatures unusedTerms = mapMaybe getUnusedTerms diags unusedTermActions = map (uncurry mkUnusedTermAction) unusedTerms - in return $ IdeResultOk $ concat [ renameActions - , redundantActions - , typedHoleActions - , topLevelSignatureActions - , unusedTermActions - ] + in return $ Right $ concat [ renameActions + , redundantActions + , typedHoleActions + , topLevelSignatureActions + , unusedTermActions + ] where @@ -383,17 +383,16 @@ extractUnusedTerm msg = Hie.extractTerm <$> stripMessageStart msg -- --------------------------------------------------------------------- hoverProvider :: HoverProvider -hoverProvider doc pos = runIdeResultT $ do - info' <- IdeResultT $ newTypeCmd pos doc - names' <- IdeResultT $ pluginGetFile "ghc-mod:hoverProvider" doc $ \fp -> - ifCachedModule fp (IdeResultOk []) $ \(_ :: GHC.ParsedModule) info -> - return $ IdeResultOk $ Hie.getSymbolsAtPoint pos info +hoverProvider doc pos = runExceptT $ do + info' <- ExceptT $ newTypeCmd pos doc + names' <- ExceptT $ pluginGetFile "ghc-mod:hoverProvider" doc $ \fp -> + ifCachedModule fp (Right []) $ \(_ :: GHC.ParsedModule) info -> + return $ Right $ Hie.getSymbolsAtPoint pos info let f = (==) `on` (Hie.showName . snd) f' = compare `on` (Hie.showName . snd) names = mapMaybe pickName $ groupBy f $ sortBy f' names' pickName [] = Nothing - pickName [x] = Just x pickName xs@(x:_) = case find (isJust . nameModule_maybe . snd) xs of Nothing -> Just x Just a -> Just a @@ -423,7 +422,7 @@ data Decl = Decl LSP.SymbolKind (Located RdrName) [Decl] SrcSpan symbolProvider :: Uri -> IdeDeferM (IdeResult [LSP.DocumentSymbol]) symbolProvider uri = pluginGetFile "ghc-mod symbolProvider: " uri $ - \file -> withCachedModule file (IdeResultOk []) $ \pm _ -> do + \file -> withCachedModule file (Right []) $ \pm _ -> do let hsMod = unLoc $ pm_parsed_source pm imports = hsmodImports hsMod imps = concatMap goImport imports @@ -594,4 +593,4 @@ symbolProvider uri = pluginGetFile "ghc-mod symbolProvider: " uri $ _ -> return childrenSymbols symInfs <- concat <$> mapM declsToSymbolInf (imps ++ decls) - return $ IdeResultOk symInfs + return $ Right symInfs diff --git a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs index beb2ea6dc..7050ba61a 100644 --- a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs +++ b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} module Haskell.Ide.Engine.Plugin.GhcMod ( ghcmodDescriptor @@ -74,7 +75,7 @@ checkCmd = HIE.setTypecheckedModule splitCaseCmd :: Hie.HarePoint -> IdeGhcM (IdeResult WorkspaceEdit) splitCaseCmd (Hie.HP _uri _pos) - = return (IdeResultFail (IdeError PluginError "splitCaseCmd not implemented" Null)) + = ideError @String PluginError "splitCaseCmd not implemented" -- --------------------------------------------------------------------- diff --git a/src/Haskell/Ide/Engine/Plugin/Haddock.hs b/src/Haskell/Ide/Engine/Plugin/Haddock.hs index 1c1daef57..f6c9088db 100644 --- a/src/Haskell/Ide/Engine/Plugin/Haddock.hs +++ b/src/Haskell/Ide/Engine/Plugin/Haddock.hs @@ -223,7 +223,7 @@ renderMarkDown = hoverProvider :: HoverProvider hoverProvider doc pos = pluginGetFile "haddock:hoverProvider" doc $ \fp -> - ifCachedModule fp (IdeResultOk mempty) $ \tm info -> runIdeResultT $ do + ifCachedModule fp (Right mempty) $ \tm info -> runExceptT $ do let df = getDynFlags tm names = mapMaybe pickName $ groupBy f $ sortBy f' $ getSymbolsAtPoint pos info docs <- forM names $ \(_,name) -> do diff --git a/src/Haskell/Ide/Engine/Plugin/HfaAlign.hs b/src/Haskell/Ide/Engine/Plugin/HfaAlign.hs index bcb793ff9..4b270b109 100644 --- a/src/Haskell/Ide/Engine/Plugin/HfaAlign.hs +++ b/src/Haskell/Ide/Engine/Plugin/HfaAlign.hs @@ -51,7 +51,7 @@ alignCmd :: AlignParams -> IdeGhcM (IdeResult J.WorkspaceEdit) alignCmd (AlignParams uri rg) = do mtext <- getRangeFromVFS uri rg case mtext of - Nothing -> return $ IdeResultOk $ J.WorkspaceEdit Nothing Nothing + Nothing -> return $ Right $ J.WorkspaceEdit Nothing Nothing Just txt -> do let adjusted = adjustText txt @@ -59,14 +59,14 @@ alignCmd (AlignParams uri rg) = do res = J.WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - return $ IdeResultOk res + return $ Right res -- --------------------------------------------------------------------- codeActionProvider :: CodeActionProvider codeActionProvider plId docId (Range (Position sl _) (Position el _)) _context = do cmd <- mkLspCommand plId "align" title (Just cmdParams) - return $ IdeResultOk [codeAction cmd] + return $ Right [codeAction cmd] where codeAction :: J.Command -> J.CodeAction codeAction cmd = J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) Nothing (Just cmd) diff --git a/src/Haskell/Ide/Engine/Plugin/HsImport.hs b/src/Haskell/Ide/Engine/Plugin/HsImport.hs index 1a2253c26..bf7bbc09e 100644 --- a/src/Haskell/Ide/Engine/Plugin/HsImport.hs +++ b/src/Haskell/Ide/Engine/Plugin/HsImport.hs @@ -132,7 +132,7 @@ importModule (ImportParams uri impStyle modName) = fileMap <- reverseFileMap let defaultResult = do debugm "hsimport: no access to the persisted file." - return $ IdeResultOk mempty + return $ Right mempty withMappedFile origInput defaultResult $ \input -> do tmpDir <- liftIO getTemporaryDirectory (output, outputH) <- liftIO $ openTempFile tmpDir "hsimportOutput" @@ -147,8 +147,7 @@ importModule (ImportParams uri impStyle modName) = case maybeErr of Just err -> do liftIO $ removeFile output - let msg = T.pack $ show err - return $ IdeResultFail (IdeError PluginError msg Null) + ideError PluginError $ show err Nothing -> do -- Since no error happened, calculate the differences of -- the original file and after the import has been done. @@ -168,7 +167,7 @@ importModule (ImportParams uri impStyle modName) = -- Client may have no formatter selected -- but still the option to format on import. Nothing -> - return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges) + return $ Right $ J.WorkspaceEdit mChanges mDocChanges Just (_, provider) -> do let @@ -198,9 +197,9 @@ importModule (ImportParams uri impStyle modName) = formatEdit origEdit@(J.TextEdit r t) = do -- TODO: are these default FormattingOptions ok? formatEdits <- - liftToGhc $ provider t uri FormatText (FormattingOptions 2 True) >>= \case - IdeResultOk xs -> return xs - _ -> return [origEdit] + liftToGhc $ provider t uri FormatText (FormattingOptions 2 True) <&> \case + Right xs -> xs + _ -> [origEdit] -- let edits = foldl' J.editTextEdit origEdit formatEdits -- TODO: this seems broken. return (J.TextEdit r (renormalise t . J._newText $ head formatEdits)) @@ -213,9 +212,8 @@ importModule (ImportParams uri impStyle modName) = return $ J.TextDocumentEdit vids newEdits mapM cmd change - return - $ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges) - else return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges) + return $ Right $ J.WorkspaceEdit newChanges newDocChanges + else return $ Right $ J.WorkspaceEdit mChanges mDocChanges -- | Convert the import style arguments into HsImport arguments. -- Takes an input and an output file as well as a module name. @@ -282,8 +280,8 @@ codeActionProvider plId docId _ context = do -- If we didn't find any exact matches, relax the search terms. -- Only looks for the function names, not the exact siganture. relaxedActions <- importActionsForTerms ExactName terms - return $ IdeResultOk relaxedActions - else return $ IdeResultOk actions + return $ Right relaxedActions + else return $ Right actions where -- | Creates CodeActions from the diagnostics to add imports. diff --git a/src/Haskell/Ide/Engine/Plugin/Liquid.hs b/src/Haskell/Ide/Engine/Plugin/Liquid.hs index 1553c4d12..7bbc2e427 100644 --- a/src/Haskell/Ide/Engine/Plugin/Liquid.hs +++ b/src/Haskell/Ide/Engine/Plugin/Liquid.hs @@ -93,7 +93,7 @@ instance ExtensionClass LiquidData where diagnosticProvider :: DiagnosticProviderFuncAsync diagnosticProvider DiagnosticOnSave uri cb = pluginGetFile "Liquid.diagnosticProvider:" uri $ \file -> - withCachedModuleAndData file (IdeResultOk ()) $ \_tm _info () -> do + withCachedModuleAndData file (Right ()) $ \_tm _info () -> do -- New save, kill any prior instance that was running LiquidData mtid <- get mapM_ (liftIO . cancel) mtid @@ -105,8 +105,8 @@ diagnosticProvider DiagnosticOnSave uri cb = pluginGetFile "Liquid.diagnosticPro put (LiquidData (Just tid)) - return $ IdeResultOk () -diagnosticProvider _ _ _ = return (IdeResultOk ()) + return $ Right () +diagnosticProvider _ _ _ = return $ Right () -- --------------------------------------------------------------------- @@ -240,11 +240,11 @@ liquidFileFor uri ext = hoverProvider :: HoverProvider hoverProvider uri pos = pluginGetFile "Liquid.hoverProvider: " uri $ \file -> - ifCachedModuleAndData file (IdeResultOk []) $ + ifCachedModuleAndData file (Right []) $ \_ info () -> do merrs <- liftIO $ readVimAnnot uri case merrs of - Nothing -> return (IdeResultOk []) + Nothing -> return $ Right [] Just lerrs -> do let perrs = map (\le@(LE s e _) -> (lpToPos s,lpToPos e,le)) lerrs ls = getThingsAtPos info pos perrs @@ -252,7 +252,7 @@ hoverProvider uri pos = let msgs = T.splitOn "\\n" msg msgm = J.markedUpContent "haskell" (T.unlines msgs) return $ J.Hover (J.HoverContents msgm) (Just r) - return (IdeResultOk hs) + return $ Right hs -- --------------------------------------------------------------------- diff --git a/src/Haskell/Ide/Engine/Plugin/Ormolu.hs b/src/Haskell/Ide/Engine/Plugin/Ormolu.hs index b23109ed9..2bc41529b 100644 --- a/src/Haskell/Ide/Engine/Plugin/Ormolu.hs +++ b/src/Haskell/Ide/Engine/Plugin/Ormolu.hs @@ -10,7 +10,6 @@ import Haskell.Ide.Engine.MonadTypes import Control.Exception import Control.Monad import Control.Monad.IO.Class ( liftIO , MonadIO(..) ) -import Data.Aeson ( Value ( Null ) ) import Data.List import Data.Maybe import qualified Data.Text as T @@ -37,21 +36,20 @@ provider :: FormattingProvider provider _contents _uri _typ _opts = #if __GLASGOW_HASKELL__ >= 806 case _typ of - FormatRange _ -> return $ IdeResultFail (IdeError PluginError (T.pack "Selection formatting for Ormolu is not currently supported.") Null) + FormatRange _ -> ideError @String PluginError "Selection formatting for Ormolu is not currently supported." FormatText -> pluginGetFile _contents _uri $ \file -> do opts <- lookupComponentOptions file let opts' = map DynOption $ filter exop $ join $ maybeToList $ componentOptions <$> opts conf = Config opts' False False True False - result <- liftIO $ try @OrmoluException (ormolu conf file (T.unpack _contents)) - + result <- liftIO $ try @OrmoluException $ ormolu conf file $ T.unpack _contents case result of - Left err -> return $ IdeResultFail (IdeError PluginError (T.pack $ "ormoluCmd: " ++ show err) Null) - Right new -> return $ IdeResultOk [TextEdit (fullRange _contents) new] + Left err -> ideErrorFrom PluginError "ormoluCmd" $ show err + Right new -> return $ Right [TextEdit (fullRange _contents) new] where exop s = "-X" `isPrefixOf` s || "-fplugin=" `isPrefixOf` s || "-pgmF=" `isPrefixOf` s #else - return $ IdeResultOk [] -- NOP formatter + return $ Right [] -- NOP formatter #endif diff --git a/src/Haskell/Ide/Engine/Plugin/Package.hs b/src/Haskell/Ide/Engine/Plugin/Package.hs index 481cb7224..6e8e32547 100644 --- a/src/Haskell/Ide/Engine/Plugin/Package.hs +++ b/src/Haskell/Ide/Engine/Plugin/Package.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} -- | Commands and code actions for adding package dependencies into .cabal and -- package.yaml files @@ -109,7 +110,7 @@ addCmd (AddParams rootDir modulePath pkg) = do absFp <- liftIO $ canonicalizePath relFp let relModulePath = makeRelative (takeDirectory absFp) modulePath liftToGhc $ editHpackPackage absFp relModulePath pkg - NoPackage -> return $ IdeResultFail (IdeError PluginError "No package.yaml or .cabal found" Null) + NoPackage -> ideError @String PluginError "No package.yaml or .cabal found" data PackageType = CabalPackage FilePath -- ^ Location of Cabal File. May be relative. | HpackPackage FilePath -- ^ Location of `package.yaml`. May be relative. @@ -190,8 +191,8 @@ editHpackPackage fp modulePath pkgName = do then J.WorkspaceEdit Nothing (Just (J.List [textDocEdit])) else J.WorkspaceEdit (Just (HM.singleton docUri (J.List [textEdit]))) Nothing - return $ IdeResultOk wsEdit - Nothing -> return $ IdeResultFail (IdeError PluginError "Couldn't parse package.yaml" Null) + return $ Right wsEdit + Nothing -> ideError @String PluginError "Couldn't parse package.yaml" where @@ -269,7 +270,7 @@ editCabalPackage file modulePath pkgName fileMap = do let newContents = T.pack $ PP.showGenericPackageDescription newPackage - IdeResultOk <$> makeAdditiveDiffResult file newContents fileMap + Right <$> makeAdditiveDiffResult file newContents fileMap where @@ -320,7 +321,7 @@ codeActionProvider plId docId _ context = do res <- mapM (bimapM return Hoogle.searchPackages) pkgs actions <- catMaybes <$> mapM (uncurry (mkAddPackageAction mRootDir)) (concatPkgs res) - return (IdeResultOk actions) + return $ Right actions where concatPkgs = concatMap (\(d, ts) -> map (d,) ts) diff --git a/src/Haskell/Ide/Engine/Plugin/Pragmas.hs b/src/Haskell/Ide/Engine/Plugin/Pragmas.hs index ba1e973b5..12e2160f6 100644 --- a/src/Haskell/Ide/Engine/Plugin/Pragmas.hs +++ b/src/Haskell/Ide/Engine/Plugin/Pragmas.hs @@ -59,7 +59,7 @@ addPragmaCmd (AddPragmaParams uri pragmaName) = do res = J.WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - return $ IdeResultOk res + return $ Right res -- --------------------------------------------------------------------- @@ -68,7 +68,7 @@ addPragmaCmd (AddPragmaParams uri pragmaName) = do codeActionProvider :: CodeActionProvider codeActionProvider plId docId _ (J.CodeActionContext (J.List diags) _monly) = do cmds <- mapM mkCommand pragmas - return $ IdeResultOk cmds + return $ Right cmds where -- Filter diagnostics that are from ghcmod ghcDiags = filter (\d -> d ^. J.source == Just "bios") diags diff --git a/src/Haskell/Ide/Engine/Scheduler.hs b/src/Haskell/Ide/Engine/Scheduler.hs index c155d15e8..c256f5367 100644 --- a/src/Haskell/Ide/Engine/Scheduler.hs +++ b/src/Haskell/Ide/Engine/Scheduler.hs @@ -303,8 +303,8 @@ ideDispatcher env errorHandler callbackHandler pin = unlessCancelled env lid errorHandler $ liftIO $ do completedReq env lid case result of - IdeResultOk x -> callbackHandler callback x - IdeResultFail (IdeError _ msg _) -> + Right x -> callbackHandler callback x + Left (IdeError _ msg _) -> errorHandler (Just lid) J.InternalError msg liftIO $ traceEventIO $ "STOP " ++ show tn ++ "ide:" ++ d @@ -356,8 +356,8 @@ ghcDispatcher env@DispatcherEnv { docVersionTVar } errorHandler publishDiagnosti runWithCallback = do result <- runner (pure def) action liftIO $ case join result of - IdeResultOk x -> callbackHandler callback x - IdeResultFail err@(IdeError _ msg _) -> do + Right x -> callbackHandler callback x + Left err@(IdeError _ msg _) -> do logm $ "ghcDispatcher:Got error for a request: " ++ show err ++ " with mid: " ++ show mid errorHandler mid J.InternalError msg diff --git a/src/Haskell/Ide/Engine/Server.hs b/src/Haskell/Ide/Engine/Server.hs index 5191d45c7..c0181e08c 100644 --- a/src/Haskell/Ide/Engine/Server.hs +++ b/src/Haskell/Ide/Engine/Server.hs @@ -285,7 +285,7 @@ getPrefixAtPos uri pos = do -- TODO: generalise this and move it to GhcMod.ModuleLoader updatePositionMap :: Uri -> [J.TextDocumentContentChangeEvent] -> IdeGhcM (IdeResult ()) updatePositionMap uri changes = pluginGetFile "updatePositionMap: " uri $ \file -> - ifCachedInfo file (IdeResultOk ()) $ \info -> do + ifCachedInfo file (Right ()) $ \info -> do let n2oOld = newPosToOld info o2nOld = oldPosToNew info (n2o,o2n) = foldl' go (n2oOld, o2nOld) changes @@ -294,7 +294,7 @@ updatePositionMap uri changes = pluginGetFile "updatePositionMap: " uri $ \file go _ _ = (const Nothing, const Nothing) let info' = info {newPosToOld = n2o, oldPosToNew = o2n} cacheInfoNoClear file info' - return $ IdeResultOk () + return $ Right () where f (+/-) (J.Range (Position sl sc) (Position el ec)) txt p@(Position l c) @@ -471,7 +471,7 @@ reactor inp diagIn = do fmServerLogMessageNotification J.MtLog $ "Using hie version: " <> T.pack hieVersion renv <- ask - let hreq = GReq tn "init-hoogle" Nothing Nothing Nothing callback Nothing $ IdeResultOk <$> Hoogle.initializeHoogleDb + let hreq = GReq tn "init-hoogle" Nothing Nothing Nothing callback Nothing $ Right <$> Hoogle.initializeHoogleDb callback Nothing = flip runReaderT renv $ reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning "No hoogle db found. Check the README for instructions to generate one" @@ -544,7 +544,7 @@ reactor inp diagIn = do makeRequest $ GReq tn "delete-cache" (Just uri) Nothing Nothing (const $ return ()) () $ do forM_ (uriToFilePath uri) deleteCachedModule - return $ IdeResultOk () + return $ Right () -- ------------------------------- @@ -695,7 +695,7 @@ reactor inp diagIn = do callback res = do let rspMsg = Core.makeResponseMessage req $ res reactorSend $ RspCompletionItemResolve rspMsg - hreq = IReq tn "completion" (req ^. J.id) callback $ runIdeResultT $ do + hreq = IReq tn "completion" (req ^. J.id) callback $ runExceptT $ lift $ lift $ Completions.resolveCompletion snippets origCompl makeRequest hreq @@ -862,7 +862,7 @@ getFormattingProvider = do let msg = providerName <> " is not a recognised plugin for formatting. Check your config" reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg - return (\_ _ _ _ -> return (IdeResultOk [])) -- nop formatter + return $ \_ _ _ _ -> return $ Right [] -- nop formatter Just (_, provider) -> return provider -- --------------------------------------------------------------------- diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index 2238922e6..9ad947dab 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} module Haskell.Ide.Engine.Support.HieExtras ( getDynFlags , getTypeForName @@ -184,14 +185,14 @@ symbolFromTypecheckedModule lm pos = getReferencesInDoc :: Uri -> Position -> IdeDeferM (IdeResult [J.DocumentHighlight]) getReferencesInDoc uri pos = pluginGetFile "getReferencesInDoc: " uri $ \file -> - withCachedModuleAndData file (IdeResultOk []) $ + withCachedModuleAndData file (Right []) $ \tcMod info NMD{inverseNameMap} -> do let lm = locMap info pm = tm_parsed_module tcMod cfile = ml_hs_file $ ms_location $ pm_mod_summary pm mpos = newPosToOld info pos case mpos of - Nothing -> return $ IdeResultOk [] + Nothing -> return $ Right [] Just pos' -> return $ fmap concat $ forM (getArtifactsAtPos pos' lm) $ \(_,name) -> do let usages = fromMaybe [] $ Map.lookup name inverseNameMap @@ -265,7 +266,7 @@ findTypeDef :: Uri -> Position -> IdeDeferM (IdeResult [Location]) findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> withCachedInfo file - (IdeResultOk []) -- Default result + (Right []) -- Default result (\info -> do let rfm = revMap info tmap = typeMap info @@ -297,7 +298,7 @@ findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> Just s -> Right s runExceptT (getTypeSrcSpanFromPosition oldPos) >>= \case - Left () -> return $ IdeResultOk [] + Left () -> return $ Right [] Right realSpan -> lift $ srcSpanToFileLocation "hare:findTypeDef" rfm realSpan ) @@ -305,7 +306,7 @@ findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> -- | Return the definition findDef :: Uri -> Position -> IdeDeferM (IdeResult [Location]) findDef uri pos = pluginGetFile "findDef: " uri $ \file -> - withCachedInfo file (IdeResultOk []) (\info -> do + withCachedInfo file (Right []) (\info -> do let rfm = revMap info lm = locMap info mm = moduleMap info @@ -314,10 +315,10 @@ findDef uri pos = pluginGetFile "findDef: " uri $ \file -> case (\x -> Just $ getArtifactsAtPos x mm) =<< oldPos of Just ((_,mn):_) -> gotoModule rfm mn _ -> case symbolFromTypecheckedModule lm =<< oldPos of - Nothing -> return $ IdeResultOk [] + Nothing -> return $ Right [] Just (_, n) -> case nameSrcSpan n of - UnhelpfulSpan _ -> return $ IdeResultOk [] + UnhelpfulSpan _ -> return $ Right [] realSpan -> lift $ srcSpanToFileLocation "hare:findDef" rfm realSpan ) @@ -332,17 +333,14 @@ srcSpanToFileLocation invoker rfm srcSpan = do case res of Right l@(J.Location luri range) -> case uriToFilePath luri of - Nothing -> return $ IdeResultOk [l] - Just fp -> ifCachedModule fp (IdeResultOk [l]) $ \(_ :: ParsedModule) info' -> + Nothing -> return $ Right [l] + Just fp -> ifCachedModule fp (Right [l]) $ \(_ :: ParsedModule) info' -> case oldRangeToNew info' range of - Just r -> return $ IdeResultOk [J.Location luri r] - Nothing -> return $ IdeResultOk [l] + Just r -> return $ Right [J.Location luri r] + Nothing -> return $ Right [l] Left x -> do debugm (T.unpack invoker <> ": name srcspan not found/valid") - pure (IdeResultFail - (IdeError PluginError - (invoker <> ": \"" <> x <> "\"") - Null)) + ideError PluginError $ invoker <> ": \"" <> x <> "\"" -- | Goto given module. gotoModule :: (FilePath -> FilePath) -> ModuleName -> IdeDeferM (IdeResult [Location]) @@ -365,10 +363,9 @@ gotoModule rfm mn = do let r = Range (Position 0 0) (Position 0 0) loc = Location (filePathToUri fp) r - return (IdeResultOk [loc]) - _ -> return (IdeResultOk []) - Nothing -> return $ IdeResultFail - (IdeError PluginError "Couldn't get hscEnv when finding import" Null) + return $ Right [loc] + _ -> return $ Right [] + Nothing -> ideError @String PluginError "Couldn't get hscEnv when finding import" -- --------------------------------------------------------------------- data HarePoint = @@ -390,11 +387,9 @@ instance ToJSON HarePoint where runGhcModCommand :: IdeGhcM a -> IdeGhcM (IdeResult a) runGhcModCommand cmd = - (IdeResultOk <$> cmd) `gcatch` + (Right <$> cmd) `gcatch` \(e :: GM.GhcModError) -> - return $ - IdeResultFail $ - IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null + ideErrorFrom PluginError "hie-ghc-mod" $ show e -} -- --------------------------------------------------------------------- @@ -407,7 +402,7 @@ splitCaseCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) splitCaseCmd' uri newPos = pluginGetFile "splitCaseCmd: " uri $ \path -> do origText <- GM.withMappedFile path $ liftIO . T.readFile - ifCachedModule path (IdeResultOk mempty) $ \tm info -> runGhcModCommand $ + ifCachedModule path (Right mempty) $ \tm info -> runGhcModCommand $ case newPosToOld info newPos of Just oldPos -> do let (line, column) = unPos oldPos diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index 106cce7cc..fbd464d5a 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -143,11 +143,11 @@ funcSpec = describe "functional dispatch" $ do let hoverReqHandler :: TypecheckedModule -> CachedInfo -> IdeDeferM (IdeResult Cached) - hoverReqHandler _ _ = return (IdeResultOk Cached) + hoverReqHandler _ _ = return $ Right Cached -- Model a hover request hoverReq tn idVal doc = dispatchIdeRequest tn ("IReq " ++ show idVal) scheduler logChan idVal $ do pluginGetFile "hoverReq" doc $ \fp -> - ifCachedModule fp (IdeResultOk NotCached) hoverReqHandler + ifCachedModule fp (Right NotCached) hoverReqHandler unpackRes (r,Right md) = (r, fromDynJSON md) unpackRes r = error $ "unpackRes:" ++ show r diff --git a/test/plugin-dispatcher/Main.hs b/test/plugin-dispatcher/Main.hs index db356c5cc..9e7ba80ce 100644 --- a/test/plugin-dispatcher/Main.hs +++ b/test/plugin-dispatcher/Main.hs @@ -36,11 +36,11 @@ newPluginSpec = do let defCallback = atomically . writeTChan outChan delayedCallback = \r -> threadDelay 10000 >> defCallback r - let req0 = GReq 0 "0" Nothing Nothing (Just $ IdInt 0) (\_ -> return () :: IO ()) "none" $ return $ IdeResultOk $ T.pack "text0" - req1 = GReq 1 "1" Nothing Nothing (Just $ IdInt 1) defCallback "none" $ return $ IdeResultOk $ T.pack "text1" - req2 = GReq 2 "2" Nothing Nothing (Just $ IdInt 2) delayedCallback "none" $ return $ IdeResultOk $ T.pack "text2" - req3 = GReq 3 "3" Nothing (Just (filePathToUri "test", 2)) Nothing defCallback "none" $ return $ IdeResultOk $ T.pack "text3" - req4 = GReq 4 "4" Nothing Nothing (Just $ IdInt 3) defCallback "none" $ return $ IdeResultOk $ T.pack "text4" + let req0 = GReq 0 "0" Nothing Nothing (Just $ IdInt 0) (\_ -> return () :: IO ()) "none" $ return $ Right $ T.pack "text0" + req1 = GReq 1 "1" Nothing Nothing (Just $ IdInt 1) defCallback "none" $ return $ Right $ T.pack "text1" + req2 = GReq 2 "2" Nothing Nothing (Just $ IdInt 2) delayedCallback "none" $ return $ Right $ T.pack "text2" + req3 = GReq 3 "3" Nothing (Just (filePathToUri "test", 2)) Nothing defCallback "none" $ return $ Right $ T.pack "text3" + req4 = GReq 4 "4" Nothing Nothing (Just $ IdInt 3) defCallback "none" $ return $ Right $ T.pack "text4" let makeReq = sendRequest scheduler diff --git a/test/unit/ApplyRefactPluginSpec.hs b/test/unit/ApplyRefactPluginSpec.hs index 408594be7..1fdd1b6ed 100644 --- a/test/unit/ApplyRefactPluginSpec.hs +++ b/test/unit/ApplyRefactPluginSpec.hs @@ -45,7 +45,7 @@ applyRefactSpec = do act = applyOneCmd arg arg = AOP furi (toPos (2,8)) "Redundant bracket" textEdits = List [TextEdit (Range (Position 1 0) (Position 1 25)) "main = putStrLn \"hello\""] - res = IdeResultOk $ WorkspaceEdit + res = Right $ WorkspaceEdit (Just $ H.singleton applyRefactPath textEdits) Nothing testCommand testPlugins applyRefactFp act "applyrefact" "applyOne" arg res @@ -58,7 +58,7 @@ applyRefactSpec = do arg = applyRefactPath textEdits = List [ TextEdit (Range (Position 1 0) (Position 1 25)) "main = putStrLn \"hello\"" , TextEdit (Range (Position 3 0) (Position 3 15)) "foo x = x + 1" ] - res = IdeResultOk $ WorkspaceEdit + res = Right $ WorkspaceEdit (Just $ H.singleton applyRefactPath textEdits) Nothing testCommand testPlugins applyRefactFp act "applyrefact" "applyAll" arg res @@ -68,7 +68,7 @@ applyRefactSpec = do it "returns hints as diagnostics" $ do let act = lint applyRefactPath - res = IdeResultOk + res = Right PublishDiagnosticsParams { _uri = applyRefactPath , _diagnostics = List $ @@ -94,7 +94,7 @@ applyRefactSpec = do let filePath = filePathToUri filePathNoUri let act = lint filePath - res = IdeResultOk + res = Right PublishDiagnosticsParams { _uri = filePath , _diagnostics = List @@ -114,20 +114,19 @@ applyRefactSpec = do let filePath = filePathToUri fp let req = lint filePath r <- runIGM testPlugins fp req - r `shouldBe` - (IdeResultOk - (PublishDiagnosticsParams - { _uri = filePath - , _diagnostics = List - [ Diagnostic (Range (Position 3 11) (Position 3 20)) - (Just DsInfo) - (Just (StringValue "Redundant bracket")) - (Just "hlint") - "Redundant bracket\nFound:\n (\"hello\")\nWhy not:\n \"hello\"\n" - Nothing - ] - } - )) + r `shouldBe` Right + PublishDiagnosticsParams + { _uri = filePath + , _diagnostics = List + [ Diagnostic (Range (Position 3 11) (Position 3 20)) + (Just DsInfo) + (Just (StringValue "Redundant bracket")) + (Just "hlint") + "Redundant bracket\nFound:\n (\"hello\")\nWhy not:\n \"hello\"\n" + Nothing + ] + } + -- --------------------------------- @@ -137,14 +136,12 @@ applyRefactSpec = do let req = lint filePath r <- withCurrentDirectory "./test/testdata" $ runIGM testPlugins fp req - r `shouldBe` - (IdeResultOk - (PublishDiagnosticsParams - -- { _uri = filePathToUri "./HlintPragma.hs" - { _uri = filePath - , _diagnostics = List [] - } - )) + r `shouldBe` Right + PublishDiagnosticsParams + -- { _uri = filePathToUri "./HlintPragma.hs" + { _uri = filePath + , _diagnostics = List [] + } -- --------------------------------- @@ -152,7 +149,7 @@ applyRefactSpec = do fp <- makeAbsolute "./test/testdata/ApplyRefactError.hs" let filePath = filePathToUri fp let req = applyAllCmd filePath - isExpectedError (IdeResultFail (IdeError PluginError err _)) = + isExpectedError (Left (IdeError PluginError err _)) = "Illegal symbol " `T.isInfixOf` err isExpectedError _ = False r <- withCurrentDirectory "./test/testdata" $ runIGM testPlugins fp req diff --git a/test/unit/ContextSpec.hs b/test/unit/ContextSpec.hs index 722325098..a3860221d 100644 --- a/test/unit/ContextSpec.hs +++ b/test/unit/ContextSpec.hs @@ -22,10 +22,10 @@ spec = describe "Context of different cursor positions" $ do $ do fp <- makeAbsolute "./ExampleContext.hs" let arg = filePathToUri fp - let res = IdeResultOk (Nothing :: Maybe Context) + let res = Right (Nothing :: Maybe Context) actual <- runSingle (IdePlugins mempty) fp $ do _ <- setTypecheckedModule arg - return $ IdeResultOk Nothing + return $ Right Nothing actual `shouldBe` res @@ -33,7 +33,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just (ModuleContext "ExampleContext")) + let res = Right $ Just $ ModuleContext "ExampleContext" actual <- getContextAt fp (toPos (1, 10)) @@ -44,42 +44,42 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just ExportContext) + let res = Right $ Just ExportContext actual <- getContextAt fp (toPos (1, 24)) actual `shouldBe` res it "value context" $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just ValueContext) + let res = Right $ Just ValueContext actual <- getContextAt fp (toPos (7, 6)) actual `shouldBe` res it "value addition context" $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just ValueContext) + let res = Right $ Just ValueContext actual <- getContextAt fp (toPos (7, 12)) actual `shouldBe` res it "import context" $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just (ImportContext "Data.List")) + let res = Right $ Just $ ImportContext "Data.List" actual <- getContextAt fp (toPos (3, 8)) actual `shouldBe` res it "import list context" $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just (ImportListContext "Data.List")) + let res = Right $ Just $ ImportListContext "Data.List" actual <- getContextAt fp (toPos (3, 20)) actual `shouldBe` res it "import hiding context" $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just (ImportHidingContext "Control.Monad")) + let res = Right $ Just $ ImportHidingContext "Control.Monad" actual <- getContextAt fp (toPos (4, 32)) actual `shouldBe` res @@ -88,7 +88,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just TypeContext) + let res = Right $ Just TypeContext actual <- getContextAt fp (toPos (6, 1)) actual `shouldBe` res @@ -97,7 +97,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just TypeContext) + let res = Right $ Just TypeContext actual <- getContextAt fp (toPos (6, 8)) actual `shouldBe` res @@ -106,7 +106,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just ValueContext) + let res = Right $ Just ValueContext actual <- getContextAt fp (toPos (7, 1)) actual `shouldBe` res @@ -119,7 +119,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just ValueContext) + let res = Right $ Just ValueContext actual <- getContextAt fp (toPos (9, 10)) actual `shouldBe` res @@ -127,7 +127,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just ValueContext) + let res = Right $ Just ValueContext actual <- getContextAt fp (toPos (10, 10)) actual `shouldBe` res @@ -137,7 +137,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk Nothing + let res = Right Nothing actual <- getContextAt fp (toPos (12, 8)) actual `shouldBe` res @@ -146,7 +146,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just TypeContext) + let res = Right $ Just TypeContext actual <- getContextAt fp (toPos (12, 18)) actual `shouldBe` res @@ -155,7 +155,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk Nothing + let res = Right Nothing actual <- getContextAt fp (toPos (15, 8)) actual `shouldBe` res @@ -165,7 +165,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk Nothing + let res = Right Nothing actual <- getContextAt fp (toPos (16, 7)) actual `shouldBe` res @@ -173,7 +173,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk Nothing + let res = Right Nothing actual <- getContextAt fp (toPos (18, 7)) actual `shouldBe` res @@ -183,7 +183,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk Nothing + let res = Right Nothing actual <- getContextAt fp (toPos (19, 6)) actual `shouldBe` res @@ -194,7 +194,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk Nothing + let res = Right Nothing actual <- getContextAt fp (toPos (13, 9)) actual `shouldBe` res @@ -206,7 +206,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk Nothing + let res = Right Nothing actual <- getContextAt fp (toPos (13, 14)) actual `shouldBe` res @@ -220,7 +220,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just TypeContext) + let res = Right (Just TypeContext) actual <- getContextAt fp (toPos (13, 15)) actual `shouldBe` res @@ -228,7 +228,7 @@ spec = describe "Context of different cursor positions" $ do $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk (Just TypeContext) + let res = Right (Just TypeContext) actual <- getContextAt fp (toPos (13, 18)) actual `shouldBe` res @@ -236,7 +236,7 @@ spec = describe "Context of different cursor positions" $ do -- There is no context it "nothing" $ withCurrentDirectory "./test/testdata/context" $ do fp <- makeAbsolute "./ExampleContext.hs" - let res = IdeResultOk Nothing + let res = Right Nothing actual <- getContextAt fp (toPos (2, 1)) actual `shouldBe` res @@ -246,5 +246,5 @@ getContextAt fp pos = do runSingle (IdePlugins mempty) fp $ do _ <- setTypecheckedModule arg pluginGetFile "getContext: " arg $ \fp_ -> - ifCachedModuleAndData fp_ (IdeResultOk Nothing) $ \tm _ () -> - return $ IdeResultOk $ getContext pos (tm_parsed_module tm) + ifCachedModuleAndData fp_ (Right Nothing) $ \tm _ () -> + return $ Right $ getContext pos (tm_parsed_module tm) diff --git a/test/unit/ExtensibleStateSpec.hs b/test/unit/ExtensibleStateSpec.hs index 3e8489c54..11dfdb92a 100644 --- a/test/unit/ExtensibleStateSpec.hs +++ b/test/unit/ExtensibleStateSpec.hs @@ -28,8 +28,8 @@ extensibleStateSpec = r1 <- makeRequest "test" "cmd1" () r2 <- makeRequest "test" "cmd2" () return (r1,r2) - fmap fromDynJSON (fst r) `shouldBe` IdeResultOk (Just "result:put foo" :: Maybe T.Text) - fmap fromDynJSON (snd r) `shouldBe` IdeResultOk (Just "result:got:\"foo\"" :: Maybe T.Text) + fmap fromDynJSON (fst r) `shouldBe` Right (Just "result:put foo" :: Maybe T.Text) + fmap fromDynJSON (snd r) `shouldBe` Right (Just "result:got:\"foo\"" :: Maybe T.Text) -- --------------------------------------------------------------------- @@ -56,13 +56,13 @@ testDescriptor plId = PluginDescriptor cmd1 :: () -> IdeGhcM (IdeResult T.Text) cmd1 () = do - put (MS1 "foo") - return (IdeResultOk (T.pack "result:put foo")) + put $ MS1 "foo" + return $ Right $ T.pack "result:put foo" cmd2 :: () -> IdeGhcM (IdeResult T.Text) cmd2 () = do - (MS1 v) <- get - return (IdeResultOk (T.pack $ "result:got:" ++ show v)) + MS1 v <- get + return $ Right $ T.pack $ "result:got:" ++ show v newtype MyState1 = MS1 T.Text deriving Typeable diff --git a/test/unit/GenericPluginSpec.hs b/test/unit/GenericPluginSpec.hs index 2fb58a7d2..c73f6d7b0 100644 --- a/test/unit/GenericPluginSpec.hs +++ b/test/unit/GenericPluginSpec.hs @@ -39,13 +39,13 @@ ghcmodSpec = fp <- makeAbsolute "./FileWithWarning.hs" let act = setTypecheckedModule arg arg = filePathToUri fp - IdeResultOk (_,env) <- runSingle testPlugins fp act + Right (_,env) <- runSingle testPlugins fp act case env of [] -> return () [s] -> T.unpack s `shouldStartWith` "Loaded package environment from" ss -> fail $ "got:" ++ show ss let - res = IdeResultOk $ + res = Right (Diagnostics (Map.singleton (toNormalizedUri arg) (S.singleton diag)), env) diag = Diagnostic (Range (toPos (4,7)) (toPos (4,8))) @@ -65,9 +65,9 @@ ghcmodSpec = -- act = lintCmd' uri -- arg = uri -- #if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,2,2,0))) --- res = IdeResultOk (T.pack fp <> ":6:9: Warning: Redundant do\NULFound:\NUL do return (3 + x)\NULPerhaps:\NUL return (3 + x)\n") +-- res = Right $ T.pack fp <> ":6:9: Warning: Redundant do\NULFound:\NUL do return (3 + x)\NULPerhaps:\NUL return (3 + x)\n" -- #else --- res = IdeResultOk (T.pack fp <> ":6:9: Warning: Redundant do\NULFound:\NUL do return (3 + x)\NULWhy not:\NUL return (3 + x)\n") +-- res = Right $ T.pack fp <> ":6:9: Warning: Redundant do\NULFound:\NUL do return (3 + x)\NULWhy not:\NUL return (3 + x)\n" -- #endif -- testCommand testPlugins act "bios" "lint" arg res @@ -78,7 +78,7 @@ ghcmodSpec = -- let uri = filePathToUri fp -- act = infoCmd' uri "main" -- arg = IP uri "main" - -- res = IdeResultOk "main :: IO () \t-- Defined at HaReRename.hs:2:1\n" + -- res = Right "main :: IO () \t-- Defined at HaReRename.hs:2:1\n" -- -- ghc-mod tries to load the test file in the context of the hie project if we do not cd first. -- testCommand testPlugins act "bios" "info" arg res @@ -91,7 +91,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (5,9)) uri arg = TP False uri (toPos (5,9)) - res = IdeResultOk + res = Right [ (Range (toPos (5,9)) (toPos (5,10)), "Int") , (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") ] @@ -105,7 +105,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (2,11)) uri arg = TP False uri (toPos (2,11)) - res = IdeResultOk + res = Right [ (Range (toPos (2, 8)) (toPos (2,16)), "String -> IO ()") , (Range (toPos (2, 1)) (toPos (2,24)), "IO ()") ] @@ -118,7 +118,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (1,1)) uri arg = TP False uri (toPos (1,1)) - res = IdeResultOk [] + res = Right [] testCommand testPlugins fp act "generic" "type" arg res it "runs the type command, simple" $ withCurrentDirectory "./test/testdata" $ do @@ -128,7 +128,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (6,16)) uri arg = TP False uri (toPos (6,16)) - res = IdeResultOk + res = Right [ (Range (toPos (6, 16)) (toPos (6,17)), "Int") , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] @@ -141,7 +141,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (6,6)) uri arg = TP False uri (toPos (6, 6)) - res = IdeResultOk + res = Right [ (Range (toPos (6, 6)) (toPos (6, 12)), "Maybe Int") , (Range (toPos (6, 5)) (toPos (6, 13)), "Maybe Int") , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") @@ -155,7 +155,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (6,11)) uri arg = TP False uri (toPos (6, 11)) - res = IdeResultOk + res = Right [ (Range (toPos (6, 11)) (toPos (6, 12)), "Int") , (Range (toPos (6, 6)) (toPos (6, 12)), "Maybe Int") , (Range (toPos (6, 5)) (toPos (6, 13)), "Maybe Int") @@ -170,7 +170,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (7,5)) uri arg = TP False uri (toPos (7,5)) - res = IdeResultOk + res = Right [ (Range (toPos (7, 5)) (toPos (7, 12)), "Maybe Int") , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] @@ -183,7 +183,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (7,15)) uri arg = TP False uri (toPos (7,15)) - res = IdeResultOk + res = Right [ (Range (toPos (7, 15)) (toPos (7, 16)), "Int") , (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int") ] @@ -196,7 +196,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (10,5)) uri arg = TP False uri (toPos (10,5)) - res = IdeResultOk + res = Right [ (Range (toPos (10, 5)) (toPos (10, 6)), "Maybe Int") , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") ] @@ -209,7 +209,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (10,14)) uri arg = TP False uri (toPos (10,14)) - res = IdeResultOk + res = Right [ (Range (toPos (10, 14)) (toPos (10, 15)), "Maybe Int") , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") @@ -223,7 +223,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (11,5)) uri arg = TP False uri (toPos (11,5)) - res = IdeResultOk + res = Right [ (Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int") , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") @@ -237,7 +237,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (11,10)) uri arg = TP False uri (toPos (11,10)) - res = IdeResultOk + res = Right [ (Range (toPos (11, 10)) (toPos (11, 11)), "Int") , (Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int") , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") @@ -252,7 +252,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (11,17)) uri arg = TP False uri (toPos (11,17)) - res = IdeResultOk + res = Right [ (Range (toPos (11, 17)) (toPos (11, 18)), "Int -> Int -> Int") , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") @@ -266,7 +266,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (12,5)) uri arg = TP False uri (toPos (12,5)) - res = IdeResultOk + res = Right [ (Range (toPos (12, 5)) (toPos (12, 12)), "Maybe Int") , (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int") , (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int") @@ -280,7 +280,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (16,5)) uri arg = TP False uri (toPos (16,5)) - res = IdeResultOk + res = Right [ (Range (toPos (16, 5)) (toPos (16, 6)), "Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] @@ -293,7 +293,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (16,10)) uri arg = TP False uri (toPos (16,10)) - res = IdeResultOk + res = Right [ (Range (toPos (16, 10)) (toPos (16, 11)), "Maybe Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] @@ -306,7 +306,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (17,13)) uri arg = TP False uri (toPos (17,13)) - res = IdeResultOk + res = Right [ (Range (toPos (17, 13)) (toPos (17, 19)), "Int -> Maybe Int") , (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") @@ -320,7 +320,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (17,21)) uri arg = TP False uri (toPos (17,21)) - res = IdeResultOk + res = Right [ (Range (toPos (17, 21)) (toPos (17, 22)), "Int") , (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") @@ -334,7 +334,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (17,9)) uri arg = TP False uri (toPos (17,9)) - res = IdeResultOk + res = Right [ (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] @@ -347,7 +347,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (18,10)) uri arg = TP False uri (toPos (18,10)) - res = IdeResultOk + res = Right [ (Range (toPos (18, 10)) (toPos (18, 11)), "Maybe Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] @@ -360,7 +360,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (18,5)) uri arg = TP False uri (toPos (18,5)) - res = IdeResultOk + res = Right [ (Range (toPos (18, 5)) (toPos (18, 6)), "Int") , (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] @@ -373,7 +373,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (15,5)) uri arg = TP False uri (toPos (15,5)) - res = IdeResultOk + res = Right [ (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int") ] testCommand testPlugins fp act "generic" "type" arg res @@ -385,7 +385,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (22,10)) uri arg = TP False uri (toPos (22,10)) - res = IdeResultOk + res = Right [ (Range (toPos (22, 10)) (toPos (22, 11)), "a -> a") , (Range (toPos (22, 1)) (toPos (22, 19)), "(a -> a) -> a -> a") ] @@ -398,7 +398,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (25,26)) uri arg = TP False uri (toPos (25,26)) - res = IdeResultOk + res = Right [ (Range (toPos (25, 26)) (toPos (25, 27)), "(b -> c) -> (a -> b) -> a -> c") , (Range (toPos (25, 20)) (toPos (25, 29)), "a -> c") , (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c") @@ -412,7 +412,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (25,20)) uri arg = TP False uri (toPos (25,20)) - res = IdeResultOk + res = Right [ (Range (toPos (25, 20)) (toPos (25, 29)), "a -> c") , (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c") ] @@ -425,7 +425,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (25,33)) uri arg = TP False uri (toPos (25,33)) - res = IdeResultOk + res = Right [ (Range (toPos (25, 33)) (toPos (25, 34)), "a -> c") , (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c") ] @@ -438,7 +438,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (25,5)) uri arg = TP False uri (toPos (25,5)) - res = IdeResultOk + res = Right [ (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c") ] testCommand testPlugins fp act "generic" "type" arg res @@ -450,7 +450,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (28,25)) uri arg = TP False uri (toPos (28,25)) - res = IdeResultOk + res = Right [ (Range (toPos (28, 25)) (toPos (28, 28)), "(a -> b) -> IO a -> IO b") , (Range (toPos (28, 1)) (toPos (28, 35)), "(a -> b) -> IO a -> IO b") ] @@ -463,7 +463,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (31,7)) uri arg = TP False uri (toPos (31,7)) - res = IdeResultOk + res = Right [ -- (Range (toPos (31, 7)) (toPos (31, 12)), "Int -> Test") ] testCommand testPlugins fp act "generic" "type" arg res @@ -475,7 +475,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (33,15)) uri arg = TP False uri (toPos (33,15)) - res = IdeResultOk + res = Right [ (Range (toPos (33, 15)) (toPos (33, 19)), "(Int -> Test -> ShowS) -> (Test -> String) -> ([Test] -> ShowS) -> Show Test") , (Range (toPos (33, 15)) (toPos (33, 19)), "Int -> Test -> ShowS") , (Range (toPos (33, 15)) (toPos (33, 19)), "Test -> String") @@ -490,7 +490,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (33,21)) uri arg = TP False uri (toPos (33,21)) - res = IdeResultOk + res = Right [ (Range (toPos (33, 21)) (toPos (33, 23)), "(Test -> Test -> Bool) -> (Test -> Test -> Bool) -> Eq Test") , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") , (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool") @@ -510,7 +510,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (5,9)) uri let arg = TP False uri (toPos (5,9)) - let res = IdeResultOk + let res = Right [(Range (toPos (5,9)) (toPos (5,10)), "Int") , (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") ] @@ -525,7 +525,7 @@ ghcmodSpec = -- _ <- setTypecheckedModule uri -- splitCaseCmd' uri (toPos (5,5)) -- arg = HP uri (toPos (5,5)) --- res = IdeResultOk $ WorkspaceEdit +-- res = Right $ WorkspaceEdit -- (Just $ H.singleton uri -- $ List [TextEdit (Range (Position 4 0) (Position 4 10)) -- "foo Nothing = ()\nfoo (Just x) = ()"]) @@ -544,7 +544,7 @@ ghcmodSpec = -- _ <- setTypecheckedModule uri -- splitCaseCmd' uri (toPos (5,5)) -- arg = HP uri (toPos (5,5)) --- res = IdeResultOk $ WorkspaceEdit +-- res = Right $ WorkspaceEdit -- (Just $ H.singleton uri -- $ List [TextEdit (Range (Position 4 0) (Position 4 10)) -- "foo Nothing = ()\nfoo (Just x) = ()"]) diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index d2f84e805..2f95c021b 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -39,13 +39,13 @@ ghcmodSpec = fp <- makeAbsolute "./FileWithWarning.hs" let act = setTypecheckedModule arg arg = filePathToUri fp - IdeResultOk (_,env) <- runSingle testPlugins fp act + Right (_,env) <- runSingle testPlugins fp act case env of [] -> return () [s] -> T.unpack s `shouldStartWith` "Loaded package environment from" ss -> fail $ "got:" ++ show ss let - res = IdeResultOk $ + res = Right (Diagnostics (Map.singleton (toNormalizedUri arg) (S.singleton diag)), env) diag = Diagnostic (Range (toPos (4,7)) (toPos (4,8))) @@ -67,7 +67,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri liftToGhc $ newTypeCmd (toPos (5,9)) uri arg = TP False uri (toPos (5,9)) - res = IdeResultOk + res = Right [ (Range (toPos (5,9)) (toPos (5,10)), "Int") , (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") ] @@ -85,7 +85,7 @@ ghcmodSpec = -- -- splitCaseCmd' uri (toPos (5,5)) -- splitCaseCmd uri (toPos (5,5)) -- arg = HP uri (toPos (5,5)) - -- res = IdeResultOk $ WorkspaceEdit + -- res = Right $ WorkspaceEdit -- (Just $ H.singleton uri -- $ List [TextEdit (Range (Position 4 0) (Position 4 10)) -- "foo Nothing = ()\nfoo (Just x) = ()"]) diff --git a/test/unit/HsImportSpec.hs b/test/unit/HsImportSpec.hs index 5bc2107a7..eca63b9a7 100644 --- a/test/unit/HsImportSpec.hs +++ b/test/unit/HsImportSpec.hs @@ -193,7 +193,7 @@ setFormatter formatterName cfg = cfg { Config.formattingProvider = formatterName expectHsImportResult :: T.Text -> FilePath -> Uri -> [TextEdit] -> IdeGhcM (IdeResult WorkspaceEdit) -> IO () expectHsImportResult formatterName fp uri expectedChanges act = do - IdeResultOk (WorkspaceEdit (Just changes) _) <- runSingle' (setFormatter formatterName) testPlugins fp act + Right (WorkspaceEdit (Just changes) _) <- runSingle' (setFormatter formatterName) testPlugins fp act case Map.lookup uri changes of Just (List val) -> val `shouldBe` expectedChanges Nothing -> fail "No Change found" \ No newline at end of file diff --git a/test/unit/PackagePluginSpec.hs b/test/unit/PackagePluginSpec.hs index 68a5c4151..c4c2a524f 100644 --- a/test/unit/PackagePluginSpec.hs +++ b/test/unit/PackagePluginSpec.hs @@ -105,7 +105,7 @@ packageSpec = do , " text -any" ] ] - res = IdeResultOk + res = Right $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing testCommand testPlugins fp act "package" "add" args res @@ -160,7 +160,7 @@ packageSpec = do , " text -any" ] ] - res = IdeResultOk + res = Right $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing testCommand testPlugins fp act "package" "add" args res @@ -173,7 +173,7 @@ packageSpec = do uri = filePathToUri $ fp "package.yaml" args = AddParams fp (fp "app" "Asdf.hs") "zlib" act = addCmd args - res = IdeResultOk + res = Right $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing textEdits = List [ TextEdit (Range (Position 0 0) (Position 32 0)) $ T.concat @@ -211,7 +211,7 @@ packageSpec = do uri = filePathToUri $ fp "package.yaml" args = AddParams fp (fp "app" "Asdf.hs") "zlib" act = addCmd args - res = IdeResultOk + res = Right $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing textEdits = List @@ -243,10 +243,8 @@ packageSpec = do fp = cwd testdata "invalid" args = AddParams fp (fp "app" "Asdf.hs") "zlib" act = addCmd args - res = - IdeResultFail - (IdeError PluginError - "No package.yaml or .cabal found" - Json.Null - ) + res = Left $ IdeError + PluginError + "No package.yaml or .cabal found" + Json.Null testCommand testPlugins fp act "package" "add" args res