diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 33aa3a5..d96b198 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -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'}|] diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 58cc19d..0d56930 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -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 diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 408ecf5..2575f4c 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -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 |] 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 |] 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 |] 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 |] 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 |] 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 |] [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 |] [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 |] [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 |] 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 |] 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 |] 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 |] 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 |] 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}|] diff --git a/ghcup.cabal b/ghcup.cabal index 3c4a079..1991f3f 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 7206a9d..71e6340 100644 --- a/lib/GHCup.hs +++ b/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- 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 diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 62944df..66f9ffc 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -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 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index f53833d..78ca40f 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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: - -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 diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index b85090a..214b28b 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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 suffix, because this might not be `Version` for diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 67d394d..bdac283 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -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) diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 8e3db48..766018a 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -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