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

Fix error messages and overhaul pretty printing 

Fixes #115
This commit is contained in:
Julian Ospald 2021-03-02 00:15:03 +01:00
parent 9da5998a5c
commit 8c87c9aeb7
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
10 changed files with 324 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
app/ghcup-gen/Validate.hs
View File

@ -32,6 +32,7 @@ import Optics
import System.Exit import System.Exit
import System.IO import System.IO
import Text.ParserCombinators.ReadP import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix import Text.Regex.Posix
import qualified Data.ByteString as B import qualified Data.ByteString as B
@ -83,7 +84,7 @@ validate dls = do
where where
checkHasRequiredPlatforms t v tags arch pspecs = do checkHasRequiredPlatforms t v tags arch pspecs = do
let v' = prettyVer v let v' = prettyVer v
arch' = prettyArch arch arch' = prettyShow arch
when (not $ any (== Linux UnknownLinux) pspecs) $ do when (not $ any (== Linux UnknownLinux) pspecs) $ do
lift $ $(logError) lift $ $(logError)
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch'}|] [i|Linux UnknownLinux missing for for #{t} #{v'} #{arch'}|]

15
app/ghcup/BrickMain.hs
View File

@ -48,6 +48,7 @@ import Prelude hiding ( appendFile )
import System.Environment import System.Environment
import System.Exit import System.Exit
import System.IO.Unsafe import System.IO.Unsafe
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString import URI.ByteString
import qualified GHCup.Types as GT import qualified GHCup.Types as GT
@ -445,12 +446,8 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure $ Right () pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V (BuildFailed _ e)) ->
pure $ Left [i|Build failed with #{e}|]
VLeft (V NoDownload) ->
pure $ Left [i|No available version for #{prettyVer lVer}|]
VLeft (V NoUpdate) -> pure $ Right () VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e} VLeft e -> pure $ Left [i|#{prettyShow e}
Also check the logs in ~/.ghcup/logs|] Also check the logs in ~/.ghcup/logs|]
@ -474,7 +471,7 @@ set' _ (_, ListResult {..}) = do
) )
>>= \case >>= \case
VRight _ -> pure $ Right () VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|] VLeft e -> pure $ Left (prettyShow e)
del' :: BrickState -> (Int, ListResult) -> IO (Either String ()) del' :: BrickState -> (Int, ListResult) -> IO (Either String ())
@ -500,7 +497,7 @@ del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure $ Right () pure $ Right ()
VRight _ -> pure $ Right () VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|] VLeft e -> pure $ Left (prettyShow e)
changelog' :: BrickState -> (Int, ListResult) -> IO (Either String ()) changelog' :: BrickState -> (Int, ListResult) -> IO (Either String ())
@ -515,7 +512,7 @@ changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
FreeBSD -> "xdg-open" FreeBSD -> "xdg-open"
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
Right _ -> pure $ Right () Right _ -> pure $ Right ()
Left e -> pure $ Left [i|#{e}|] Left e -> pure $ Left $ prettyShow e
settings' :: IORef AppState settings' :: IORef AppState
@ -595,7 +592,7 @@ getDownloads' = do
case r of case r of
VRight a -> pure $ Right a VRight a -> pure $ Right a
VLeft e -> pure $ Left [i|#{e}|] VLeft e -> pure $ Left (prettyShow e)
getAppData :: Maybe GHCupDownloads getAppData :: Maybe GHCupDownloads

76
app/ghcup/Main.hs
View File

@ -66,6 +66,7 @@ import System.Environment
import System.Exit import System.Exit
import System.IO hiding ( appendFile ) import System.IO hiding ( appendFile )
import Text.Read hiding ( lift ) import Text.Read hiding ( lift )
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString import URI.ByteString
import qualified Data.ByteString as B import qualified Data.ByteString as B
@ -113,7 +114,7 @@ data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
| ToolTag Tag | ToolTag Tag
prettyToolVer :: ToolVersion -> String prettyToolVer :: ToolVersion -> String
prettyToolVer (ToolVersion v') = T.unpack $ prettyTVer v' prettyToolVer (ToolVersion v') = T.unpack $ tVerToText v'
prettyToolVer (ToolTag t) = show t prettyToolVer (ToolTag t) = show t
toSetToolVer :: Maybe ToolVersion -> SetToolVersion toSetToolVer :: Maybe ToolVersion -> SetToolVersion
@ -830,7 +831,7 @@ tagCompleter tool add = listIOCompleter $ do
$ join $ join
$ M.elems $ M.elems
$ availableToolVersions (_ghcupDownloads dls) tool $ availableToolVersions (_ghcupDownloads dls) tool
pure $ nub $ (add ++) $ fmap prettyTag allTags pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add) VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add)
@ -1231,7 +1232,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight r -> pure r VRight r -> pure r
VLeft e -> do VLeft e -> do
runLogger runLogger
($(logError) [i|Error determining Platform: #{e}|]) ($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
@ -1246,7 +1247,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight r -> pure r VRight r -> pure r
VLeft e -> do VLeft e -> do
runLogger runLogger
($(logError) [i|Error fetching download info: #{e}|]) ($(logError) $ T.pack $ prettyShow e)
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
case optCommand of case optCommand of
@ -1285,23 +1286,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logWarn) runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc #{prettyVer v}' first|] [i|GHC ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc #{prettyVer v}' first|]
pure ExitSuccess pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of case keepDirs settings of
Never -> runLogger ($(logError) [i|Build failed with #{e}|]) Never -> runLogger ($(logError) $ T.pack $ prettyShow err)
_ -> runLogger ($(logError) [i|Build failed with #{e} _ -> runLogger ($(logError) [i|#{prettyShow err}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues. Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|]) Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available GHC version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended GHC version|]
pure $ ExitFailure 3
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
$(logError) [i|#{e}|] $(logError) $ T.pack $ prettyShow e
$(logError) [i|Also check the logs in #{logsDir}|] $(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 3 pure $ ExitFailure 3
@ -1330,16 +1324,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logWarn) runLogger $ $(logWarn)
[i|Cabal ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm cabal #{prettyVer v}' first|] [i|Cabal ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm cabal #{prettyVer v}' first|]
pure ExitSuccess pure ExitSuccess
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available Cabal version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended Cabal version|]
pure $ ExitFailure 4
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
$(logError) [i|#{e}|] $(logError) $ T.pack $ prettyShow e
$(logError) [i|Also check the logs in #{logsDir}|] $(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 4 pure $ ExitFailure 4
@ -1367,16 +1354,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logWarn) runLogger $ $(logWarn)
[i|HLS ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm hls #{prettyVer v}' first|] [i|HLS ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm hls #{prettyVer v}' first|]
pure ExitSuccess pure ExitSuccess
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available HLS version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended HLS version|]
pure $ ExitFailure 4
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
$(logError) [i|#{e}|] $(logError) $ T.pack $ prettyShow e
$(logError) [i|Also check the logs in #{logsDir}|] $(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 4 pure $ ExitFailure 4
@ -1393,7 +1373,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
[i|GHC #{prettyVer _tvVersion} successfully set as default version#{maybe "" (" for cross target " <>) _tvTarget}|] [i|GHC #{prettyVer _tvVersion} successfully set as default version#{maybe "" (" for cross target " <>) _tvTarget}|]
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger ($(logError) [i|#{e}|]) runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 5 pure $ ExitFailure 5
let setCabal' SetOptions{..} = let setCabal' SetOptions{..} =
@ -1409,7 +1389,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
[i|Cabal #{prettyVer _tvVersion} successfully set as default version|] [i|Cabal #{prettyVer _tvVersion} successfully set as default version|]
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger ($(logError) [i|#{e}|]) runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 14 pure $ ExitFailure 14
let setHLS' SetOptions{..} = let setHLS' SetOptions{..} =
@ -1425,7 +1405,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
[i|HLS #{prettyVer _tvVersion} successfully set as default version|] [i|HLS #{prettyVer _tvVersion} successfully set as default version|]
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger ($(logError) [i|#{e}|]) runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 14 pure $ ExitFailure 14
let rmGHC' RmOptions{..} = let rmGHC' RmOptions{..} =
@ -1442,7 +1422,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger ($(logError) [i|#{e}|]) runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 7 pure $ ExitFailure 7
let rmCabal' tv = let rmCabal' tv =
@ -1459,7 +1439,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger ($(logError) [i|#{e}|]) runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 15 pure $ ExitFailure 15
let rmHLS' tv = let rmHLS' tv =
@ -1476,7 +1456,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logInfo) msg runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger ($(logError) [i|#{e}|]) runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 15 pure $ ExitFailure 15
@ -1523,7 +1503,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
putStrLn $ prettyDebugInfo dinfo putStrLn $ prettyDebugInfo dinfo
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger ($(logError) [i|#{e}|]) runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 8 pure $ ExitFailure 8
Compile (CompileGHC GHCCompileOptions {..}) -> Compile (CompileGHC GHCCompileOptions {..}) ->
@ -1558,16 +1538,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger $ $(logWarn) runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc #{prettyVer v}' first|] [i|GHC ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc #{prettyVer v}' first|]
pure ExitSuccess pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of case keepDirs settings of
Never -> runLogger ($(logError) [i|Build failed with #{e} Never -> runLogger $ $(logError) $ T.pack $ prettyShow err
Check the logs at #{logsDir}|]) _ -> runLogger ($(logError) [i|#{prettyShow err}
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues. Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|]) Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 9 pure $ ExitFailure 9
VLeft e -> do VLeft e -> do
runLogger ($(logError) [i|#{e}|]) runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 9 pure $ ExitFailure 9
Upgrade (uOpts) force -> do Upgrade (uOpts) force -> do
@ -1592,7 +1571,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger $ $(logWarn) [i|No GHCup update available|] runLogger $ $(logWarn) [i|No GHCup update available|]
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger ($(logError) [i|#{e}|]) runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 11 pure $ ExitFailure 11
ToolRequirements -> ToolRequirements ->
@ -1609,10 +1588,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
>>= \case >>= \case
VRight _ -> pure ExitSuccess VRight _ -> pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger runLogger $ $(logError) $ T.pack $ prettyShow e
($(logError)
[i|Error getting tool requirements: #{e}|]
)
pure $ ExitFailure 12 pure $ ExitFailure 12
ChangeLog (ChangeLogOptions {..}) -> do ChangeLog (ChangeLogOptions {..}) -> do
@ -1926,7 +1902,7 @@ GHCup base dir: #{toFilePath diBaseDir}
GHCup bin dir: #{toFilePath diBinDir} GHCup bin dir: #{toFilePath diBinDir}
GHCup GHC directory: #{toFilePath diGHCDir} GHCup GHC directory: #{toFilePath diGHCDir}
GHCup cache directory: #{toFilePath diCacheDir} GHCup cache directory: #{toFilePath diCacheDir}
Architecture: #{prettyArch diArch} Architecture: #{prettyShow diArch}
Platform: #{prettyPlatform diPlatform} Platform: #{prettyShow diPlatform}
Version: #{describe_result}|] Version: #{describe_result}|]

6
ghcup.cabal
View File

@ -150,6 +150,9 @@ common optparse-applicative
common parsec common parsec
build-depends: parsec >=3.1 build-depends: parsec >=3.1
common pretty
build-depends: pretty >=1.1.3.1
common pretty-terminal common pretty-terminal
build-depends: pretty-terminal >=0.1.0.0 build-depends: pretty-terminal >=0.1.0.0
@ -288,6 +291,7 @@ library
, optics , optics
, optics-vl , optics-vl
, parsec , parsec
, pretty
, pretty-terminal , pretty-terminal
, regex-posix , regex-posix
, resourcet , resourcet
@ -377,6 +381,7 @@ executable ghcup
, monad-logger , monad-logger
, mtl , mtl
, optparse-applicative , optparse-applicative
, pretty
, pretty-terminal , pretty-terminal
, resourcet , resourcet
, safe , safe
@ -432,6 +437,7 @@ executable ghcup-gen
, mtl , mtl
, optics , optics
, optparse-applicative , optparse-applicative
, pretty
, pretty-terminal , pretty-terminal
, regex-posix , regex-posix
, resourcet , resourcet

14
lib/GHCup.hs
View File

@ -525,7 +525,7 @@ setGHC ver sghc = do
let verBS = verToBS (_tvVersion ver) let verBS = verToBS (_tvVersion ver)
ghcdir <- lift $ ghcupGHCDir ver ghcdir <- lift $ ghcupGHCDir ver
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))) whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver))
-- symlink destination -- symlink destination
AppState { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
@ -605,7 +605,7 @@ setCabal ver = do
whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile)) whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile))
$ throwE $ throwE
$ NotInstalled Cabal (prettyVer ver) $ NotInstalled Cabal (GHCTargetVersion Nothing ver)
let cabalbin = binDir </> [rel|cabal|] let cabalbin = binDir </> [rel|cabal|]
@ -647,7 +647,7 @@ setHLS ver = do
-- set haskell-language-server-<ghcver> symlinks -- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver bins <- lift $ hlsServerBinaries ver
when (bins == []) $ throwE $ NotInstalled HLS (prettyVer ver) when (bins == []) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
forM_ bins $ \f -> do forM_ bins $ \f -> do
let destL = toFilePath f let destL = toFilePath f
@ -929,7 +929,7 @@ rmGHCVer :: ( MonadReader AppState m
rmGHCVer ver = do rmGHCVer ver = do
isSetGHC <- lift $ fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver) isSetGHC <- lift $ fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver)
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))) whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver))
dir <- lift $ ghcupGHCDir ver dir <- lift $ ghcupGHCDir ver
-- this isn't atomic, order matters -- this isn't atomic, order matters
@ -970,7 +970,7 @@ rmCabalVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, M
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmCabalVer ver = do rmCabalVer ver = do
whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (prettyVer ver)) whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver))
cSet <- lift $ cabalSet cSet <- lift $ cabalSet
@ -993,7 +993,7 @@ rmHLSVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, Mon
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmHLSVer ver = do rmHLSVer ver = do
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (prettyVer ver)) whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))
isHlsSet <- lift $ hlsSet isHlsSet <- lift $ hlsSet
@ -1240,7 +1240,7 @@ Stage1Only = YES|]
$ c $ c
tarName <- tarName <-
parseRel parseRel
[i|ghc-#{prettyTVer tver}-#{prettyPfReq pfreq}-#{cDigest}.tar#{takeExtension (toFilePath tar)}|] [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{cDigest}.tar#{takeExtension (toFilePath tar)}|]
let tarPath = cacheDir </> tarName let tarPath = cacheDir </> tarName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar) handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
tarPath tarPath

186
lib/GHCup/Errors.hs
View File

@ -1,7 +1,13 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-| {-|
Module : GHCup.Errors Module : GHCup.Errors
@ -15,13 +21,21 @@ Portability : POSIX
module GHCup.Errors where module GHCup.Errors where
import GHCup.Types import GHCup.Types
import GHCup.Utils.Prelude
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Exception.Safe import Control.Exception.Safe
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.String.Interpolate
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
import Haskus.Utils.Variant
import HPath import HPath
import Haskus.Utils.Variant
import Text.PrettyPrint
import Text.PrettyPrint.HughesPJClass
import URI.ByteString
@ -35,109 +49,211 @@ import HPath
data NoCompatiblePlatform = NoCompatiblePlatform String -- the platform we got data NoCompatiblePlatform = NoCompatiblePlatform String -- the platform we got
deriving Show deriving Show
instance Pretty NoCompatiblePlatform where
pPrint (NoCompatiblePlatform str') =
text ("Could not find a compatible platform. Got: " ++ str')
-- | Unable to find a download for the requested versio/distro. -- | Unable to find a download for the requested versio/distro.
data NoDownload = NoDownload data NoDownload = NoDownload
deriving Show deriving Show
instance Pretty NoDownload where
pPrint NoDownload =
text "Unable to find a download for the requested version/distro."
-- | No update available or necessary. -- | No update available or necessary.
data NoUpdate = NoUpdate data NoUpdate = NoUpdate
deriving Show deriving Show
instance Pretty NoUpdate where
pPrint NoUpdate = text "No update available or necessary."
-- | The Architecture is unknown and unsupported. -- | The Architecture is unknown and unsupported.
data NoCompatibleArch = NoCompatibleArch String data NoCompatibleArch = NoCompatibleArch String
deriving Show deriving Show
instance Pretty NoCompatibleArch where
pPrint (NoCompatibleArch arch) =
text ("The Architecture is unknown or unsupported. Got: " ++ arch)
-- | Unable to figure out the distribution of the host. -- | Unable to figure out the distribution of the host.
data DistroNotFound = DistroNotFound data DistroNotFound = DistroNotFound
deriving Show deriving Show
instance Pretty DistroNotFound where
pPrint DistroNotFound =
text "Unable to figure out the distribution of the host."
-- | The archive format is unknown. We don't know how to extract it. -- | The archive format is unknown. We don't know how to extract it.
data UnknownArchive = UnknownArchive ByteString data UnknownArchive = UnknownArchive ByteString
deriving Show deriving Show
instance Pretty UnknownArchive where
pPrint (UnknownArchive file) =
text [i|The archive format is unknown. We don't know how to extract the file "#{decUTF8Safe file}"|]
-- | The scheme is not supported (such as ftp). -- | The scheme is not supported (such as ftp).
data UnsupportedScheme = UnsupportedScheme data UnsupportedScheme = UnsupportedScheme
deriving Show deriving Show
instance Pretty UnsupportedScheme where
pPrint UnsupportedScheme = text "The scheme is not supported (such as ftp)."
-- | Unable to copy a file. -- | Unable to copy a file.
data CopyError = CopyError String data CopyError = CopyError String
deriving Show deriving Show
instance Pretty CopyError where
pPrint (CopyError reason) =
text ("Unable to copy a file. Reason was: " ++ reason)
-- | Unable to find a tag of a tool. -- | Unable to find a tag of a tool.
data TagNotFound = TagNotFound Tag Tool data TagNotFound = TagNotFound Tag Tool
deriving Show deriving Show
instance Pretty TagNotFound where
pPrint (TagNotFound tag tool) =
text "Unable to find tag" <+> pPrint tag <+> text [i|of tool "#{tool}"|]
-- | Unable to find a version of a tool. -- | Unable to find a version of a tool.
data VerNotFound = VerNotFound Version Tool data VerNotFound = VerNotFound Version Tool
deriving Show deriving Show
instance Pretty VerNotFound where
pPrint (VerNotFound ver' tool) =
text [i|Unable to find version "#{prettyShow ver'}" of tool "#{tool}"|]
-- | Unable to find the next version of a tool (the one after the currently -- | Unable to find the next version of a tool (the one after the currently
-- set one). -- set one).
data NextVerNotFound = NextVerNotFound Tool data NextVerNotFound = NextVerNotFound Tool
deriving Show deriving Show
instance Pretty NextVerNotFound where
pPrint (NextVerNotFound tool) =
text [i|Unable to find next (the one after the currently set one) version of tool "#{tool}"|]
-- | The tool (such as GHC) is already installed with that version. -- | The tool (such as GHC) is already installed with that version.
data AlreadyInstalled = AlreadyInstalled Tool Version data AlreadyInstalled = AlreadyInstalled Tool Version
deriving Show deriving Show
instance Pretty AlreadyInstalled where
pPrint (AlreadyInstalled tool ver') =
text [i|#{tool}-#{prettyShow ver'} is already installed|]
-- | The tool is not installed. Some operations rely on a tool -- | The tool is not installed. Some operations rely on a tool
-- to be installed (such as setting the current GHC version). -- to be installed (such as setting the current GHC version).
data NotInstalled = NotInstalled Tool Text data NotInstalled = NotInstalled Tool GHCTargetVersion
deriving Show deriving Show
instance Pretty NotInstalled where
pPrint (NotInstalled tool ver) =
text [i|The version "#{prettyShow ver}" of the tool "#{tool}" is not installed.|]
-- | An executable was expected to be in PATH, but was not found. -- | An executable was expected to be in PATH, but was not found.
data NotFoundInPATH = NotFoundInPATH (Path Rel) data NotFoundInPATH = NotFoundInPATH (Path Rel)
deriving Show deriving Show
instance Pretty NotFoundInPATH where
pPrint (NotFoundInPATH exe) =
text [i|The exe "#{decUTF8Safe . toFilePath $ exe}" was not found in PATH.|]
-- | JSON decoding failed. -- | JSON decoding failed.
data JSONError = JSONDecodeError String data JSONError = JSONDecodeError String
deriving Show deriving Show
instance Pretty JSONError where
pPrint (JSONDecodeError err) =
text [i|JSON decoding failed with: #{err}|]
-- | A file that is supposed to exist does not exist -- | A file that is supposed to exist does not exist
-- (e.g. when we use file scheme to "download" something). -- (e.g. when we use file scheme to "download" something).
data FileDoesNotExistError = FileDoesNotExistError ByteString data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show deriving Show
instance Pretty FileDoesNotExistError where
pPrint (FileDoesNotExistError file) =
text [i|File "#{decUTF8Safe file}" does not exist.|]
data TarDirDoesNotExist = TarDirDoesNotExist TarDir data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show deriving Show
instance Pretty TarDirDoesNotExist where
pPrint (TarDirDoesNotExist dir) =
text "Tar directory does not exist:" <+> pPrint dir
-- | File digest verification failed. -- | File digest verification failed.
data DigestError = DigestError Text Text data DigestError = DigestError Text Text
deriving Show deriving Show
instance Pretty DigestError where
pPrint (DigestError currentDigest expectedDigest) =
text [i|Digest error: expected "#{expectedDigest}", but got "#{currentDigest}"|]
-- | Unexpected HTTP status. -- | Unexpected HTTP status.
data HTTPStatusError = HTTPStatusError Int data HTTPStatusError = HTTPStatusError Int
deriving Show deriving Show
instance Pretty HTTPStatusError where
pPrint (HTTPStatusError status) =
text [i|Unexpected HTTP status: #{status}|]
-- | The 'Location' header was expected during a 3xx redirect, but not found. -- | The 'Location' header was expected during a 3xx redirect, but not found.
data NoLocationHeader = NoLocationHeader data NoLocationHeader = NoLocationHeader
deriving Show deriving Show
instance Pretty NoLocationHeader where
pPrint NoLocationHeader =
text [i|The 'Location' header was expected during a 3xx redirect, but not found.|]
-- | Too many redirects. -- | Too many redirects.
data TooManyRedirs = TooManyRedirs data TooManyRedirs = TooManyRedirs
deriving Show deriving Show
instance Pretty TooManyRedirs where
pPrint TooManyRedirs =
text [i|Too many redirections.|]
-- | A patch could not be applied. -- | A patch could not be applied.
data PatchFailed = PatchFailed data PatchFailed = PatchFailed
deriving Show deriving Show
instance Pretty PatchFailed where
pPrint PatchFailed =
text [i|A patch could not be applied.|]
-- | The tool requirements could not be found. -- | The tool requirements could not be found.
data NoToolRequirements = NoToolRequirements data NoToolRequirements = NoToolRequirements
deriving Show deriving Show
instance Pretty NoToolRequirements where
pPrint NoToolRequirements =
text [i|The Tool requirements could not be found.|]
data InvalidBuildConfig = InvalidBuildConfig Text data InvalidBuildConfig = InvalidBuildConfig Text
deriving Show deriving Show
instance Pretty InvalidBuildConfig where
pPrint (InvalidBuildConfig reason) =
text [i|The build config is invalid. Reason was: #{reason}|]
data NoToolVersionSet = NoToolVersionSet Tool data NoToolVersionSet = NoToolVersionSet Tool
deriving Show deriving Show
instance Pretty NoToolVersionSet where
pPrint (NoToolVersionSet tool) =
text [i|No version is set for tool "#{tool}".|]
------------------------- -------------------------
--[ High-level errors ]-- --[ High-level errors ]--
------------------------- -------------------------
-- | A download failed. The underlying error is encapsulated. -- | A download failed. The underlying error is encapsulated.
data DownloadFailed = forall es . Show (V es) => DownloadFailed (V es) data DownloadFailed = forall x xs . (Show x, Show (V xs), Pretty x, Pretty (V xs)) => DownloadFailed (V (x ': xs))
instance Pretty DownloadFailed where
pPrint (DownloadFailed reason) =
text "Download failed:" <+> pPrint reason
deriving instance Show DownloadFailed deriving instance Show DownloadFailed
@ -145,12 +261,20 @@ deriving instance Show DownloadFailed
-- | A build failed. -- | A build failed.
data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es) data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
instance Pretty BuildFailed where
pPrint (BuildFailed path reason) =
text [i|BuildFailed failed in dir "#{decUTF8Safe . toFilePath $ path}": #{reason}|]
deriving instance Show BuildFailed deriving instance Show BuildFailed
-- | Setting the current GHC version failed. -- | Setting the current GHC version failed.
data GHCupSetError = forall es . Show (V es) => GHCupSetError (V es) data GHCupSetError = forall es . Show (V es) => GHCupSetError (V es)
instance Pretty GHCupSetError where
pPrint (GHCupSetError reason) =
text [i|Setting the current GHC version failed: #{reason}|]
deriving instance Show GHCupSetError deriving instance Show GHCupSetError
@ -163,11 +287,65 @@ deriving instance Show GHCupSetError
data ParseError = ParseError String data ParseError = ParseError String
deriving Show deriving Show
instance Pretty ParseError where
pPrint (ParseError reason) =
text [i|Parsing failed: #{reason}|]
instance Exception ParseError instance Exception ParseError
data UnexpectedListLength = UnexpectedListLength String data UnexpectedListLength = UnexpectedListLength String
deriving Show deriving Show
instance Pretty UnexpectedListLength where
pPrint (UnexpectedListLength reason) =
text [i|List length unexpected: #{reason}|]
instance Exception UnexpectedListLength instance Exception UnexpectedListLength
------------------------
--[ orphan instances ]--
------------------------
instance Pretty (V '[]) where
{-# INLINABLE pPrint #-}
pPrint _ = undefined
instance
( Pretty x
, Pretty (V xs)
) => Pretty (V (x ': xs))
where
pPrint v = case popVariantHead v of
Right x -> pPrint x
Left xs -> pPrint xs
instance Pretty URIParseError where
pPrint (MalformedScheme reason) =
text [i|Failed to parse URI. Malformed scheme: #{reason}|]
pPrint MalformedUserInfo =
text [i|Failed to parse URI. Malformed user info.|]
pPrint MalformedQuery =
text [i|Failed to parse URI. Malformed query.|]
pPrint MalformedFragment =
text [i|Failed to parse URI. Malformed fragment.|]
pPrint MalformedHost =
text [i|Failed to parse URI. Malformed host.|]
pPrint MalformedPort =
text [i|Failed to parse URI. Malformed port.|]
pPrint MalformedPath =
text [i|Failed to parse URI. Malformed path.|]
pPrint (OtherError err) =
text [i|Failed to parse URI: #{err}|]
#if !defined(TAR)
instance Pretty ArchiveResult where
pPrint ArchiveFatal = text "Archive result: fatal"
pPrint ArchiveFailed = text "Archive result: failed"
pPrint ArchiveWarn = text "Archive result: warning"
pPrint ArchiveRetry = text "Archive result: retry"
pPrint ArchiveOk = text "Archive result: Ok"
pPrint ArchiveEOF = text "Archive result: EOF"
#endif

123
lib/GHCup/Types.hs
View File

@ -1,6 +1,8 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-| {-|
Module : GHCup.Types Module : GHCup.Types
@ -15,12 +17,16 @@ module GHCup.Types where
import Data.Map.Strict ( Map ) import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) ) import Data.List.NonEmpty ( NonEmpty (..) )
import Data.String.Interpolate
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
import HPath import HPath
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
import URI.ByteString import URI.ByteString
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Encoding.Error as E
import qualified GHC.Generics as GHC import qualified GHC.Generics as GHC
import qualified Graphics.Vty as Vty import qualified Graphics.Vty as Vty
@ -106,13 +112,21 @@ data Tag = Latest
| UnknownTag String -- ^ used for upwardscompat | UnknownTag String -- ^ used for upwardscompat
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
prettyTag :: Tag -> String tagToString :: Tag -> String
prettyTag Recommended = "recommended" tagToString Recommended = "recommended"
prettyTag Latest = "latest" tagToString Latest = "latest"
prettyTag Prerelease = "prerelease" tagToString Prerelease = "prerelease"
prettyTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'') tagToString (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
prettyTag (UnknownTag t ) = t tagToString (UnknownTag t ) = t
prettyTag Old = "" tagToString Old = ""
instance Pretty Tag where
pPrint Recommended = text "recommended"
pPrint Latest = text "latest"
pPrint Prerelease = text "prerelease"
pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp''))
pPrint (UnknownTag t ) = text t
pPrint Old = mempty
data Architecture = A_64 data Architecture = A_64
| A_32 | A_32
@ -124,15 +138,18 @@ data Architecture = A_64
| A_ARM64 | A_ARM64
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
prettyArch :: Architecture -> String archToString :: Architecture -> String
prettyArch A_64 = "x86_64" archToString A_64 = "x86_64"
prettyArch A_32 = "i386" archToString A_32 = "i386"
prettyArch A_PowerPC = "powerpc" archToString A_PowerPC = "powerpc"
prettyArch A_PowerPC64 = "powerpc64" archToString A_PowerPC64 = "powerpc64"
prettyArch A_Sparc = "sparc" archToString A_Sparc = "sparc"
prettyArch A_Sparc64 = "sparc64" archToString A_Sparc64 = "sparc64"
prettyArch A_ARM = "arm" archToString A_ARM = "arm"
prettyArch A_ARM64 = "aarch64" archToString A_ARM64 = "aarch64"
instance Pretty Architecture where
pPrint = text . archToString
data Platform = Linux LinuxDistro data Platform = Linux LinuxDistro
-- ^ must exit -- ^ must exit
@ -141,10 +158,13 @@ data Platform = Linux LinuxDistro
| FreeBSD | FreeBSD
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
prettyPlatfrom :: Platform -> String platformToString :: Platform -> String
prettyPlatfrom (Linux distro) = "linux-" ++ prettyDistro distro platformToString (Linux distro) = "linux-" ++ distroToString distro
prettyPlatfrom Darwin = "darwin" platformToString Darwin = "darwin"
prettyPlatfrom FreeBSD = "freebsd" platformToString FreeBSD = "freebsd"
instance Pretty Platform where
pPrint = text . platformToString
data LinuxDistro = Debian data LinuxDistro = Debian
| Ubuntu | Ubuntu
@ -162,18 +182,21 @@ data LinuxDistro = Debian
-- ^ must exit -- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
prettyDistro :: LinuxDistro -> String distroToString :: LinuxDistro -> String
prettyDistro Debian = "debian" distroToString Debian = "debian"
prettyDistro Ubuntu = "ubuntu" distroToString Ubuntu = "ubuntu"
prettyDistro Mint= "mint" distroToString Mint= "mint"
prettyDistro Fedora = "fedora" distroToString Fedora = "fedora"
prettyDistro CentOS = "centos" distroToString CentOS = "centos"
prettyDistro RedHat = "redhat" distroToString RedHat = "redhat"
prettyDistro Alpine = "alpine" distroToString Alpine = "alpine"
prettyDistro AmazonLinux = "amazon" distroToString AmazonLinux = "amazon"
prettyDistro Gentoo = "gentoo" distroToString Gentoo = "gentoo"
prettyDistro Exherbo = "exherbo" distroToString Exherbo = "exherbo"
prettyDistro UnknownLinux = "unknown" distroToString UnknownLinux = "unknown"
instance Pretty LinuxDistro where
pPrint = text . distroToString
-- | An encapsulation of a download. This can be used -- | An encapsulation of a download. This can be used
@ -198,6 +221,10 @@ data TarDir = RealDir (Path Rel)
| RegexDir String -- ^ will be compiled to regex, the first match will "win" | RegexDir String -- ^ will be compiled to regex, the first match will "win"
deriving (Eq, Ord, GHC.Generic, Show) deriving (Eq, Ord, GHC.Generic, Show)
instance Pretty TarDir where
pPrint (RealDir path) = text [i|#{E.decodeUtf8With E.lenientDecode . toFilePath $ path}|]
pPrint (RegexDir regex) = text regex
-- | Where to fetch GHCupDownloads from. -- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL data URLSource = GHCupURL
@ -317,12 +344,15 @@ data PlatformResult = PlatformResult
} }
deriving (Eq, Show) deriving (Eq, Show)
prettyPlatform :: PlatformResult -> String platResToString :: PlatformResult -> String
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' } platResToString PlatformResult { _platform = plat, _distroVersion = Just v' }
= show plat <> ", " <> T.unpack (prettyV v') = show plat <> ", " <> T.unpack (prettyV v')
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing } platResToString PlatformResult { _platform = plat, _distroVersion = Nothing }
= show plat = show plat
instance Pretty PlatformResult where
pPrint = text . platResToString
data PlatformRequest = PlatformRequest data PlatformRequest = PlatformRequest
{ _rArch :: Architecture { _rArch :: Architecture
, _rPlatform :: Platform , _rPlatform :: Platform
@ -330,14 +360,17 @@ data PlatformRequest = PlatformRequest
} }
deriving (Eq, Show) deriving (Eq, Show)
prettyPfReq :: PlatformRequest -> String pfReqToString :: PlatformRequest -> String
prettyPfReq (PlatformRequest arch plat ver) = pfReqToString (PlatformRequest arch plat ver) =
prettyArch arch ++ "-" ++ prettyPlatfrom plat ++ pver archToString arch ++ "-" ++ platformToString plat ++ pver
where where
pver = case ver of pver = case ver of
Just v' -> "-" ++ (T.unpack $ prettyV v') Just v' -> "-" ++ (T.unpack $ prettyV v')
Nothing -> "" Nothing -> ""
instance Pretty PlatformRequest where
pPrint = text . pfReqToString
-- | A GHC identified by the target platform triple -- | A GHC identified by the target platform triple
-- and the version. -- and the version.
data GHCTargetVersion = GHCTargetVersion data GHCTargetVersion = GHCTargetVersion
@ -350,11 +383,13 @@ data GHCTargetVersion = GHCTargetVersion
mkTVer :: Version -> GHCTargetVersion mkTVer :: Version -> GHCTargetVersion
mkTVer = GHCTargetVersion Nothing mkTVer = GHCTargetVersion Nothing
tVerToText :: GHCTargetVersion -> Text
tVerToText (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v'
tVerToText (GHCTargetVersion Nothing v') = prettyVer v'
-- | Assembles a path of the form: <target-triple>-<version> -- | Assembles a path of the form: <target-triple>-<version>
prettyTVer :: GHCTargetVersion -> Text instance Pretty GHCTargetVersion where
prettyTVer (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v' pPrint = text . T.unpack . tVerToText
prettyTVer (GHCTargetVersion Nothing v') = prettyVer v'
-- | A comparator and a version. -- | A comparator and a version.
@ -372,3 +407,9 @@ data VersionRange = SimpleRange (NonEmpty VersionCmp) -- And
| OrRange (NonEmpty VersionCmp) VersionRange | OrRange (NonEmpty VersionCmp) VersionRange
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
instance Pretty Versioning where
pPrint = text . T.unpack . prettyV
instance Pretty Version where
pPrint = text . T.unpack . prettyVer

2
lib/GHCup/Utils.hs
View File

@ -650,7 +650,7 @@ ghcToolFiles ver = do
-- fail if ghc is not installed -- fail if ghc is not installed
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir) whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
(throwE (NotInstalled GHC (prettyTVer ver))) (throwE (NotInstalled GHC ver))
files <- liftIO $ getDirsFiles' bindir files <- liftIO $ getDirsFiles' bindir
-- figure out the <ver> suffix, because this might not be `Version` for -- figure out the <ver> suffix, because this might not be `Version` for

2
lib/GHCup/Utils/Dirs.hs
View File

@ -214,7 +214,7 @@ ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
-> m (Path Abs) -> m (Path Abs)
ghcupGHCDir ver = do ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel $ E.encodeUtf8 (prettyTVer ver) verdir <- parseRel $ E.encodeUtf8 (tVerToText ver)
pure (ghcbasedir </> verdir) pure (ghcbasedir </> verdir)

12
lib/GHCup/Utils/File.hs
View File

@ -43,7 +43,7 @@ import GHC.IO.Exception
import HPath import HPath
import HPath.IO hiding ( hideError ) import HPath.IO hiding ( hideError )
import Optics hiding ((<|), (|>)) import Optics hiding ((<|), (|>))
import System.Console.Pretty import System.Console.Pretty hiding ( Pretty )
import System.Console.Regions import System.Console.Regions
import System.IO.Error import System.IO.Error
import System.Posix.Directory.ByteString import System.Posix.Directory.ByteString
@ -55,6 +55,7 @@ import "unix" System.Posix.IO.ByteString
hiding ( openFd ) hiding ( openFd )
import System.Posix.Process ( ProcessStatus(..) ) import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Types import System.Posix.Types
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import Text.Regex.Posix import Text.Regex.Posix
@ -79,6 +80,15 @@ data ProcessError = NonZeroExit Int ByteString [ByteString]
| NoSuchPid ByteString [ByteString] | NoSuchPid ByteString [ByteString]
deriving Show deriving Show
instance Pretty ProcessError where
pPrint (NonZeroExit e exe args) =
text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} failed with exit code #{e}.|]
pPrint (PTerminated exe args) =
text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} terminated.|]
pPrint (PStopped exe args) =
text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} stopped.|]
pPrint (NoSuchPid exe args) =
text [i|Could not find PID for process running "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args}.|]
data CapturedProcess = CapturedProcess data CapturedProcess = CapturedProcess
{ _exitCode :: ExitCode { _exitCode :: ExitCode