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

Refactor excepts

This commit is contained in:
Julian Ospald 2022-05-23 23:32:58 +02:00
parent 9375255452
commit c7774450bf
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
4 changed files with 87 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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,7 +358,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v, ())) -> do
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
pure ExitSuccess
@ -444,7 +371,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
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 +383,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 +404,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
@ -508,11 +435,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
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
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 <> "'"
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 +455,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
@ -564,7 +491,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
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
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"HLS ver "
<> prettyVer v
@ -572,7 +499,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
<> prettyVer v
<> "'"
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 +515,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
@ -619,11 +546,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
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
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 <> "'"
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

1
ghcup.cabal
View File

@ -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

12
lib/GHCup/Errors.hs
View File

@ -141,6 +141,7 @@ instance Pretty AlreadyInstalled where
-- | 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 +345,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)

28
lib/GHCup/Prelude.hs
View File

@ -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