Merge branch 'excepts-refac'
This commit is contained in:
commit
b7007aa100
GPG Key ID:
3786C5262ECB4A3F
@ -7,6 +7,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module GHCup.OptParse.Install where
|
||||
|
||||
@ -19,6 +20,7 @@ import GHCup
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
@ -260,51 +262,7 @@ type InstallEffects = '[ AlreadyInstalled
|
||||
, ProcessError
|
||||
, UninstallFailed
|
||||
, MergeFileTreeError
|
||||
|
||||
, (AlreadyInstalled, ())
|
||||
, (UnknownArchive, ())
|
||||
, (ArchiveResult, ())
|
||||
, (FileDoesNotExistError, ())
|
||||
, (CopyError, ())
|
||||
, (NotInstalled, ())
|
||||
, (UninstallFailed, ())
|
||||
, (MergeFileTreeError, ())
|
||||
, (DirNotEmpty, ())
|
||||
, (NoDownload, ())
|
||||
, (BuildFailed, ())
|
||||
, (TagNotFound, ())
|
||||
, (DigestError, ())
|
||||
, (GPGError, ())
|
||||
, (DownloadFailed, ())
|
||||
, (TarDirDoesNotExist, ())
|
||||
, (NextVerNotFound, ())
|
||||
, (NoToolVersionSet, ())
|
||||
, (FileAlreadyExistsError, ())
|
||||
, (ProcessError, ())
|
||||
|
||||
, (AlreadyInstalled, NotInstalled)
|
||||
, (UnknownArchive, NotInstalled)
|
||||
, (ArchiveResult, NotInstalled)
|
||||
, (FileDoesNotExistError, NotInstalled)
|
||||
, (CopyError, NotInstalled)
|
||||
, (NotInstalled, NotInstalled)
|
||||
, (DirNotEmpty, NotInstalled)
|
||||
, (NoDownload, NotInstalled)
|
||||
, (NotInstalled, NotInstalled)
|
||||
, (UninstallFailed, NotInstalled)
|
||||
, (MergeFileTreeError, NotInstalled)
|
||||
, (BuildFailed, NotInstalled)
|
||||
, (TagNotFound, NotInstalled)
|
||||
, (DigestError, NotInstalled)
|
||||
, (GPGError, NotInstalled)
|
||||
, (DownloadFailed, NotInstalled)
|
||||
, (TarDirDoesNotExist, NotInstalled)
|
||||
, (NextVerNotFound, NotInstalled)
|
||||
, (NoToolVersionSet, NotInstalled)
|
||||
, (FileAlreadyExistsError, NotInstalled)
|
||||
, (ProcessError, NotInstalled)
|
||||
|
||||
, ((), NotInstalled)
|
||||
, InstallSetError
|
||||
]
|
||||
|
||||
|
||||
@ -319,58 +277,27 @@ runInstTool appstate' mInstPlatform =
|
||||
@InstallEffects
|
||||
|
||||
|
||||
type InstallGHCEffects = '[ TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
type InstallGHCEffects = '[ AlreadyInstalled
|
||||
, ArchiveResult
|
||||
, BuildFailed
|
||||
, CopyError
|
||||
, DigestError
|
||||
, DirNotEmpty
|
||||
, AlreadyInstalled
|
||||
, UninstallFailed
|
||||
, DownloadFailed
|
||||
, FileAlreadyExistsError
|
||||
, FileDoesNotExistError
|
||||
, GPGError
|
||||
, MergeFileTreeError
|
||||
|
||||
, (AlreadyInstalled, NotInstalled)
|
||||
, (UnknownArchive, NotInstalled)
|
||||
, (ArchiveResult, NotInstalled)
|
||||
, (FileDoesNotExistError, NotInstalled)
|
||||
, (CopyError, NotInstalled)
|
||||
, (NotInstalled, NotInstalled)
|
||||
, (DirNotEmpty, NotInstalled)
|
||||
, (NoDownload, NotInstalled)
|
||||
, (UninstallFailed, NotInstalled)
|
||||
, (MergeFileTreeError, NotInstalled)
|
||||
, (BuildFailed, NotInstalled)
|
||||
, (TagNotFound, NotInstalled)
|
||||
, (DigestError, NotInstalled)
|
||||
, (GPGError, NotInstalled)
|
||||
, (DownloadFailed, NotInstalled)
|
||||
, (TarDirDoesNotExist, NotInstalled)
|
||||
, (NextVerNotFound, NotInstalled)
|
||||
, (NoToolVersionSet, NotInstalled)
|
||||
, (FileAlreadyExistsError, NotInstalled)
|
||||
, (ProcessError, NotInstalled)
|
||||
|
||||
, (AlreadyInstalled, ())
|
||||
, (UnknownArchive, ())
|
||||
, (ArchiveResult, ())
|
||||
, (FileDoesNotExistError, ())
|
||||
, (CopyError, ())
|
||||
, (NotInstalled, ())
|
||||
, (DirNotEmpty, ())
|
||||
, (NoDownload, ())
|
||||
, (UninstallFailed, ())
|
||||
, (MergeFileTreeError, ())
|
||||
, (BuildFailed, ())
|
||||
, (TagNotFound, ())
|
||||
, (DigestError, ())
|
||||
, (GPGError, ())
|
||||
, (DownloadFailed, ())
|
||||
, (TarDirDoesNotExist, ())
|
||||
, (NextVerNotFound, ())
|
||||
, (NoToolVersionSet, ())
|
||||
, (FileAlreadyExistsError, ())
|
||||
, (ProcessError, ())
|
||||
|
||||
, ((), NotInstalled)
|
||||
, NextVerNotFound
|
||||
, NoDownload
|
||||
, NoToolVersionSet
|
||||
, NotInstalled
|
||||
, ProcessError
|
||||
, TagNotFound
|
||||
, TarDirDoesNotExist
|
||||
, UninstallFailed
|
||||
, UnknownArchive
|
||||
, InstallSetError
|
||||
]
|
||||
|
||||
runInstGHC :: AppState
|
||||
@ -405,23 +332,23 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
(case instBindist of
|
||||
Nothing -> runInstGHC s' instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer GHC
|
||||
void $ liftE $ sequenceE (installGHCBin
|
||||
liftE $ runBothE' (installGHCBin
|
||||
(_tvVersion v)
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
)
|
||||
$ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
|
||||
$ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
|
||||
pure vi
|
||||
Just uri -> do
|
||||
runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
|
||||
(v, vi) <- liftE $ fromVersion instVer GHC
|
||||
void $ liftE $ sequenceE (installGHCBindist
|
||||
liftE $ runBothE' (installGHCBindist
|
||||
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
|
||||
(_tvVersion v)
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
)
|
||||
$ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
|
||||
$ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
@ -431,20 +358,18 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
runLogger $ logInfo msg
|
||||
pure ExitSuccess
|
||||
|
||||
VLeft (V (AlreadyInstalled _ v, ())) -> do
|
||||
runLogger $ logWarn $
|
||||
"GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyShow e
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
runLogger $ logWarn $
|
||||
"GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyShow e
|
||||
pure ExitSuccess
|
||||
|
||||
VLeft (V (DirNotEmpty fp)) -> do
|
||||
runLogger $ logError $
|
||||
"Install directory " <> T.pack fp <> " is not empty."
|
||||
pure $ ExitFailure 3
|
||||
VLeft (V (DirNotEmpty fp, ())) -> do
|
||||
VLeft (V (DirNotEmpty fp)) -> do
|
||||
runLogger $ logError $
|
||||
"Install directory " <> T.pack fp <> " is not empty."
|
||||
pure $ ExitFailure 3
|
||||
@ -456,7 +381,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||
pure $ ExitFailure 3
|
||||
VLeft err@(V (BuildFailed tmpdir _, ())) -> do
|
||||
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
||||
case keepDirs settings of
|
||||
Never -> runLogger (logError $ T.pack $ prettyShow err)
|
||||
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
|
||||
@ -477,21 +402,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool s' instPlatform $ do
|
||||
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
|
||||
void $ liftE $ sequenceE (installCabalBin
|
||||
liftE $ runBothE' (installCabalBin
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
|
||||
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
|
||||
pure vi
|
||||
Just uri -> do
|
||||
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
|
||||
void $ liftE $ sequenceE (installCabalBindist
|
||||
liftE $ runBothE' (installCabalBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
|
||||
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
@ -500,19 +425,17 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ logInfo msg
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
runLogger $ logWarn $
|
||||
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyShow e
|
||||
pure ExitSuccess
|
||||
VLeft (V (FileAlreadyExistsError fp)) -> do
|
||||
runLogger $ logWarn $
|
||||
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
|
||||
pure $ ExitFailure 3
|
||||
VLeft (V (AlreadyInstalled _ v, ())) -> do
|
||||
runLogger $ logWarn $
|
||||
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyShow e
|
||||
pure ExitSuccess
|
||||
VLeft (V (FileAlreadyExistsError fp, ())) -> do
|
||||
VLeft (V (FileAlreadyExistsError fp)) -> do
|
||||
runLogger $ logWarn $
|
||||
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
|
||||
pure $ ExitFailure 3
|
||||
@ -528,22 +451,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool s' instPlatform $ do
|
||||
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
|
||||
void $ liftE $ sequenceE (installHLSBin
|
||||
liftE $ runBothE' (installHLSBin
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
|
||||
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
|
||||
pure vi
|
||||
Just uri -> do
|
||||
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
|
||||
-- TODO: support legacy
|
||||
void $ liftE $ sequenceE (installHLSBindist
|
||||
liftE $ runBothE' (installHLSBindist
|
||||
(DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
|
||||
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
@ -552,27 +475,17 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ logInfo msg
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
runLogger $ logWarn $
|
||||
"HLS ver "
|
||||
<> prettyVer v
|
||||
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
|
||||
<> prettyVer v
|
||||
<> "'"
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyShow e
|
||||
pure ExitSuccess
|
||||
VLeft (V (FileAlreadyExistsError fp)) -> do
|
||||
runLogger $ logWarn $
|
||||
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
|
||||
pure $ ExitFailure 3
|
||||
VLeft (V (AlreadyInstalled _ v, ())) -> do
|
||||
runLogger $ logWarn $
|
||||
"HLS ver "
|
||||
<> prettyVer v
|
||||
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
|
||||
<> prettyVer v
|
||||
<> "'"
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyShow e
|
||||
pure ExitSuccess
|
||||
VLeft (V (FileAlreadyExistsError fp, ())) -> do
|
||||
VLeft (V (FileAlreadyExistsError fp)) -> do
|
||||
runLogger $ logWarn $
|
||||
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
|
||||
pure $ ExitFailure 3
|
||||
@ -588,21 +501,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
(case instBindist of
|
||||
Nothing -> runInstTool s' instPlatform $ do
|
||||
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
|
||||
void $ liftE $ sequenceE (installStackBin
|
||||
liftE $ runBothE' (installStackBin
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
|
||||
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
|
||||
pure vi
|
||||
Just uri -> do
|
||||
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
|
||||
void $ liftE $ sequenceE (installStackBindist
|
||||
liftE $ runBothE' (installStackBindist
|
||||
(DownloadInfo uri Nothing "")
|
||||
v
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
|
||||
) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
|
||||
pure vi
|
||||
)
|
||||
>>= \case
|
||||
@ -611,19 +524,17 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ logInfo msg
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
runLogger $ logWarn $
|
||||
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyShow e
|
||||
pure ExitSuccess
|
||||
VLeft (V (FileAlreadyExistsError fp)) -> do
|
||||
runLogger $ logWarn $
|
||||
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
|
||||
pure $ ExitFailure 3
|
||||
VLeft (V (AlreadyInstalled _ v, ())) -> do
|
||||
runLogger $ logWarn $
|
||||
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
|
||||
VLeft e@(V (AlreadyInstalled _ _)) -> do
|
||||
runLogger $ logWarn $ T.pack $ prettyShow e
|
||||
pure ExitSuccess
|
||||
VLeft (V (FileAlreadyExistsError fp, ())) -> do
|
||||
VLeft (V (FileAlreadyExistsError fp)) -> do
|
||||
runLogger $ logWarn $
|
||||
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
|
||||
pure $ ExitFailure 3
|
||||
|
||||
@ -241,6 +241,7 @@ executable ghcup
|
||||
, directory ^>=1.3.6.0
|
||||
, filepath ^>=1.4.2.1
|
||||
, ghcup
|
||||
, haskus-utils-types ^>=1.5
|
||||
, haskus-utils-variant ^>=3.2.1
|
||||
, libarchive ^>=3.0.3.0
|
||||
, megaparsec >=8.0.0 && <9.3
|
||||
|
||||
@ -137,10 +137,13 @@ data AlreadyInstalled = AlreadyInstalled Tool Version
|
||||
|
||||
instance Pretty AlreadyInstalled where
|
||||
pPrint (AlreadyInstalled tool ver') =
|
||||
pPrint tool <+> text "-" <+> pPrint ver' <+> text "is already installed"
|
||||
pPrint tool <+> text "-" <+> pPrint ver' <+> text "is already installed;"
|
||||
<+> text "if you really want to reinstall it, you may want to run 'ghcup install cabal --force" <+> (pPrint ver' <> text "'")
|
||||
|
||||
|
||||
-- | The Directory is supposed to be empty, but wasn't.
|
||||
data DirNotEmpty = DirNotEmpty {path :: FilePath}
|
||||
deriving Show
|
||||
|
||||
instance Pretty DirNotEmpty where
|
||||
pPrint (DirNotEmpty path) = do
|
||||
@ -344,6 +347,17 @@ instance Pretty DownloadFailed where
|
||||
|
||||
deriving instance Show DownloadFailed
|
||||
|
||||
data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), Show (V xs2), Pretty (V xs2)) => InstallSetError (V xs1) (V xs2)
|
||||
|
||||
instance Pretty InstallSetError where
|
||||
pPrint (InstallSetError reason1 reason2) =
|
||||
text "Both installation and setting the tool failed. Install error was:"
|
||||
<+> pPrint reason1
|
||||
<+> text "\nSet error was:"
|
||||
<+> pPrint reason2
|
||||
|
||||
deriving instance Show InstallSetError
|
||||
|
||||
|
||||
-- | A build failed.
|
||||
data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Prelude
|
||||
@ -27,6 +28,7 @@ module GHCup.Prelude
|
||||
)
|
||||
where
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Prelude.Internal
|
||||
import GHCup.Types.Optics (HasLog)
|
||||
import GHCup.Prelude.Logger (logWarn)
|
||||
@ -52,3 +54,29 @@ catchWarn :: forall es m env . ( Pretty (V es)
|
||||
, Monad m) => Excepts es m () -> Excepts '[] m ()
|
||||
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
|
||||
|
||||
|
||||
runBothE' :: forall e m a b .
|
||||
( Monad m
|
||||
, Show (V e)
|
||||
, Pretty (V e)
|
||||
, PopVariant InstallSetError e
|
||||
, LiftVariant' e (InstallSetError ': e)
|
||||
, e :<< (InstallSetError ': e)
|
||||
)
|
||||
=> Excepts e m a
|
||||
-> Excepts e m b
|
||||
-> Excepts (InstallSetError ': e) m ()
|
||||
runBothE' a1 a2 = do
|
||||
r1 <- lift $ runE @e a1
|
||||
r2 <- lift $ runE @e a2
|
||||
case (r1, r2) of
|
||||
(VLeft e1, VLeft e2) -> throwE (InstallSetError e1 e2)
|
||||
(VLeft e , _ ) -> throwSomeE e
|
||||
(_ , VLeft e ) -> throwSomeE e
|
||||
(VRight _, VRight _) -> pure ()
|
||||
|
||||
|
||||
-- | Throw some exception
|
||||
throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excepts es m a
|
||||
{-# INLINABLE throwSomeE #-}
|
||||
throwSomeE = Excepts . pure . VLeft . liftVariant
|
||||
|
||||
Loading…
Reference in New Issue
Block a user