This commit is contained in:
Julian Ospald 2020-02-24 15:09:38 +01:00
parent b3eac9bf54
commit 30ed7f0226
3 changed files with 32 additions and 16 deletions

View File

@ -2,6 +2,8 @@
## New ## New
* download progress
* Downloads from URL * Downloads from URL
* set Set currently active GHC version * set Set currently active GHC version
* list Show available GHCs and other tools * list Show available GHCs and other tools

View File

@ -44,13 +44,11 @@ data Command
| InstallCabal InstallCabalOptions | InstallCabal InstallCabalOptions
data InstallGHCOptions = InstallGHCOptions data InstallGHCOptions = InstallGHCOptions
{ { ghcVer :: Maybe Version
ghcVer :: Maybe Version
} }
data InstallCabalOptions = InstallCabalOptions data InstallCabalOptions = InstallCabalOptions
{ { cabalVer :: Maybe Version
cabalVer :: Maybe Version
} }
@ -120,12 +118,22 @@ main = do
>>= \opt@Options {..} -> do >>= \opt@Options {..} -> do
let settings = toSettings opt let settings = toSettings opt
-- wrapper to run effects with settings -- wrapper to run effects with settings
let let runInstTool =
runInstTool =
runLogger runLogger
. flip runReaderT settings . flip runReaderT settings
. runE . runE
@'[FileError, ArchiveError, ProcessError, URLException, PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound, TagNotFound, AlreadyInstalled] @'[ FileError
, ArchiveError
, ProcessError
, URLException
, PlatformResultError
, NoDownload
, NoCompatibleArch
, DistroNotFound
, TagNotFound
, AlreadyInstalled
, NotInstalled
]
case optCommand of case optCommand of
InstallGHC (InstallGHCOptions {..}) -> InstallGHC (InstallGHCOptions {..}) ->
@ -142,7 +150,7 @@ main = do
(OwnSpec availableDownloads) (OwnSpec availableDownloads)
) )
>>= \case >>= \case
VRight _ -> pure () VRight _ -> runLogger $ $(logInfo) ([s|GHC installation successful|])
VLeft (V (AlreadyInstalled treq)) -> VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn) runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|]) (T.pack (show treq) <> [s| already installed|])
@ -161,7 +169,7 @@ main = do
(OwnSpec availableDownloads) (OwnSpec availableDownloads)
) )
>>= \case >>= \case
VRight _ -> pure () VRight _ -> runLogger $ $(logInfo) ([s|Cabal installation successful|])
VLeft (V (AlreadyInstalled treq)) -> VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn) runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|]) (T.pack (show treq) <> [s| already installed|])

View File

@ -556,6 +556,7 @@ installTool :: ( MonadThrow m
, MonadLogger m , MonadLogger m
, MonadCatch m , MonadCatch m
, MonadIO m , MonadIO m
, MonadFail m
) )
=> ToolRequest => ToolRequest
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
@ -570,6 +571,7 @@ installTool :: ( MonadThrow m
, NoDownload , NoDownload
, NoCompatibleArch , NoCompatibleArch
, DistroNotFound , DistroNotFound
, NotInstalled
] ]
m m
() ()
@ -607,7 +609,9 @@ installTool treq mpfReq urlSource = do
-- TODO: test if tool is already installed -- TODO: test if tool is already installed
case treq of case treq of
(ToolRequest GHC ver) -> liftE $ installGHC archiveSubdir ghcdir (ToolRequest GHC ver) -> do
liftE $ installGHC archiveSubdir ghcdir
liftE $ setGHC ver SetGHCOnly
(ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir (ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir
pure () pure ()
@ -619,7 +623,7 @@ toolAlreadyInstalled ToolRequest {..} = case _tool of
-- | Install an unpacked GHC distribution. -- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
installGHC :: (MonadLogger m, MonadIO m) installGHC :: (MonadLogger m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides) => Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> Path Abs -- ^ Path to install to -> Path Abs -- ^ Path to install to
@ -642,6 +646,7 @@ installCabal :: (MonadLogger m, MonadCatch m, MonadIO m)
installCabal path inst = do installCabal path inst = do
lift $ $(logInfo) ([s|Installing cabal|]) lift $ $(logInfo) ([s|Installing cabal|])
let cabalFile = [rel|cabal|] :: Path Rel let cabalFile = [rel|cabal|] :: Path Rel
liftIO $ createDirIfMissing newDirPerms inst
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile) (path </> cabalFile)
(inst </> cabalFile) (inst </> cabalFile)
@ -667,6 +672,7 @@ setGHC ver sghc = do
-- symlink destination -- symlink destination
destdir <- liftIO $ ghcupBinDir destdir <- liftIO $ ghcupBinDir
liftIO $ createDirIfMissing newDirPerms destdir
-- for ghc tools (ghc, ghci, haddock, ...) -- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ghcdir verfiles <- ghcToolFiles ghcdir