hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'excepts-refac'

Browse Source
This commit is contained in:
Julian Ospald 2022-05-24 12:44:39 +02:00
commit b7007aa100
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
4 changed files with 102 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

205
app/ghcup/GHCup/OptParse/Install.hs
View File

@ -7,6 +7,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.OptParse.Install where module GHCup.OptParse.Install where
@ -19,6 +20,7 @@ import GHCup
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Prelude
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ import GHCup.Prelude.String.QQ
@ -260,51 +262,7 @@ type InstallEffects = '[ AlreadyInstalled
, ProcessError , ProcessError
, UninstallFailed , UninstallFailed
, MergeFileTreeError , MergeFileTreeError
, InstallSetError
, (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)
] ]
@ -319,58 +277,27 @@ runInstTool appstate' mInstPlatform =
@InstallEffects @InstallEffects
type InstallGHCEffects = '[ TagNotFound type InstallGHCEffects = '[ AlreadyInstalled
, NextVerNotFound , ArchiveResult
, NoToolVersionSet
, BuildFailed , BuildFailed
, CopyError
, DigestError
, DirNotEmpty , DirNotEmpty
, AlreadyInstalled , DownloadFailed
, UninstallFailed , FileAlreadyExistsError
, FileDoesNotExistError
, GPGError
, MergeFileTreeError , MergeFileTreeError
, NextVerNotFound
, (AlreadyInstalled, NotInstalled) , NoDownload
, (UnknownArchive, NotInstalled) , NoToolVersionSet
, (ArchiveResult, NotInstalled) , NotInstalled
, (FileDoesNotExistError, NotInstalled) , ProcessError
, (CopyError, NotInstalled) , TagNotFound
, (NotInstalled, NotInstalled) , TarDirDoesNotExist
, (DirNotEmpty, NotInstalled) , UninstallFailed
, (NoDownload, NotInstalled) , UnknownArchive
, (UninstallFailed, NotInstalled) , InstallSetError
, (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)
] ]
runInstGHC :: AppState runInstGHC :: AppState
@ -405,23 +332,23 @@ install installCommand settings getAppState' runLogger = case installCommand of
(case instBindist of (case instBindist of
Nothing -> runInstGHC s' instPlatform $ do Nothing -> runInstGHC s' instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
void $ liftE $ sequenceE (installGHCBin liftE $ runBothE' (installGHCBin
(_tvVersion v) (_tvVersion v)
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) )
$ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
pure vi pure vi
Just uri -> do Just uri -> do
runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
void $ liftE $ sequenceE (installGHCBindist liftE $ runBothE' (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v) (_tvVersion v)
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) )
$ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
pure vi pure vi
) )
>>= \case >>= \case
@ -431,20 +358,18 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v, ())) -> do VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ runLogger $ logWarn $ T.pack $ prettyShow e
"GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ runLogger $ logWarn $ T.pack $ prettyShow e
"GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
pure ExitSuccess pure ExitSuccess
VLeft (V (DirNotEmpty fp)) -> do VLeft (V (DirNotEmpty fp)) -> do
runLogger $ logError $ runLogger $ logError $
"Install directory " <> T.pack fp <> " is not empty." "Install directory " <> T.pack fp <> " is not empty."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft (V (DirNotEmpty fp, ())) -> do VLeft (V (DirNotEmpty fp)) -> do
runLogger $ logError $ runLogger $ logError $
"Install directory " <> T.pack fp <> " is not empty." "Install directory " <> T.pack fp <> " is not empty."
pure $ ExitFailure 3 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" <> "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.") "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _, ())) -> do VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err) Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <> _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
@ -477,21 +402,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
(case instBindist of (case instBindist of
Nothing -> runInstTool s' instPlatform $ do Nothing -> runInstTool s' instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
void $ liftE $ sequenceE (installCabalBin liftE $ runBothE' (installCabalBin
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
pure vi pure vi
Just uri -> do Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
void $ liftE $ sequenceE (installCabalBindist liftE $ runBothE' (installCabalBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v
pure vi pure vi
) )
>>= \case >>= \case
@ -500,19 +425,17 @@ install installCommand settings getAppState' runLogger = case installCommand of
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ runLogger $ logWarn $ T.pack $ prettyShow e
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft (V (AlreadyInstalled _ v, ())) -> do VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ runLogger $ logWarn $ T.pack $ prettyShow e
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp, ())) -> do VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 pure $ ExitFailure 3
@ -528,22 +451,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
(case instBindist of (case instBindist of
Nothing -> runInstTool s' instPlatform $ do Nothing -> runInstTool s' instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
void $ liftE $ sequenceE (installHLSBin liftE $ runBothE' (installHLSBin
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
pure vi pure vi
Just uri -> do Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-- TODO: support legacy -- TODO: support legacy
void $ liftE $ sequenceE (installHLSBindist liftE $ runBothE' (installHLSBindist
(DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "") (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing
pure vi pure vi
) )
>>= \case >>= \case
@ -552,27 +475,17 @@ install installCommand settings getAppState' runLogger = case installCommand of
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ runLogger $ logWarn $ T.pack $ prettyShow e
"HLS ver "
<> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
<> prettyVer v
<> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft (V (AlreadyInstalled _ v, ())) -> do VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ runLogger $ logWarn $ T.pack $ prettyShow e
"HLS ver "
<> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
<> prettyVer v
<> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp, ())) -> do VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 pure $ ExitFailure 3
@ -588,21 +501,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
(case instBindist of (case instBindist of
Nothing -> runInstTool s' instPlatform $ do Nothing -> runInstTool s' instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
void $ liftE $ sequenceE (installStackBin liftE $ runBothE' (installStackBin
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
pure vi pure vi
Just uri -> do Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
void $ liftE $ sequenceE (installStackBindist liftE $ runBothE' (installStackBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v
pure vi pure vi
) )
>>= \case >>= \case
@ -611,19 +524,17 @@ install installCommand settings getAppState' runLogger = case installCommand of
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ runLogger $ logWarn $ T.pack $ prettyShow e
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft (V (AlreadyInstalled _ v, ())) -> do VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ runLogger $ logWarn $ T.pack $ prettyShow e
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
pure ExitSuccess pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp, ())) -> do VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $ runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3 pure $ ExitFailure 3

1
ghcup.cabal
View File

@ -241,6 +241,7 @@ executable ghcup
, directory ^>=1.3.6.0 , directory ^>=1.3.6.0
, filepath ^>=1.4.2.1 , filepath ^>=1.4.2.1
, ghcup , ghcup
, haskus-utils-types ^>=1.5
, haskus-utils-variant ^>=3.2.1 , haskus-utils-variant ^>=3.2.1
, libarchive ^>=3.0.3.0 , libarchive ^>=3.0.3.0
, megaparsec >=8.0.0 && <9.3 , megaparsec >=8.0.0 && <9.3

16
lib/GHCup/Errors.hs
View File

@ -137,10 +137,13 @@ data AlreadyInstalled = AlreadyInstalled Tool Version
instance Pretty AlreadyInstalled where instance Pretty AlreadyInstalled where
pPrint (AlreadyInstalled tool ver') = 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. -- | The Directory is supposed to be empty, but wasn't.
data DirNotEmpty = DirNotEmpty {path :: FilePath} data DirNotEmpty = DirNotEmpty {path :: FilePath}
deriving Show
instance Pretty DirNotEmpty where instance Pretty DirNotEmpty where
pPrint (DirNotEmpty path) = do pPrint (DirNotEmpty path) = do
@ -344,6 +347,17 @@ instance Pretty DownloadFailed where
deriving instance Show DownloadFailed 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. -- | A build failed.
data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es) data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)

28
lib/GHCup/Prelude.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-| {-|
Module : GHCup.Prelude Module : GHCup.Prelude
@ -27,6 +28,7 @@ module GHCup.Prelude
) )
where where
import GHCup.Errors
import GHCup.Prelude.Internal import GHCup.Prelude.Internal
import GHCup.Types.Optics (HasLog) import GHCup.Types.Optics (HasLog)
import GHCup.Prelude.Logger (logWarn) import GHCup.Prelude.Logger (logWarn)
@ -52,3 +54,29 @@ catchWarn :: forall es m env . ( Pretty (V es)
, Monad m) => Excepts es m () -> Excepts '[] m () , Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v)) 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