Merge pull request commercialhaskell#5957 from commercialhaskell/fix5956

Fix commercialhaskell#5956 Use `displayException`, not `show`

Author: mpilgrem

src/Control/Concurrent/Execute.hs

@@ -22,15 +22,13 @@ import qualified Data.Set                 as Set
 -- "Control.Concurrent.Execute" module.
 data ExecuteException
     = InconsistentDependenciesBug
-    deriving Typeable
+    deriving (Show, Typeable)
 
-instance Show ExecuteException where
-    show InconsistentDependenciesBug = bugReport "[S-2816]"
+instance Exception ExecuteException where
+    displayException InconsistentDependenciesBug = bugReport "[S-2816]"
         "Inconsistent dependencies were discovered while executing your build \
         \plan."
 
-instance Exception ExecuteException
-
 data ActionType
     = ATBuild
       -- ^ Action for building a package's library and executables. If

src/Options/Applicative/Builder/Extra.hs

@@ -50,17 +50,15 @@ import System.FilePath (takeBaseName, (</>), splitFileName, isRelative, takeExte
 -- "Options.Applicative.Builder.Extra" module.
 data OptionsApplicativeExtraException
   = FlagNotFoundBug
-  deriving Typeable
+  deriving (Show, Typeable)
 
-instance Show OptionsApplicativeExtraException where
-  show FlagNotFoundBug =
+instance Exception OptionsApplicativeExtraException where
+  displayException FlagNotFoundBug =
     "Error: [S-2797]\n"
     ++ "The impossible happened! No valid flags found in \
        \enableDisableFlagsNoDefault. Please report this bug at Stack's \
        \repository."
 
-instance Exception OptionsApplicativeExtraException
-
 -- | Enable/disable flags for a 'Bool'.
 boolFlags :: Bool                 -- ^ Default value
           -> String               -- ^ Flag name

src/Stack/Build.hs

@@ -54,17 +54,17 @@ import           System.Terminal (fixCodePage)
 data CabalVersionException
     = AllowNewerNotSupported Version
     | CabalVersionNotSupported Version
-    deriving (Typeable)
+    deriving (Show, Typeable)
 
-instance Show CabalVersionException where
-    show (AllowNewerNotSupported cabalVer) = concat
+instance Exception CabalVersionException where
+    displayException (AllowNewerNotSupported cabalVer) = concat
         [ "Error: [S-8503]\n"
         , "'--allow-newer' requires Cabal version 1.22 or greater, but "
         , "version "
         , versionString cabalVer
         , " was found."
         ]
-    show (CabalVersionNotSupported cabalVer) = concat
+    displayException (CabalVersionNotSupported cabalVer) = concat
         [ "Error: [S-5973]\n"
         , "Stack no longer supports Cabal versions before 1.19.2, "
         , "but version "
@@ -73,25 +73,23 @@ instance Show CabalVersionException where
         , "or later or to nightly-2015-05-05 or later."
         ]
 
-instance Exception CabalVersionException
-
 data QueryException
     = SelectorNotFound [Text]
     | IndexOutOfRange [Text]
     | NoNumericSelector [Text]
     | CannotApplySelector Value [Text]
-    deriving (Typeable)
-
-instance Show QueryException where
-    show (SelectorNotFound sels) = err "[S-4419]" "Selector not found" sels
-    show (IndexOutOfRange sels) = err "[S-8422]" "Index out of range" sels
-    show (NoNumericSelector sels) =
+    deriving (Show, Typeable)
+
+instance Exception QueryException where
+    displayException (SelectorNotFound sels) =
+        err "[S-4419]" "Selector not found" sels
+    displayException (IndexOutOfRange sels) =
+        err "[S-8422]" "Index out of range" sels
+    displayException (NoNumericSelector sels) =
         err "[S-4360]" "Encountered array and needed numeric selector" sels
-    show (CannotApplySelector value sels) =
+    displayException (CannotApplySelector value sels) =
         err "[S-1711]" ("Cannot apply selector to " ++ show value) sels
 
-instance Exception QueryException
-
 -- | Helper function for 'QueryException' instance of 'Show'
 err :: String -> String -> [Text] -> String
 err msg code sels = "Error: " ++ code ++ "\n" ++ msg ++ ": " ++ show sels

src/Stack/Build/ConstructPlan.hs

@@ -272,10 +272,12 @@ errorOnSnapshot plan@(Plan tasks _finals _unregister installExes) = do
     NotOnlyLocal snapTasks snapExes
   pure plan
 
-data NotOnlyLocal = NotOnlyLocal [PackageName] [Text]
+data NotOnlyLocal
+    = NotOnlyLocal [PackageName] [Text]
+    deriving (Show, Typeable)
 
-instance Show NotOnlyLocal where
-  show (NotOnlyLocal packages exes) = concat
+instance Exception NotOnlyLocal where
+  displayException (NotOnlyLocal packages exes) = concat
     [ "Error: [S-1727]\n"
     , "Specified only-locals, but I need to build snapshot contents:\n"
     , if null packages then "" else concat
@@ -289,7 +291,6 @@ instance Show NotOnlyLocal where
         , "\n"
         ]
     ]
-instance Exception NotOnlyLocal
 
 -- | State to be maintained during the calculation of local packages
 -- to unregister.

src/Stack/Build/Execute.hs

@@ -1717,7 +1717,9 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap
             eres <- try $ cabal KeepTHLoading ["copy"]
             case eres of
                 Left err@CabalExitedUnsuccessfully{} ->
-                    throwM $ CabalCopyFailed (packageBuildType package == C.Simple) (show err)
+                    throwM $ CabalCopyFailed
+                               (packageBuildType package == C.Simple)
+                               (displayException err)
                 _ -> pure ()
             when hasLibrary $ cabal KeepTHLoading ["register"]
 

src/Stack/BuildPlan.hs

@@ -56,17 +56,17 @@ data BuildPlanException
     | SnapshotNotFound SnapName
     | NeitherCompilerOrResolverSpecified T.Text
     | DuplicatePackagesBug
-    deriving Typeable
+    deriving (Show, Typeable)
 
-instance Show BuildPlanException where
-    show (SnapshotNotFound snapName) = unlines
+instance Exception BuildPlanException where
+    displayException (SnapshotNotFound snapName) = unlines
         [ "Error: [S-2045]"
         , "SnapshotNotFound " ++ snapName'
         , "Non existing resolver: " ++ snapName' ++ "."
         , "For a complete list of available snapshots see https://www.stackage.org/snapshots"
         ]
-        where snapName' = show snapName
-    show (UnknownPackages stackYaml unknown shadowed) =
+      where snapName' = show snapName
+    displayException (UnknownPackages stackYaml unknown shadowed) =
         "Error: [S-7571]\n"
         ++ unlines (unknown' ++ shadowed')
       where
@@ -134,17 +134,15 @@ instance Show BuildPlanException where
                       $ Set.toList
                       $ Set.unions
                       $ Map.elems shadowed
-    show (NeitherCompilerOrResolverSpecified url) = concat
+    displayException (NeitherCompilerOrResolverSpecified url) = concat
         [ "Error: [S-8559]\n"
         , "Failed to load custom snapshot at "
         , T.unpack url
         , ", because no 'compiler' or 'resolver' is specified."
         ]
-    show DuplicatePackagesBug = bugReport "[S-5743]"
+    displayException DuplicatePackagesBug = bugReport "[S-5743]"
         "Duplicate packages are not expected here."
 
-instance Exception BuildPlanException
-
 gpdPackages :: [GenericPackageDescription] -> Map PackageName Version
 gpdPackages = Map.fromList . map (toPair . C.package . C.packageDescription)
     where

src/Stack/Clean.hs

@@ -25,24 +25,23 @@ import           Stack.Types.SourceMap
 data CleanException
     = NonLocalPackages [PackageName]
     | DeletionFailures [(Path Abs Dir, SomeException)]
-    deriving Typeable
+    deriving (Show, Typeable)
 
-instance Show CleanException where
-    show (NonLocalPackages pkgs) = concat
+instance Exception CleanException where
+    displayException (NonLocalPackages pkgs) = concat
         [ "Error: [S-9463]\n"
         , "The following packages are not part of this project: "
         , intercalate ", " (map show pkgs)
         ]
-    show (DeletionFailures failures) = concat
+    displayException (DeletionFailures failures) = concat
         [ "Error: [S-6321]\n"
         , "Exception while recursively deleting:\n"
-        , concatMap (\(dir, e) -> toFilePath dir <> "\n" <> show e <> "\n") failures
+        , concatMap (\(dir, e) ->
+            toFilePath dir <> "\n" <> displayException e <> "\n") failures
         , "Perhaps you do not have permission to delete these files or they \
           \are in use?"
         ]
 
-instance Exception CleanException
-
 -- | Deletes build artifacts in the current project.
 clean :: CleanOpts -> RIO Config ()
 clean cleanOpts = do

src/Stack/ComponentFile.hs

@@ -266,7 +266,9 @@ parseHI
 parseHI hiPath = do
   dir <- asks (parent . ctxFile)
   result <-
-    liftIO $ Iface.fromFile hiPath `catchAnyDeep` \e -> pure (Left (show e))
+    liftIO $ catchAnyDeep
+      (Iface.fromFile hiPath)
+      (\e -> pure (Left (displayException e)))
   case result of
     Left msg -> do
       prettyStackDevL

src/Stack/Config/Docker.hs

@@ -20,11 +20,10 @@ import           Stack.Types.Resolver
 data ConfigDockerException
     = ResolverNotSupportedException !(Maybe Project) !(Maybe AbstractResolver)
     -- ^ Only LTS resolvers are supported for default image tag.
-    deriving Typeable
+    deriving (Show, Typeable)
 
--- | Show instance for StackDockerConfigException.
-instance Show ConfigDockerException where
-    show (ResolverNotSupportedException mproject maresolver) =
+instance Exception ConfigDockerException where
+    displayException (ResolverNotSupportedException mproject maresolver) =
         concat
             [ "Error: [S-8575]\n"
             , "Resolver not supported for Docker images:\n    "
@@ -36,8 +35,6 @@ instance Show ConfigDockerException where
             , T.unpack dockerImageArgName
             , "' explicitly, in your configuration file."]
 
-instance Exception ConfigDockerException
-
 -- | Add a default Docker tag name to a given base image.
 addDefaultTag
   :: MonadThrow m

src/Stack/Config/Nix.hs

@@ -27,22 +27,20 @@ data ConfigNixException
     -- ^ Nix can't be given packages and a shell file at the same time
   | GHCMajorVersionUnspecified
   | OnlyGHCSupported
-  deriving Typeable
+  deriving (Show, Typeable)
 
-instance Show ConfigNixException where
-  show NixCannotUseShellFileAndPackagesException =
+instance Exception ConfigNixException where
+  displayException NixCannotUseShellFileAndPackagesException =
     "Error: [S-2726]\n"
     ++ "You cannot have packages and a shell-file filled at the same time \
        \in your nix-shell configuration."
-  show GHCMajorVersionUnspecified =
+  displayException GHCMajorVersionUnspecified =
     "Error: [S-9317]\n"
     ++ "GHC major version not specified."
-  show OnlyGHCSupported =
+  displayException OnlyGHCSupported =
     "Error: [S-8605]\n"
     ++ "Only GHC is supported by 'stack --nix'."
 
-instance Exception ConfigNixException
-
 -- | Interprets NixOptsMonoid options.
 nixOptsFromMonoid
     :: HasRunner env