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

Merge branch 'issue-211'

Browse Source
This commit is contained in:
Julian Ospald 2021-08-24 16:14:24 +02:00
commit 7bc00c4e68
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
2 changed files with 14 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
lib/GHCup.hs
View File

@ -83,7 +83,7 @@ import System.IO.Error
#if defined(IS_WINDOWS)
import System.IO.Temp
#endif
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
import Text.Regex.Posix
import qualified Crypto.Hash.SHA256 as SHA256
@ -276,7 +276,7 @@ installPackedGHC dl msubdir inst ver = do
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack)
@ -451,7 +451,7 @@ installCabalBindist dlinfo ver isoFilepath = do
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
@ -579,7 +579,7 @@ installHLSBindist dlinfo ver isoFilepath = do
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
@ -760,7 +760,7 @@ installStackBindist dlinfo ver isoFilepath = do
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
@ -1816,7 +1816,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ lift $ darwinNotarization _rPlatform tmpUnpack
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
@ -1856,7 +1856,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
void $ lift $ darwinNotarization _rPlatform tmpUnpack
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
lift $ $(logInfo) [i|Git version #{ref} corresponds to GHC version #{prettyVer tver}|]
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
@ -2354,4 +2354,3 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
liftIO $ canonicalizePath currentRunningExecPath

7
lib/GHCup/Utils/Prelude.hs
View File

@ -5,6 +5,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.Prelude
@ -29,6 +30,7 @@ import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Logger
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.List ( nub, intercalate )
@ -39,6 +41,7 @@ import Data.Versions
import Data.Word8
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
import System.IO.Error
#if defined(IS_WINDOWS)
import System.IO.Temp
@ -170,6 +173,10 @@ lEM' :: forall e' e es a m
-> Excepts es m a
lEM' f em = lift em >>= lE . first f
-- for some obscure reason... this won't type-check if we move it to a different module
catchWarn :: forall es m . (Pretty (V es), MonadLogger m, Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ $(logWarn) (T.pack . prettyShow $ v))
fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight