ghcup-hs/lib/GHCup/Errors.hs

490 lines
16 KiB
Haskell
Raw Normal View History

{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}
2021-03-11 16:03:51 +00:00
{-# LANGUAGE DataKinds #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
{-|
Module : GHCup.Errors
Description : GHCup error types
Copyright : (c) Julian Ospald, 2020
2020-07-30 18:04:02 +00:00
License : LGPL-3.0
2020-07-21 23:08:58 +00:00
Maintainer : hasufell@hasufell.de
Stability : experimental
2021-05-14 21:09:45 +00:00
Portability : portable
2020-07-21 23:08:58 +00:00
-}
2020-01-11 20:15:05 +00:00
module GHCup.Errors where
import GHCup.Types
import Codec.Archive
2020-01-11 20:15:05 +00:00
import Control.Exception.Safe
2021-07-24 14:36:31 +00:00
import Data.ByteString ( ByteString )
import Data.CaseInsensitive ( CI )
2020-01-11 20:15:05 +00:00
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant
import System.FilePath
import Text.PrettyPrint hiding ( (<>) )
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import URI.ByteString
2020-01-11 20:15:05 +00:00
2021-07-24 14:36:31 +00:00
import qualified Data.Map.Strict as M
2021-08-25 16:54:58 +00:00
import qualified Data.Text as T
2021-07-24 14:36:31 +00:00
2020-01-11 20:15:05 +00:00
------------------------
--[ Low-level errors ]--
------------------------
-- | A compatible platform could not be found.
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')
2021-08-29 12:50:49 +00:00
-- | Unable to find a download for the requested version/distro.
2020-01-11 20:15:05 +00:00
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."
2020-01-11 20:15:05 +00:00
-- | 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)
2020-01-11 20:15:05 +00:00
-- | 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."
2020-01-11 20:15:05 +00:00
-- | The archive format is unknown. We don't know how to extract it.
2021-05-14 21:09:45 +00:00
data UnknownArchive = UnknownArchive FilePath
2020-01-11 20:15:05 +00:00
deriving Show
instance Pretty UnknownArchive where
pPrint (UnknownArchive file) =
2021-08-25 16:54:58 +00:00
text $ "The archive format is unknown. We don't know how to extract the file " <> file
2020-01-11 20:15:05 +00:00
-- | 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)."
2020-01-11 20:15:05 +00:00
-- | 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 merge file trees.
data MergeFileTreeError = MergeFileTreeError IOException FilePath FilePath
deriving Show
instance Pretty MergeFileTreeError where
pPrint (MergeFileTreeError e from to) =
text "Failed to merge file tree from" <+> text from <+> text "to" <+> text to <+> text "\nexception was:" <+> text (displayException e)
2022-05-28 14:44:08 +00:00
<+> text "\n...you may need to delete" <+> text to <+> text "manually. Make sure it's gone."
2020-01-11 20:15:05 +00:00
-- | Unable to find a tag of a tool.
data TagNotFound = TagNotFound Tag Tool
deriving Show
instance Pretty TagNotFound where
pPrint (TagNotFound tag tool) =
2021-08-25 16:54:58 +00:00
text "Unable to find tag" <+> pPrint tag <+> text "of tool" <+> pPrint tool
2021-02-25 17:21:25 +00:00
-- | 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) =
2021-08-25 16:54:58 +00:00
text "Unable to find next (the one after the currently set one) version of tool" <+> pPrint tool
2020-01-11 20:15:05 +00:00
-- | 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') =
2022-07-11 14:01:40 +00:00
(pPrint tool <> text "-" <> pPrint ver') <+> text "is already installed;"
2022-08-23 11:59:08 +00:00
<+> text "if you really want to reinstall it, you may want to run 'ghcup install" <+> pPrint tool <+> text "--force" <+> (pPrint ver' <> text "'")
2022-05-23 21:49:43 +00:00
2021-08-11 10:24:51 +00:00
-- | The Directory is supposed to be empty, but wasn't.
data DirNotEmpty = DirNotEmpty {path :: FilePath}
2022-05-23 21:32:58 +00:00
deriving Show
2021-08-11 10:24:51 +00:00
instance Pretty DirNotEmpty where
pPrint (DirNotEmpty path) = do
2021-08-25 16:54:58 +00:00
text $ "The directory was expected to be empty, but isn't: " <> path
2020-01-11 20:15:05 +00:00
-- | 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 GHCTargetVersion
2020-01-11 20:15:05 +00:00
deriving Show
instance Pretty NotInstalled where
pPrint (NotInstalled tool ver) =
2021-08-25 16:54:58 +00:00
text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."
data UninstallFailed = UninstallFailed FilePath [FilePath]
deriving Show
instance Pretty UninstallFailed where
pPrint (UninstallFailed dir files) =
text "The following files survived uninstallation: " <+> pPrint files <+> text "...consider removing" <+> pPrint dir <+> text "manually."
2020-04-10 20:44:43 +00:00
-- | An executable was expected to be in PATH, but was not found.
2021-05-14 21:09:45 +00:00
data NotFoundInPATH = NotFoundInPATH FilePath
2020-04-10 20:44:43 +00:00
deriving Show
instance Exception NotFoundInPATH
instance Pretty NotFoundInPATH where
pPrint (NotFoundInPATH exe) =
2021-08-25 16:54:58 +00:00
text $ "The exe " <> exe <> " was not found in PATH."
2020-01-11 20:15:05 +00:00
-- | JSON decoding failed.
data JSONError = JSONDecodeError String
deriving Show
instance Pretty JSONError where
pPrint (JSONDecodeError err) =
2021-08-25 16:54:58 +00:00
text $ "JSON decoding failed with: " <> err
2020-01-11 20:15:05 +00:00
-- | A file that is supposed to exist does not exist
-- (e.g. when we use file scheme to "download" something).
2021-05-14 21:09:45 +00:00
data FileDoesNotExistError = FileDoesNotExistError FilePath
2020-01-11 20:15:05 +00:00
deriving Show
instance Pretty FileDoesNotExistError where
pPrint (FileDoesNotExistError file) =
2021-08-25 16:54:58 +00:00
text $ "File " <> file <> " does not exist."
-- | The file already exists
-- (e.g. when we use isolated installs with the same path).
-- (e.g. This is done to prevent any overwriting)
data FileAlreadyExistsError = FileAlreadyExistsError FilePath
deriving Show
instance Pretty FileAlreadyExistsError where
pPrint (FileAlreadyExistsError file) =
2021-08-25 16:54:58 +00:00
text $ "File " <> file <> " Already exists."
2020-08-06 11:28:20 +00:00
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show
instance Pretty TarDirDoesNotExist where
pPrint (TarDirDoesNotExist dir) =
text "Tar directory does not exist:" <+> pPrint dir
2020-01-11 20:15:05 +00:00
-- | File digest verification failed.
2021-09-19 19:24:21 +00:00
data DigestError = DigestError FilePath Text Text
2020-01-11 20:15:05 +00:00
deriving Show
instance Pretty DigestError where
2021-09-19 19:24:21 +00:00
pPrint (DigestError fp currentDigest expectedDigest) =
text "Digest error for" <+> text (fp <> ": expected")
<+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest <+> text
"\nConsider removing the file in case it's cached and try again."
-- | File content length verification failed.
data ContentLengthError = ContentLengthError (Maybe FilePath) (Maybe Integer) Integer
deriving Show
instance Pretty ContentLengthError where
pPrint (ContentLengthError Nothing Nothing expectedSize) =
text "Content length exceeded expected size:"
<+> text (show expectedSize)
<+> text "\nConsider removing the file in case it's cached and try again."
pPrint (ContentLengthError Nothing (Just currentSize) expectedSize) =
text "Content length error. Expected"
<+> text (show expectedSize) <+> text "but got" <+> pPrint currentSize <+> text
"\nConsider removing the file in case it's cached and try again."
pPrint (ContentLengthError (Just fp) (Just currentSize) expectedSize) =
text "Content length error for" <+> text (fp <> ": expected")
<+> text (show expectedSize) <+> text "but got" <+> pPrint currentSize <+> text
"\nConsider removing the file in case it's cached and try again."
pPrint (ContentLengthError (Just fp) Nothing expectedSize) =
text "Content length error for" <+> text (fp <> ": expected")
<+> text (show expectedSize) <+> text "\nConsider removing the file in case it's cached and try again."
instance Exception ContentLengthError
2021-09-18 17:45:32 +00:00
-- | File digest verification failed.
data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs)
deriving instance Show GPGError
instance Pretty GPGError where
pPrint (GPGError reason) = text "GPG verify failed:" <+> pPrint reason
2020-01-11 20:15:05 +00:00
-- | Unexpected HTTP status.
2021-07-24 14:36:31 +00:00
data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
2020-01-11 20:15:05 +00:00
deriving Show
instance Pretty HTTPStatusError where
2021-07-24 14:36:31 +00:00
pPrint (HTTPStatusError status _) =
2021-08-25 16:54:58 +00:00
text "Unexpected HTTP status:" <+> pPrint status
2021-07-24 14:36:31 +00:00
-- | Malformed headers.
data MalformedHeaders = MalformedHeaders Text
deriving Show
instance Pretty MalformedHeaders where
pPrint (MalformedHeaders h) =
2021-08-25 16:54:58 +00:00
text "Headers are malformed: " <+> pPrint h
2021-07-24 14:36:31 +00:00
-- | Unexpected HTTP status.
data HTTPNotModified = HTTPNotModified Text
deriving Show
instance Pretty HTTPNotModified where
pPrint (HTTPNotModified etag) =
2021-08-25 16:54:58 +00:00
text "Remote resource not modifed, etag was:" <+> pPrint etag
2021-07-24 14:36:31 +00:00
2020-01-11 20:15:05 +00:00
-- | The 'Location' header was expected during a 3xx redirect, but not found.
data NoLocationHeader = NoLocationHeader
deriving Show
instance Pretty NoLocationHeader where
pPrint NoLocationHeader =
2021-08-25 16:54:58 +00:00
text "The 'Location' header was expected during a 3xx redirect, but not found."
2020-01-11 20:15:05 +00:00
-- | Too many redirects.
data TooManyRedirs = TooManyRedirs
deriving Show
instance Pretty TooManyRedirs where
pPrint TooManyRedirs =
2021-08-25 16:54:58 +00:00
text "Too many redirections."
-- | A patch could not be applied.
data PatchFailed = PatchFailed
deriving Show
instance Pretty PatchFailed where
pPrint PatchFailed =
2021-08-25 16:54:58 +00:00
text "A patch could not be applied."
2020-04-10 15:36:27 +00:00
-- | The tool requirements could not be found.
data NoToolRequirements = NoToolRequirements
deriving Show
2020-01-11 20:15:05 +00:00
instance Pretty NoToolRequirements where
pPrint NoToolRequirements =
2021-08-25 16:54:58 +00:00
text "The Tool requirements could not be found."
2020-04-25 10:06:41 +00:00
data InvalidBuildConfig = InvalidBuildConfig Text
deriving Show
instance Pretty InvalidBuildConfig where
pPrint (InvalidBuildConfig reason) =
2021-08-25 16:54:58 +00:00
text "The build config is invalid. Reason was:" <+> pPrint reason
2021-02-25 17:21:25 +00:00
data NoToolVersionSet = NoToolVersionSet Tool
deriving Show
2020-04-25 10:06:41 +00:00
instance Pretty NoToolVersionSet where
pPrint (NoToolVersionSet tool) =
2021-08-25 16:54:58 +00:00
text "No version is set for tool" <+> pPrint tool <+> text "."
2021-07-18 21:29:09 +00:00
data NoNetwork = NoNetwork
deriving Show
instance Pretty NoNetwork where
pPrint NoNetwork =
2021-08-25 16:54:58 +00:00
text "A download was required or requested, but '--offline' was specified."
2021-07-18 21:29:09 +00:00
data HadrianNotFound = HadrianNotFound
deriving Show
instance Pretty HadrianNotFound where
pPrint HadrianNotFound =
2021-08-25 16:54:58 +00:00
text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
2022-05-23 14:48:29 +00:00
data ToolShadowed = ToolShadowed
Tool
FilePath -- shadow binary
FilePath -- upgraded binary
Version -- upgraded version
deriving Show
2022-05-23 14:48:29 +00:00
instance Pretty ToolShadowed where
pPrint (ToolShadowed tool sh up _) =
text (prettyShow tool
<> " is shadowed by "
<> sh
2022-05-23 14:48:29 +00:00
<> ".\nThe upgrade will not be in effect, unless you remove "
<> sh
2022-05-23 14:48:29 +00:00
<> "\nor make sure "
<> takeDirectory up
<> " comes before "
<> takeDirectory sh
<> " in PATH."
)
2020-01-11 20:15:05 +00:00
-------------------------
--[ High-level errors ]--
-------------------------
-- | A download failed. The underlying error is encapsulated.
2021-09-06 20:31:07 +00:00
data DownloadFailed = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)
instance Pretty DownloadFailed where
pPrint (DownloadFailed reason) =
2021-09-06 20:31:07 +00:00
case reason of
VMaybe (_ :: DownloadFailed) -> pPrint reason
_ -> text "Download failed:" <+> pPrint reason
2020-01-11 20:15:05 +00:00
deriving instance Show DownloadFailed
2022-05-23 21:32:58 +00:00
data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), Show (V xs2), Pretty (V xs2)) => InstallSetError (V xs1) (V xs2)
instance Pretty InstallSetError where
pPrint (InstallSetError reason1 reason2) =
text "Both installation and setting the tool failed. Install error was:"
<+> pPrint reason1
<+> text "\nSet error was:"
<+> pPrint reason2
deriving instance Show InstallSetError
2020-01-11 20:15:05 +00:00
-- | A build failed.
2021-09-06 20:31:07 +00:00
data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)
2020-01-11 20:15:05 +00:00
instance Pretty BuildFailed where
pPrint (BuildFailed path reason) =
2021-09-06 20:31:07 +00:00
case reason of
VMaybe (_ :: BuildFailed) -> pPrint reason
_ -> text "BuildFailed failed in dir" <+> text (path <> ":") <+> pPrint reason
2020-01-11 20:15:05 +00:00
deriving instance Show BuildFailed
-- | Setting the current GHC version failed.
2021-09-06 20:31:07 +00:00
data GHCupSetError = forall es . (ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es, Show (V es), Pretty (V es)) => GHCupSetError (V es)
2020-01-11 20:15:05 +00:00
instance Pretty GHCupSetError where
pPrint (GHCupSetError reason) =
2021-09-06 20:31:07 +00:00
case reason of
VMaybe (_ :: GHCupSetError) -> pPrint reason
_ -> text "Setting the current GHC version failed:" <+> pPrint reason
2020-01-11 20:15:05 +00:00
deriving instance Show GHCupSetError
---------------------------------------------
--[ True Exceptions (e.g. for MonadThrow) ]--
---------------------------------------------
-- | Parsing failed.
data ParseError = ParseError String
deriving Show
instance Pretty ParseError where
pPrint (ParseError reason) =
2021-08-25 16:54:58 +00:00
text "Parsing failed:" <+> pPrint reason
2020-01-11 20:15:05 +00:00
instance Exception ParseError
data UnexpectedListLength = UnexpectedListLength String
deriving Show
instance Pretty UnexpectedListLength where
pPrint (UnexpectedListLength reason) =
2021-08-25 16:54:58 +00:00
text "List length unexpected:" <+> pPrint reason
instance Exception UnexpectedListLength
data NoUrlBase = NoUrlBase Text
deriving Show
instance Pretty NoUrlBase where
pPrint (NoUrlBase url) =
2021-08-25 16:54:58 +00:00
text "Couldn't get a base filename from url" <+> pPrint url
instance Exception NoUrlBase
------------------------
--[ 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) =
2021-08-25 16:54:58 +00:00
text "Failed to parse URI. Malformed scheme:" <+> text (show reason)
pPrint MalformedUserInfo =
2021-08-25 16:54:58 +00:00
text "Failed to parse URI. Malformed user info."
pPrint MalformedQuery =
2021-08-25 16:54:58 +00:00
text "Failed to parse URI. Malformed query."
pPrint MalformedFragment =
2021-08-25 16:54:58 +00:00
text "Failed to parse URI. Malformed fragment."
pPrint MalformedHost =
2021-08-25 16:54:58 +00:00
text "Failed to parse URI. Malformed host."
pPrint MalformedPort =
2021-08-25 16:54:58 +00:00
text "Failed to parse URI. Malformed port."
pPrint MalformedPath =
2021-08-25 16:54:58 +00:00
text "Failed to parse URI. Malformed path."
pPrint (OtherError err) =
2021-08-25 16:54:58 +00:00
text "Failed to parse URI:" <+> pPrint err
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"
2021-08-25 16:54:58 +00:00
instance Pretty T.Text where
pPrint = text . T.unpack