Merge branch 'PR/issue-115'
This commit is contained in:
commit
d10cdfdf57
|
|
@ -32,6 +32,7 @@ import Optics
|
|||
import System.Exit
|
||||
import System.IO
|
||||
import Text.ParserCombinators.ReadP
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
import Text.Regex.Posix
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
|
|
@ -83,7 +84,7 @@ validate dls = do
|
|||
where
|
||||
checkHasRequiredPlatforms t v tags arch pspecs = do
|
||||
let v' = prettyVer v
|
||||
arch' = prettyArch arch
|
||||
arch' = prettyShow arch
|
||||
when (not $ any (== Linux UnknownLinux) pspecs) $ do
|
||||
lift $ $(logError)
|
||||
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch'}|]
|
||||
|
|
|
|||
|
|
@ -48,6 +48,7 @@ import Prelude hiding ( appendFile )
|
|||
import System.Environment
|
||||
import System.Exit
|
||||
import System.IO.Unsafe
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified GHCup.Types as GT
|
||||
|
|
@ -445,12 +446,8 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
|||
runLogger $ $(logInfo) msg
|
||||
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 e -> pure $ Left [i|#{e}
|
||||
VLeft e -> pure $ Left [i|#{prettyShow e}
|
||||
Also check the logs in ~/.ghcup/logs|]
|
||||
|
||||
|
||||
|
|
@ -474,7 +471,7 @@ set' _ (_, ListResult {..}) = do
|
|||
)
|
||||
>>= \case
|
||||
VRight _ -> pure $ Right ()
|
||||
VLeft e -> pure $ Left [i|#{e}|]
|
||||
VLeft e -> pure $ Left (prettyShow e)
|
||||
|
||||
|
||||
del' :: BrickState -> (Int, ListResult) -> IO (Either String ())
|
||||
|
|
@ -500,7 +497,7 @@ del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
|||
runLogger $ $(logInfo) msg
|
||||
pure $ Right ()
|
||||
VRight _ -> pure $ Right ()
|
||||
VLeft e -> pure $ Left [i|#{e}|]
|
||||
VLeft e -> pure $ Left (prettyShow e)
|
||||
|
||||
|
||||
changelog' :: BrickState -> (Int, ListResult) -> IO (Either String ())
|
||||
|
|
@ -515,7 +512,7 @@ changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
|||
FreeBSD -> "xdg-open"
|
||||
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
|
||||
Right _ -> pure $ Right ()
|
||||
Left e -> pure $ Left [i|#{e}|]
|
||||
Left e -> pure $ Left $ prettyShow e
|
||||
|
||||
|
||||
settings' :: IORef AppState
|
||||
|
|
@ -595,7 +592,7 @@ getDownloads' = do
|
|||
|
||||
case r of
|
||||
VRight a -> pure $ Right a
|
||||
VLeft e -> pure $ Left [i|#{e}|]
|
||||
VLeft e -> pure $ Left (prettyShow e)
|
||||
|
||||
|
||||
getAppData :: Maybe GHCupDownloads
|
||||
|
|
|
|||
|
|
@ -66,6 +66,7 @@ import System.Environment
|
|||
import System.Exit
|
||||
import System.IO hiding ( appendFile )
|
||||
import Text.Read hiding ( lift )
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
|
|
@ -113,7 +114,7 @@ data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
|
|||
| ToolTag Tag
|
||||
|
||||
prettyToolVer :: ToolVersion -> String
|
||||
prettyToolVer (ToolVersion v') = T.unpack $ prettyTVer v'
|
||||
prettyToolVer (ToolVersion v') = T.unpack $ tVerToText v'
|
||||
prettyToolVer (ToolTag t) = show t
|
||||
|
||||
toSetToolVer :: Maybe ToolVersion -> SetToolVersion
|
||||
|
|
@ -830,7 +831,7 @@ tagCompleter tool add = listIOCompleter $ do
|
|||
$ join
|
||||
$ M.elems
|
||||
$ availableToolVersions (_ghcupDownloads dls) tool
|
||||
pure $ nub $ (add ++) $ fmap prettyTag allTags
|
||||
pure $ nub $ (add ++) $ fmap tagToString allTags
|
||||
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
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) [i|Error determining Platform: #{e}|])
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 2)
|
||||
|
||||
|
||||
|
|
@ -1246,7 +1247,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
VRight r -> pure r
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError) [i|Error fetching download info: #{e}|])
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 2)
|
||||
|
||||
case optCommand of
|
||||
|
|
@ -1285,23 +1286,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
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|]
|
||||
pure ExitSuccess
|
||||
VLeft (V (BuildFailed tmpdir e)) -> do
|
||||
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
||||
case keepDirs settings of
|
||||
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
|
||||
_ -> runLogger ($(logError) [i|Build failed with #{e}
|
||||
Never -> runLogger ($(logError) $ T.pack $ prettyShow err)
|
||||
_ -> runLogger ($(logError) [i|#{prettyShow err}
|
||||
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
|
||||
Make sure to clean up #{tmpdir} afterwards.|])
|
||||
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
|
||||
runLogger $ do
|
||||
$(logError) [i|#{e}|]
|
||||
$(logError) $ T.pack $ prettyShow e
|
||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
||||
pure $ ExitFailure 3
|
||||
|
||||
|
|
@ -1330,16 +1324,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
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|]
|
||||
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
|
||||
runLogger $ do
|
||||
$(logError) [i|#{e}|]
|
||||
$(logError) $ T.pack $ prettyShow e
|
||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
||||
pure $ ExitFailure 4
|
||||
|
||||
|
|
@ -1367,16 +1354,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
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|]
|
||||
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
|
||||
runLogger $ do
|
||||
$(logError) [i|#{e}|]
|
||||
$(logError) $ T.pack $ prettyShow e
|
||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
||||
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}|]
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 5
|
||||
|
||||
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|]
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 14
|
||||
|
||||
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|]
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 14
|
||||
|
||||
let rmGHC' RmOptions{..} =
|
||||
|
|
@ -1442,7 +1422,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 7
|
||||
|
||||
let rmCabal' tv =
|
||||
|
|
@ -1459,7 +1439,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 15
|
||||
|
||||
let rmHLS' tv =
|
||||
|
|
@ -1476,7 +1456,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 15
|
||||
|
||||
|
||||
|
|
@ -1523,7 +1503,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
putStrLn $ prettyDebugInfo dinfo
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 8
|
||||
|
||||
Compile (CompileGHC GHCCompileOptions {..}) ->
|
||||
|
|
@ -1558,16 +1538,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||
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|]
|
||||
pure ExitSuccess
|
||||
VLeft (V (BuildFailed tmpdir e)) -> do
|
||||
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
||||
case keepDirs settings of
|
||||
Never -> runLogger ($(logError) [i|Build failed with #{e}
|
||||
Check the logs at #{logsDir}|])
|
||||
_ -> runLogger ($(logError) [i|Build failed with #{e}
|
||||
Never -> runLogger $ $(logError) $ T.pack $ prettyShow err
|
||||
_ -> runLogger ($(logError) [i|#{prettyShow err}
|
||||
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
|
||||
Make sure to clean up #{tmpdir} afterwards.|])
|
||||
pure $ ExitFailure 9
|
||||
VLeft e -> do
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 9
|
||||
|
||||
Upgrade (uOpts) force -> do
|
||||
|
|
@ -1592,7 +1571,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||
runLogger $ $(logWarn) [i|No GHCup update available|]
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger ($(logError) [i|#{e}|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 11
|
||||
|
||||
ToolRequirements ->
|
||||
|
|
@ -1609,10 +1588,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||
>>= \case
|
||||
VRight _ -> pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
($(logError)
|
||||
[i|Error getting tool requirements: #{e}|]
|
||||
)
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 12
|
||||
|
||||
ChangeLog (ChangeLogOptions {..}) -> do
|
||||
|
|
@ -1926,7 +1902,7 @@ GHCup base dir: #{toFilePath diBaseDir}
|
|||
GHCup bin dir: #{toFilePath diBinDir}
|
||||
GHCup GHC directory: #{toFilePath diGHCDir}
|
||||
GHCup cache directory: #{toFilePath diCacheDir}
|
||||
Architecture: #{prettyArch diArch}
|
||||
Platform: #{prettyPlatform diPlatform}
|
||||
Architecture: #{prettyShow diArch}
|
||||
Platform: #{prettyShow diPlatform}
|
||||
Version: #{describe_result}|]
|
||||
|
||||
|
|
|
|||
|
|
@ -150,6 +150,9 @@ common optparse-applicative
|
|||
common parsec
|
||||
build-depends: parsec >=3.1
|
||||
|
||||
common pretty
|
||||
build-depends: pretty >=1.1.3.1
|
||||
|
||||
common pretty-terminal
|
||||
build-depends: pretty-terminal >=0.1.0.0
|
||||
|
||||
|
|
@ -288,6 +291,7 @@ library
|
|||
, optics
|
||||
, optics-vl
|
||||
, parsec
|
||||
, pretty
|
||||
, pretty-terminal
|
||||
, regex-posix
|
||||
, resourcet
|
||||
|
|
@ -377,6 +381,7 @@ executable ghcup
|
|||
, monad-logger
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, pretty
|
||||
, pretty-terminal
|
||||
, resourcet
|
||||
, safe
|
||||
|
|
@ -432,6 +437,7 @@ executable ghcup-gen
|
|||
, mtl
|
||||
, optics
|
||||
, optparse-applicative
|
||||
, pretty
|
||||
, pretty-terminal
|
||||
, regex-posix
|
||||
, resourcet
|
||||
|
|
|
|||
14
lib/GHCup.hs
14
lib/GHCup.hs
|
|
@ -525,7 +525,7 @@ setGHC ver sghc = do
|
|||
let verBS = verToBS (_tvVersion 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
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
|
|
@ -605,7 +605,7 @@ setCabal ver = do
|
|||
|
||||
whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile))
|
||||
$ throwE
|
||||
$ NotInstalled Cabal (prettyVer ver)
|
||||
$ NotInstalled Cabal (GHCTargetVersion Nothing ver)
|
||||
|
||||
let cabalbin = binDir </> [rel|cabal|]
|
||||
|
||||
|
|
@ -647,7 +647,7 @@ setHLS ver = do
|
|||
|
||||
-- set haskell-language-server-<ghcver> symlinks
|
||||
bins <- lift $ hlsServerBinaries ver
|
||||
when (bins == []) $ throwE $ NotInstalled HLS (prettyVer ver)
|
||||
when (bins == []) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
|
||||
|
||||
forM_ bins $ \f -> do
|
||||
let destL = toFilePath f
|
||||
|
|
@ -929,7 +929,7 @@ rmGHCVer :: ( MonadReader AppState m
|
|||
rmGHCVer ver = do
|
||||
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
|
||||
|
||||
-- this isn't atomic, order matters
|
||||
|
|
@ -970,7 +970,7 @@ rmCabalVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, M
|
|||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
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
|
||||
|
||||
|
|
@ -993,7 +993,7 @@ rmHLSVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, Mon
|
|||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
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
|
||||
|
||||
|
|
@ -1240,7 +1240,7 @@ Stage1Only = YES|]
|
|||
$ c
|
||||
tarName <-
|
||||
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
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
|
||||
tarPath
|
||||
|
|
|
|||
|
|
@ -1,7 +1,13 @@
|
|||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Errors
|
||||
|
|
@ -15,13 +21,21 @@ Portability : POSIX
|
|||
module GHCup.Errors where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
#if !defined(TAR)
|
||||
import Codec.Archive
|
||||
#endif
|
||||
import Control.Exception.Safe
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import Haskus.Utils.Variant
|
||||
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
|
||||
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.
|
||||
data NoDownload = NoDownload
|
||||
deriving Show
|
||||
|
||||
instance Pretty NoDownload where
|
||||
pPrint NoDownload =
|
||||
text "Unable to find a download for the requested version/distro."
|
||||
|
||||
-- | No update available or necessary.
|
||||
data NoUpdate = NoUpdate
|
||||
deriving Show
|
||||
|
||||
instance Pretty NoUpdate where
|
||||
pPrint NoUpdate = text "No update available or necessary."
|
||||
|
||||
-- | The Architecture is unknown and unsupported.
|
||||
data NoCompatibleArch = NoCompatibleArch String
|
||||
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.
|
||||
data DistroNotFound = DistroNotFound
|
||||
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.
|
||||
data UnknownArchive = UnknownArchive ByteString
|
||||
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).
|
||||
data UnsupportedScheme = UnsupportedScheme
|
||||
deriving Show
|
||||
|
||||
instance Pretty UnsupportedScheme where
|
||||
pPrint UnsupportedScheme = text "The scheme is not supported (such as ftp)."
|
||||
|
||||
-- | Unable to copy a file.
|
||||
data CopyError = CopyError String
|
||||
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.
|
||||
data TagNotFound = TagNotFound Tag Tool
|
||||
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.
|
||||
data VerNotFound = VerNotFound Version Tool
|
||||
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
|
||||
-- set one).
|
||||
data NextVerNotFound = NextVerNotFound Tool
|
||||
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.
|
||||
data AlreadyInstalled = AlreadyInstalled Tool Version
|
||||
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
|
||||
-- to be installed (such as setting the current GHC version).
|
||||
data NotInstalled = NotInstalled Tool Text
|
||||
data NotInstalled = NotInstalled Tool GHCTargetVersion
|
||||
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.
|
||||
data NotFoundInPATH = NotFoundInPATH (Path Rel)
|
||||
deriving Show
|
||||
|
||||
instance Pretty NotFoundInPATH where
|
||||
pPrint (NotFoundInPATH exe) =
|
||||
text [i|The exe "#{decUTF8Safe . toFilePath $ exe}" was not found in PATH.|]
|
||||
|
||||
-- | JSON decoding failed.
|
||||
data JSONError = JSONDecodeError String
|
||||
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
|
||||
-- (e.g. when we use file scheme to "download" something).
|
||||
data FileDoesNotExistError = FileDoesNotExistError ByteString
|
||||
deriving Show
|
||||
|
||||
instance Pretty FileDoesNotExistError where
|
||||
pPrint (FileDoesNotExistError file) =
|
||||
text [i|File "#{decUTF8Safe file}" does not exist.|]
|
||||
|
||||
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
|
||||
deriving Show
|
||||
|
||||
instance Pretty TarDirDoesNotExist where
|
||||
pPrint (TarDirDoesNotExist dir) =
|
||||
text "Tar directory does not exist:" <+> pPrint dir
|
||||
|
||||
-- | File digest verification failed.
|
||||
data DigestError = DigestError Text Text
|
||||
deriving Show
|
||||
|
||||
instance Pretty DigestError where
|
||||
pPrint (DigestError currentDigest expectedDigest) =
|
||||
text [i|Digest error: expected "#{expectedDigest}", but got "#{currentDigest}"|]
|
||||
|
||||
-- | Unexpected HTTP status.
|
||||
data HTTPStatusError = HTTPStatusError Int
|
||||
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.
|
||||
data NoLocationHeader = NoLocationHeader
|
||||
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.
|
||||
data TooManyRedirs = TooManyRedirs
|
||||
deriving Show
|
||||
|
||||
instance Pretty TooManyRedirs where
|
||||
pPrint TooManyRedirs =
|
||||
text [i|Too many redirections.|]
|
||||
|
||||
-- | A patch could not be applied.
|
||||
data PatchFailed = PatchFailed
|
||||
deriving Show
|
||||
|
||||
instance Pretty PatchFailed where
|
||||
pPrint PatchFailed =
|
||||
text [i|A patch could not be applied.|]
|
||||
|
||||
-- | The tool requirements could not be found.
|
||||
data NoToolRequirements = NoToolRequirements
|
||||
deriving Show
|
||||
|
||||
instance Pretty NoToolRequirements where
|
||||
pPrint NoToolRequirements =
|
||||
text [i|The Tool requirements could not be found.|]
|
||||
|
||||
data InvalidBuildConfig = InvalidBuildConfig Text
|
||||
deriving Show
|
||||
|
||||
|
||||
instance Pretty InvalidBuildConfig where
|
||||
pPrint (InvalidBuildConfig reason) =
|
||||
text [i|The build config is invalid. Reason was: #{reason}|]
|
||||
|
||||
data NoToolVersionSet = NoToolVersionSet Tool
|
||||
deriving Show
|
||||
|
||||
instance Pretty NoToolVersionSet where
|
||||
pPrint (NoToolVersionSet tool) =
|
||||
text [i|No version is set for tool "#{tool}".|]
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ High-level errors ]--
|
||||
-------------------------
|
||||
|
||||
-- | 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
|
||||
|
||||
|
|
@ -145,12 +261,20 @@ deriving instance Show DownloadFailed
|
|||
-- | A build failed.
|
||||
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
|
||||
|
||||
|
||||
-- | Setting the current GHC version failed.
|
||||
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
|
||||
|
||||
|
||||
|
|
@ -163,11 +287,65 @@ deriving instance Show GHCupSetError
|
|||
data ParseError = ParseError String
|
||||
deriving Show
|
||||
|
||||
instance Pretty ParseError where
|
||||
pPrint (ParseError reason) =
|
||||
text [i|Parsing failed: #{reason}|]
|
||||
|
||||
instance Exception ParseError
|
||||
|
||||
|
||||
data UnexpectedListLength = UnexpectedListLength String
|
||||
deriving Show
|
||||
|
||||
instance Pretty UnexpectedListLength where
|
||||
pPrint (UnexpectedListLength reason) =
|
||||
text [i|List length unexpected: #{reason}|]
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Types
|
||||
|
|
@ -15,12 +17,16 @@ module GHCup.Types where
|
|||
|
||||
import Data.Map.Strict ( Map )
|
||||
import Data.List.NonEmpty ( NonEmpty (..) )
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import HPath
|
||||
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
|
||||
import URI.ByteString
|
||||
|
||||
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 Graphics.Vty as Vty
|
||||
|
||||
|
|
@ -106,13 +112,21 @@ data Tag = Latest
|
|||
| UnknownTag String -- ^ used for upwardscompat
|
||||
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
|
||||
|
||||
prettyTag :: Tag -> String
|
||||
prettyTag Recommended = "recommended"
|
||||
prettyTag Latest = "latest"
|
||||
prettyTag Prerelease = "prerelease"
|
||||
prettyTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
|
||||
prettyTag (UnknownTag t ) = t
|
||||
prettyTag Old = ""
|
||||
tagToString :: Tag -> String
|
||||
tagToString Recommended = "recommended"
|
||||
tagToString Latest = "latest"
|
||||
tagToString Prerelease = "prerelease"
|
||||
tagToString (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
|
||||
tagToString (UnknownTag t ) = t
|
||||
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
|
||||
| A_32
|
||||
|
|
@ -124,15 +138,18 @@ data Architecture = A_64
|
|||
| A_ARM64
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
prettyArch :: Architecture -> String
|
||||
prettyArch A_64 = "x86_64"
|
||||
prettyArch A_32 = "i386"
|
||||
prettyArch A_PowerPC = "powerpc"
|
||||
prettyArch A_PowerPC64 = "powerpc64"
|
||||
prettyArch A_Sparc = "sparc"
|
||||
prettyArch A_Sparc64 = "sparc64"
|
||||
prettyArch A_ARM = "arm"
|
||||
prettyArch A_ARM64 = "aarch64"
|
||||
archToString :: Architecture -> String
|
||||
archToString A_64 = "x86_64"
|
||||
archToString A_32 = "i386"
|
||||
archToString A_PowerPC = "powerpc"
|
||||
archToString A_PowerPC64 = "powerpc64"
|
||||
archToString A_Sparc = "sparc"
|
||||
archToString A_Sparc64 = "sparc64"
|
||||
archToString A_ARM = "arm"
|
||||
archToString A_ARM64 = "aarch64"
|
||||
|
||||
instance Pretty Architecture where
|
||||
pPrint = text . archToString
|
||||
|
||||
data Platform = Linux LinuxDistro
|
||||
-- ^ must exit
|
||||
|
|
@ -141,10 +158,13 @@ data Platform = Linux LinuxDistro
|
|||
| FreeBSD
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
prettyPlatfrom :: Platform -> String
|
||||
prettyPlatfrom (Linux distro) = "linux-" ++ prettyDistro distro
|
||||
prettyPlatfrom Darwin = "darwin"
|
||||
prettyPlatfrom FreeBSD = "freebsd"
|
||||
platformToString :: Platform -> String
|
||||
platformToString (Linux distro) = "linux-" ++ distroToString distro
|
||||
platformToString Darwin = "darwin"
|
||||
platformToString FreeBSD = "freebsd"
|
||||
|
||||
instance Pretty Platform where
|
||||
pPrint = text . platformToString
|
||||
|
||||
data LinuxDistro = Debian
|
||||
| Ubuntu
|
||||
|
|
@ -162,18 +182,21 @@ data LinuxDistro = Debian
|
|||
-- ^ must exit
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
prettyDistro :: LinuxDistro -> String
|
||||
prettyDistro Debian = "debian"
|
||||
prettyDistro Ubuntu = "ubuntu"
|
||||
prettyDistro Mint= "mint"
|
||||
prettyDistro Fedora = "fedora"
|
||||
prettyDistro CentOS = "centos"
|
||||
prettyDistro RedHat = "redhat"
|
||||
prettyDistro Alpine = "alpine"
|
||||
prettyDistro AmazonLinux = "amazon"
|
||||
prettyDistro Gentoo = "gentoo"
|
||||
prettyDistro Exherbo = "exherbo"
|
||||
prettyDistro UnknownLinux = "unknown"
|
||||
distroToString :: LinuxDistro -> String
|
||||
distroToString Debian = "debian"
|
||||
distroToString Ubuntu = "ubuntu"
|
||||
distroToString Mint= "mint"
|
||||
distroToString Fedora = "fedora"
|
||||
distroToString CentOS = "centos"
|
||||
distroToString RedHat = "redhat"
|
||||
distroToString Alpine = "alpine"
|
||||
distroToString AmazonLinux = "amazon"
|
||||
distroToString Gentoo = "gentoo"
|
||||
distroToString Exherbo = "exherbo"
|
||||
distroToString UnknownLinux = "unknown"
|
||||
|
||||
instance Pretty LinuxDistro where
|
||||
pPrint = text . distroToString
|
||||
|
||||
|
||||
-- | 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"
|
||||
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.
|
||||
data URLSource = GHCupURL
|
||||
|
|
@ -317,12 +344,15 @@ data PlatformResult = PlatformResult
|
|||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
prettyPlatform :: PlatformResult -> String
|
||||
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
|
||||
platResToString :: PlatformResult -> String
|
||||
platResToString PlatformResult { _platform = plat, _distroVersion = Just v' }
|
||||
= show plat <> ", " <> T.unpack (prettyV v')
|
||||
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing }
|
||||
platResToString PlatformResult { _platform = plat, _distroVersion = Nothing }
|
||||
= show plat
|
||||
|
||||
instance Pretty PlatformResult where
|
||||
pPrint = text . platResToString
|
||||
|
||||
data PlatformRequest = PlatformRequest
|
||||
{ _rArch :: Architecture
|
||||
, _rPlatform :: Platform
|
||||
|
|
@ -330,14 +360,17 @@ data PlatformRequest = PlatformRequest
|
|||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
prettyPfReq :: PlatformRequest -> String
|
||||
prettyPfReq (PlatformRequest arch plat ver) =
|
||||
prettyArch arch ++ "-" ++ prettyPlatfrom plat ++ pver
|
||||
pfReqToString :: PlatformRequest -> String
|
||||
pfReqToString (PlatformRequest arch plat ver) =
|
||||
archToString arch ++ "-" ++ platformToString plat ++ pver
|
||||
where
|
||||
pver = case ver of
|
||||
Just v' -> "-" ++ (T.unpack $ prettyV v')
|
||||
Nothing -> ""
|
||||
|
||||
instance Pretty PlatformRequest where
|
||||
pPrint = text . pfReqToString
|
||||
|
||||
-- | A GHC identified by the target platform triple
|
||||
-- and the version.
|
||||
data GHCTargetVersion = GHCTargetVersion
|
||||
|
|
@ -350,11 +383,13 @@ data GHCTargetVersion = GHCTargetVersion
|
|||
mkTVer :: Version -> GHCTargetVersion
|
||||
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>
|
||||
prettyTVer :: GHCTargetVersion -> Text
|
||||
prettyTVer (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v'
|
||||
prettyTVer (GHCTargetVersion Nothing v') = prettyVer v'
|
||||
instance Pretty GHCTargetVersion where
|
||||
pPrint = text . T.unpack . tVerToText
|
||||
|
||||
|
||||
-- | A comparator and a version.
|
||||
|
|
@ -372,3 +407,9 @@ data VersionRange = SimpleRange (NonEmpty VersionCmp) -- And
|
|||
| OrRange (NonEmpty VersionCmp) VersionRange
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
instance Pretty Versioning where
|
||||
pPrint = text . T.unpack . prettyV
|
||||
|
||||
instance Pretty Version where
|
||||
pPrint = text . T.unpack . prettyVer
|
||||
|
|
|
|||
|
|
@ -650,7 +650,7 @@ ghcToolFiles ver = do
|
|||
|
||||
-- fail if ghc is not installed
|
||||
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
|
||||
(throwE (NotInstalled GHC (prettyTVer ver)))
|
||||
(throwE (NotInstalled GHC ver))
|
||||
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
-- figure out the <ver> suffix, because this might not be `Version` for
|
||||
|
|
|
|||
|
|
@ -214,7 +214,7 @@ ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
|
|||
-> m (Path Abs)
|
||||
ghcupGHCDir ver = do
|
||||
ghcbasedir <- ghcupGHCBaseDir
|
||||
verdir <- parseRel $ E.encodeUtf8 (prettyTVer ver)
|
||||
verdir <- parseRel $ E.encodeUtf8 (tVerToText ver)
|
||||
pure (ghcbasedir </> verdir)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ import GHC.IO.Exception
|
|||
import HPath
|
||||
import HPath.IO hiding ( hideError )
|
||||
import Optics hiding ((<|), (|>))
|
||||
import System.Console.Pretty
|
||||
import System.Console.Pretty hiding ( Pretty )
|
||||
import System.Console.Regions
|
||||
import System.IO.Error
|
||||
import System.Posix.Directory.ByteString
|
||||
|
|
@ -55,6 +55,7 @@ import "unix" System.Posix.IO.ByteString
|
|||
hiding ( openFd )
|
||||
import System.Posix.Process ( ProcessStatus(..) )
|
||||
import System.Posix.Types
|
||||
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
|
||||
import Text.Regex.Posix
|
||||
|
||||
|
||||
|
|
@ -79,6 +80,15 @@ data ProcessError = NonZeroExit Int ByteString [ByteString]
|
|||
| NoSuchPid ByteString [ByteString]
|
||||
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
|
||||
{ _exitCode :: ExitCode
|
||||
|
|
|
|||
Loading…
Reference in New Issue