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

Integrate with errors.haskell.org

Browse Source 
Fixes #434
This commit is contained in:
Julian Ospald
2022-12-20 00:10:19 +08:00
parent 109187eb6f
commit 009f9211a9
27 changed files with 570 additions and 211 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
app/ghcup/GHCup/OptParse.hs
View File

@@ -108,6 +108,7 @@ data Command
| Prefetch PrefetchCommand
| GC GCOptions
| Run RunOptions
| PrintAppErrors
@@ -341,3 +342,10 @@ com =
<> commandGroup "Nuclear Commands:"
<> hidden
)
<|> subparser
(command
"print-app-errors"
(info (pure PrintAppErrors <**> helper)
(progDesc ""))
<> internal
)

3
app/ghcup/GHCup/OptParse/ChangeLog.hs
View File

@@ -12,6 +12,7 @@ module GHCup.OptParse.ChangeLog where
import GHCup.Types
import GHCup.Errors
import GHCup.OptParse.Common
import GHCup.Prelude
import GHCup.Prelude.Logger
@@ -148,6 +149,6 @@ changelog ChangeLogOptions{..} runAppState runLogger = do
Nothing
>>= \case
Right _ -> pure ExitSuccess
Left e -> logError (T.pack $ prettyShow e)
Left e -> logError (T.pack $ prettyHFError e)
>> pure (ExitFailure 13)
else liftIO $ putStrLn uri' >> pure ExitSuccess

13
app/ghcup/GHCup/OptParse/Compile.hs
View File

@@ -40,7 +40,6 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T
@@ -546,14 +545,14 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger $ logError $ T.pack $ prettyHFError err
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 9
(CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
runLogger $ logError "Hadrian cross compile support is not yet implemented!"
@@ -608,12 +607,12 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger $ logError $ T.pack $ prettyHFError err
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 9

2
app/ghcup/GHCup/OptParse/DInfo.hs
View File

@@ -115,5 +115,5 @@ dinfo runAppState runLogger = do
liftIO $ putStrLn $ prettyDebugInfo di
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 8

3
app/ghcup/GHCup/OptParse/GC.hs
View File

@@ -27,7 +27,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -139,5 +138,5 @@ gc GCOptions{..} runAppState runLogger = runGC runAppState (do
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 27

33
app/ghcup/GHCup/OptParse/Install.hs
View File

@@ -38,7 +38,6 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T
@@ -351,10 +350,10 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (DirNotEmpty fp)) -> do
@@ -368,22 +367,22 @@ install installCommand settings getAppState' runLogger = case installCommand of
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger (logError $ T.pack $ prettyHFError err)
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger (logError $ T.pack $ prettyHFError err)
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 3
@@ -418,14 +417,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logInfo msg
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
@@ -433,7 +432,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 4
@@ -468,14 +467,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logInfo msg
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
@@ -483,7 +482,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 4
@@ -517,14 +516,14 @@ install installCommand settings getAppState' runLogger = case installCommand of
runLogger $ logInfo msg
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyShow e
runLogger $ logWarn $ T.pack $ prettyHFError e
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
@@ -532,6 +531,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 4

3
app/ghcup/GHCup/OptParse/Nuke.hs
View File

@@ -26,7 +26,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -95,5 +94,5 @@ nuke appState runLogger = do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15

3
app/ghcup/GHCup/OptParse/Prefetch.hs
View File

@@ -30,7 +30,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -216,5 +215,5 @@ prefetch prefetchCommand runAppState runLogger =
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15

9
app/ghcup/GHCup/OptParse/Rm.hs
View File

@@ -34,7 +34,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -179,7 +178,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
postRmLog vi
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 7
rmCabal' tv =
@@ -194,7 +193,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
postRmLog vi
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15
rmHLS' tv =
@@ -209,7 +208,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
postRmLog vi
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15
rmStack' tv =
@@ -224,7 +223,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
postRmLog vi
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 15
postRmLog vi =

5
app/ghcup/GHCup/OptParse/Run.hs
View File

@@ -40,7 +40,6 @@ import Prelude hiding ( appendFile )
import System.FilePath
import System.Environment
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
@@ -266,11 +265,11 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
case r' of
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 28
#endif
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 27
where

9
app/ghcup/GHCup/OptParse/Set.hs
View File

@@ -35,7 +35,6 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Data.Bifunctor (second)
@@ -286,7 +285,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
"GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 5
@@ -307,7 +306,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
"Cabal " <> prettyVer (_tvVersion v) <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 14
setHLS' :: SetOptions
@@ -327,7 +326,7 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
"HLS " <> prettyVer (_tvVersion v) <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 14
@@ -348,5 +347,5 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
"Stack " <> prettyVer (_tvVersion v) <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 14

3
app/ghcup/GHCup/OptParse/ToolRequirements.hs
View File

@@ -23,7 +23,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import qualified Data.Text.IO as T
@@ -118,5 +117,5 @@ toolRequirements ToolReqOpts{..} runAppState runLogger = runToolRequirements run
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 12

3
app/ghcup/GHCup/OptParse/UnSet.hs
View File

@@ -31,7 +31,6 @@ import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -189,7 +188,7 @@ unset unsetCommand runLeanAppState runLogger = case unsetCommand of
runLogger $ logInfo "GHC successfully unset"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 14
(UnsetCabal (UnsetOptions _)) -> do
void $ runLeanAppState (VRight <$> unsetCabal)

3
app/ghcup/GHCup/OptParse/Upgrade.hs
View File

@@ -28,7 +28,6 @@ import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -152,5 +151,5 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
runLogger $ logWarn "No GHCup update available"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 11

7
app/ghcup/GHCup/OptParse/Whereis.hs
View File

@@ -34,7 +34,6 @@ import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Environment
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
@@ -288,7 +287,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 30
(WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
runLeanWhereIs leanAppstate (do
@@ -302,7 +301,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 30
(WhereisTool tool whereVer, WhereisOptions{..}) -> do
@@ -318,7 +317,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
liftIO $ putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyHFError e
pure $ ExitFailure 30
(WhereisBaseDir, _) -> do