Remove string-interpolate wrt #212
This commit is contained in:
parent
a2555cecc5
commit
14fc6b7281
GPG Key ID:
3786C5262ECB4A3F
@ -5,6 +5,7 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Validate where
|
module Validate where
|
||||||
|
|
||||||
@ -33,7 +34,6 @@ import Control.Monad.Trans.Resource ( runResourceT
|
|||||||
import Data.Containers.ListUtils ( nubOrd )
|
import Data.Containers.ListUtils ( nubOrd )
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.String.Interpolate
|
|
||||||
import Data.Versions
|
import Data.Versions
|
||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Optics
|
import Optics
|
||||||
@ -89,24 +89,23 @@ validate dls _ = do
|
|||||||
if e > 0
|
if e > 0
|
||||||
then pure $ ExitFailure e
|
then pure $ ExitFailure e
|
||||||
else do
|
else do
|
||||||
lift $ $(logInfo) [i|All good|]
|
lift $ $(logInfo) "All good"
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
where
|
where
|
||||||
checkHasRequiredPlatforms t v tags arch pspecs = do
|
checkHasRequiredPlatforms t v tags arch pspecs = do
|
||||||
let v' = prettyVer v
|
let v' = prettyVer v
|
||||||
arch' = prettyShow arch
|
arch' = prettyShow arch
|
||||||
when (notElem (Linux UnknownLinux) pspecs) $ do
|
when (notElem (Linux UnknownLinux) pspecs) $ do
|
||||||
lift $ $(logError)
|
lift $ $(logError) $
|
||||||
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch'}|]
|
"Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
|
||||||
addError
|
addError
|
||||||
when ((notElem Darwin pspecs) && arch == A_64) $ do
|
when ((notElem Darwin pspecs) && arch == A_64) $ do
|
||||||
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch'}|]
|
lift $ $(logError) $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
|
||||||
addError
|
addError
|
||||||
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn)
|
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn) $
|
||||||
[i|FreeBSD missing for #{t} #{v'} #{arch'}|]
|
"FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
|
||||||
when (notElem Windows pspecs && arch == A_64) $ do
|
when (notElem Windows pspecs && arch == A_64) $ do
|
||||||
lift $ $(logError)
|
lift $ $(logError) $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
|
||||||
[i|Windows missing for for #{t} #{v'} #{arch'}|]
|
|
||||||
addError
|
addError
|
||||||
|
|
||||||
-- alpine needs to be set explicitly, because
|
-- alpine needs to be set explicitly, because
|
||||||
@ -114,12 +113,12 @@ validate dls _ = do
|
|||||||
-- (although it could be static)
|
-- (although it could be static)
|
||||||
when (notElem (Linux Alpine) pspecs) $
|
when (notElem (Linux Alpine) pspecs) $
|
||||||
case t of
|
case t of
|
||||||
GHCup | arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]) >> addError
|
GHCup | arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
|
||||||
Cabal | v > [vver|2.4.1.0|]
|
Cabal | v > [vver|2.4.1.0|]
|
||||||
, arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]) >> addError
|
, arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
|
||||||
GHC | Latest `elem` tags || Recommended `elem` tags
|
GHC | Latest `elem` tags || Recommended `elem` tags
|
||||||
, arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|])
|
, arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))
|
||||||
_ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]
|
_ -> lift $ $(logWarn) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
|
||||||
|
|
||||||
checkUniqueTags tool = do
|
checkUniqueTags tool = do
|
||||||
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
|
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
|
||||||
@ -139,7 +138,7 @@ validate dls _ = do
|
|||||||
case join nonUnique of
|
case join nonUnique of
|
||||||
[] -> pure ()
|
[] -> pure ()
|
||||||
xs -> do
|
xs -> do
|
||||||
lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|]
|
lift $ $(logError) $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
|
||||||
addError
|
addError
|
||||||
where
|
where
|
||||||
isUniqueTag Latest = True
|
isUniqueTag Latest = True
|
||||||
@ -155,7 +154,7 @@ validate dls _ = do
|
|||||||
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
|
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
|
||||||
[_] -> pure ()
|
[_] -> pure ()
|
||||||
_ -> do
|
_ -> do
|
||||||
lift $ $(logError) [i|GHC version #{v} is not valid |]
|
lift $ $(logError) $ "GHC version " <> prettyVer v <> " is not valid"
|
||||||
addError
|
addError
|
||||||
|
|
||||||
-- a tool must have at least one of each mandatory tags
|
-- a tool must have at least one of each mandatory tags
|
||||||
@ -163,7 +162,7 @@ validate dls _ = do
|
|||||||
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
|
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
|
||||||
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
|
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
|
||||||
False -> do
|
False -> do
|
||||||
lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
|
lift $ $(logError) $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
|
||||||
addError
|
addError
|
||||||
True -> pure ()
|
True -> pure ()
|
||||||
|
|
||||||
@ -172,7 +171,7 @@ validate dls _ = do
|
|||||||
let allTags = M.toList $ availableToolVersions dls GHC
|
let allTags = M.toList $ availableToolVersions dls GHC
|
||||||
forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
|
forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
|
||||||
False -> do
|
False -> do
|
||||||
lift $ $(logError) [i|Base tag missing from GHC ver #{ver}|]
|
lift $ $(logError) $ "Base tag missing from GHC ver " <> prettyVer ver
|
||||||
addError
|
addError
|
||||||
True -> pure ()
|
True -> pure ()
|
||||||
|
|
||||||
@ -205,7 +204,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
|||||||
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
|
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
|
||||||
let gdlis = nubOrd $ gt ^.. each
|
let gdlis = nubOrd $ gt ^.. each
|
||||||
let allDls = either (const gdlis) (const dlis) etool
|
let allDls = either (const gdlis) (const dlis) etool
|
||||||
when (null allDls) $ $(logError) [i|no tarballs selected by filter|] *> addError
|
when (null allDls) $ $(logError) "no tarballs selected by filter" *> addError
|
||||||
forM_ allDls downloadAll
|
forM_ allDls downloadAll
|
||||||
|
|
||||||
-- exit
|
-- exit
|
||||||
@ -213,7 +212,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
|||||||
if e > 0
|
if e > 0
|
||||||
then pure $ ExitFailure e
|
then pure $ ExitFailure e
|
||||||
else do
|
else do
|
||||||
lift $ $(logInfo) [i|All good|]
|
lift $ $(logInfo) "All good"
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
|
|
||||||
where
|
where
|
||||||
@ -265,25 +264,25 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
|||||||
case _dlSubdir dli of
|
case _dlSubdir dli of
|
||||||
Just (RealDir prel) -> do
|
Just (RealDir prel) -> do
|
||||||
lift $ $(logInfo)
|
lift $ $(logInfo)
|
||||||
[i|verifying subdir: #{prel}|]
|
$ " verifying subdir: " <> T.pack prel
|
||||||
when (basePath /= prel) $ do
|
when (basePath /= prel) $ do
|
||||||
lift $ $(logError)
|
lift $ $(logError) $
|
||||||
[i|Subdir doesn't match: expected "#{prel}", got "#{basePath}"|]
|
"Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
|
||||||
addError
|
addError
|
||||||
Just (RegexDir regexString) -> do
|
Just (RegexDir regexString) -> do
|
||||||
lift $ $(logInfo)
|
lift $ $(logInfo) $
|
||||||
[i|verifying subdir (regex): #{regexString}|]
|
"verifying subdir (regex): " <> T.pack regexString
|
||||||
let regex = makeRegexOpts
|
let regex = makeRegexOpts
|
||||||
compIgnoreCase
|
compIgnoreCase
|
||||||
execBlank
|
execBlank
|
||||||
regexString
|
regexString
|
||||||
when (not (match regex basePath)) $ do
|
when (not (match regex basePath)) $ do
|
||||||
lift $ $(logError)
|
lift $ $(logError) $
|
||||||
[i|Subdir doesn't match: expected regex "#{regexString}", got "#{basePath}"|]
|
"Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
|
||||||
addError
|
addError
|
||||||
Nothing -> pure ()
|
Nothing -> pure ()
|
||||||
VRight Nothing -> pure ()
|
VRight Nothing -> pure ()
|
||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
lift $ $(logError)
|
lift $ $(logError) $
|
||||||
[i|Could not download (or verify hash) of #{dli}, Error was: #{prettyShow e}|]
|
"Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
|
||||||
addError
|
addError
|
||||||
|
|||||||
@ -38,7 +38,6 @@ import Data.Functor
|
|||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
import Data.String.Interpolate
|
|
||||||
import Data.Vector ( Vector
|
import Data.Vector ( Vector
|
||||||
, (!?)
|
, (!?)
|
||||||
)
|
)
|
||||||
@ -467,8 +466,8 @@ install' _ (_, ListResult {..}) = do
|
|||||||
pure $ Right ()
|
pure $ Right ()
|
||||||
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
|
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
|
||||||
VLeft (V NoUpdate) -> pure $ Right ()
|
VLeft (V NoUpdate) -> pure $ Right ()
|
||||||
VLeft e -> pure $ Left [i|#{prettyShow e}
|
VLeft e -> pure $ Left $ prettyShow e <> "\n"
|
||||||
Also check the logs in ~/.ghcup/logs|]
|
<> "Also check the logs in ~/.ghcup/logs"
|
||||||
|
|
||||||
|
|
||||||
set' :: BrickState -> (Int, ListResult) -> IO (Either String ())
|
set' :: BrickState -> (Int, ListResult) -> IO (Either String ())
|
||||||
@ -530,8 +529,8 @@ changelog' :: (MonadReader AppState m, MonadIO m)
|
|||||||
changelog' _ (_, ListResult {..}) = do
|
changelog' _ (_, ListResult {..}) = do
|
||||||
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
||||||
case getChangeLog dls lTool (Left lVer) of
|
case getChangeLog dls lTool (Left lVer) of
|
||||||
Nothing -> pure $ Left
|
Nothing -> pure $ Left $
|
||||||
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
|
"Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer)
|
||||||
Just uri -> do
|
Just uri -> do
|
||||||
let cmd = case _rPlatform pfreq of
|
let cmd = case _rPlatform pfreq of
|
||||||
Darwin -> "open"
|
Darwin -> "open"
|
||||||
@ -597,7 +596,7 @@ brickMain s l = do
|
|||||||
)
|
)
|
||||||
$> ()
|
$> ()
|
||||||
Left e -> do
|
Left e -> do
|
||||||
runLogger ($(logError) [i|Error building app state: #{show e}|])
|
runLogger ($(logError) $ "Error building app state: " <> T.pack (show e))
|
||||||
exitWith $ ExitFailure 2
|
exitWith $ ExitFailure 2
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -49,7 +49,6 @@ import Data.Functor
|
|||||||
import Data.List ( intercalate, nub, sort, sortBy )
|
import Data.List ( intercalate, nub, sort, sortBy )
|
||||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.String.Interpolate
|
|
||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
import Data.Versions hiding ( str )
|
import Data.Versions hiding ( str )
|
||||||
import Data.Void
|
import Data.Void
|
||||||
@ -1087,7 +1086,7 @@ setVersionArgument criteria tool =
|
|||||||
<|> second SetToolVersion (tVersionEither s')
|
<|> second SetToolVersion (tVersionEither s')
|
||||||
parseSet s' = case fmap toLower s' of
|
parseSet s' = case fmap toLower s' of
|
||||||
"next" -> Right SetNext
|
"next" -> Right SetNext
|
||||||
other -> Left [i|Unknown tag/version #{other}|]
|
other -> Left $ "Unknown tag/version " <> other
|
||||||
|
|
||||||
|
|
||||||
versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
|
versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
|
||||||
@ -1170,8 +1169,8 @@ tagEither s' = case fmap toLower s' of
|
|||||||
"latest" -> Right Latest
|
"latest" -> Right Latest
|
||||||
('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
|
('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
|
||||||
Right x -> Right (Base x)
|
Right x -> Right (Base x)
|
||||||
Left _ -> Left [i|Invalid PVP version for base #{ver'}|]
|
Left _ -> Left $ "Invalid PVP version for base " <> ver'
|
||||||
other -> Left [i|Unknown tag #{other}|]
|
other -> Left $ "Unknown tag " <> other
|
||||||
|
|
||||||
|
|
||||||
tVersionEither :: String -> Either String GHCTargetVersion
|
tVersionEither :: String -> Either String GHCTargetVersion
|
||||||
@ -1466,7 +1465,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
let s' = AppState settings dirs keybindings ghcupInfo pfreq
|
let s' = AppState settings dirs keybindings ghcupInfo pfreq
|
||||||
|
|
||||||
race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupTrash)
|
race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupTrash)
|
||||||
(threadDelay 5000000 >> runLogger ($(logWarn) [i|Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in #{recycleDir} manually|]))
|
(threadDelay 5000000 >> runLogger ($(logWarn) $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
|
||||||
|
|
||||||
case optCommand of
|
case optCommand of
|
||||||
Nuke -> pure ()
|
Nuke -> pure ()
|
||||||
@ -1718,20 +1717,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
runLogger $ $(logInfo) msg
|
runLogger $ $(logInfo) msg
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||||
runLogger $ $(logWarn)
|
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|]
|
"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
|
pure ExitSuccess
|
||||||
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
||||||
case keepDirs settings of
|
case keepDirs settings of
|
||||||
Never -> myLoggerT loggerConfig $ ($(logError) $ T.pack $ prettyShow err)
|
Never -> myLoggerT loggerConfig $ ($(logError) $ T.pack $ prettyShow err)
|
||||||
_ -> myLoggerT loggerConfig $ ($(logError) [i|#{prettyShow err}
|
_ -> myLoggerT loggerConfig $ ($(logError) $ T.pack (prettyShow err) <> "\n" <>
|
||||||
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
|
"Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||||
Make sure to clean up #{tmpdir} afterwards.|])
|
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||||
pure $ ExitFailure 3
|
pure $ ExitFailure 3
|
||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ do
|
runLogger $ do
|
||||||
$(logError) $ T.pack $ prettyShow e
|
$(logError) $ T.pack $ prettyShow e
|
||||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
$(logError) $ "Also check the logs in " <> T.pack logsDir
|
||||||
pure $ ExitFailure 3
|
pure $ ExitFailure 3
|
||||||
|
|
||||||
|
|
||||||
@ -1758,13 +1757,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
runLogger $ $(logInfo) msg
|
runLogger $ $(logInfo) msg
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||||
runLogger $ $(logWarn)
|
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|]
|
"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
|
pure ExitSuccess
|
||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ do
|
runLogger $ do
|
||||||
$(logError) $ T.pack $ prettyShow e
|
$(logError) $ T.pack $ prettyShow e
|
||||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
$(logError) $ "Also check the logs in " <> T.pack logsDir
|
||||||
pure $ ExitFailure 4
|
pure $ ExitFailure 4
|
||||||
|
|
||||||
let installHLS InstallOptions{..} =
|
let installHLS InstallOptions{..} =
|
||||||
@ -1790,13 +1789,17 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
runLogger $ $(logInfo) msg
|
runLogger $ $(logInfo) msg
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||||
runLogger $ $(logWarn)
|
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|]
|
"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
|
pure ExitSuccess
|
||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ do
|
runLogger $ do
|
||||||
$(logError) $ T.pack $ prettyShow e
|
$(logError) $ T.pack $ prettyShow e
|
||||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
$(logError) $ "Also check the logs in " <> T.pack logsDir
|
||||||
pure $ ExitFailure 4
|
pure $ ExitFailure 4
|
||||||
|
|
||||||
let installStack InstallOptions{..} =
|
let installStack InstallOptions{..} =
|
||||||
@ -1822,13 +1825,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
runLogger $ $(logInfo) msg
|
runLogger $ $(logInfo) msg
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||||
runLogger $ $(logWarn)
|
runLogger $ $(logWarn) $
|
||||||
[i|Stack ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm stack #{prettyVer v}' first|]
|
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm stack " <> prettyVer v <> "' first"
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ do
|
runLogger $ do
|
||||||
$(logError) $ T.pack $ prettyShow e
|
$(logError) $ T.pack $ prettyShow e
|
||||||
$(logError) [i|Also check the logs in #{logsDir}|]
|
$(logError) $ "Also check the logs in " <> T.pack logsDir
|
||||||
pure $ ExitFailure 4
|
pure $ ExitFailure 4
|
||||||
|
|
||||||
|
|
||||||
@ -1842,8 +1845,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
>>= \case
|
>>= \case
|
||||||
VRight GHCTargetVersion{..} -> do
|
VRight GHCTargetVersion{..} -> do
|
||||||
runLogger
|
runLogger
|
||||||
$ $(logInfo)
|
$ $(logInfo) $
|
||||||
[i|GHC #{prettyVer _tvVersion} successfully set as default version#{maybe "" (" for cross target " <>) _tvTarget}|]
|
"GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||||
@ -1860,8 +1863,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
>>= \case
|
>>= \case
|
||||||
VRight GHCTargetVersion{..} -> do
|
VRight GHCTargetVersion{..} -> do
|
||||||
runLogger
|
runLogger
|
||||||
$ $(logInfo)
|
$ $(logInfo) $
|
||||||
[i|Cabal #{prettyVer _tvVersion} successfully set as default version|]
|
"Cabal " <> prettyVer _tvVersion <> " successfully set as default version"
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||||
@ -1878,8 +1881,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
>>= \case
|
>>= \case
|
||||||
VRight GHCTargetVersion{..} -> do
|
VRight GHCTargetVersion{..} -> do
|
||||||
runLogger
|
runLogger
|
||||||
$ $(logInfo)
|
$ $(logInfo) $
|
||||||
[i|HLS #{prettyVer _tvVersion} successfully set as default version|]
|
"HLS " <> prettyVer _tvVersion <> " successfully set as default version"
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||||
@ -1896,8 +1899,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
>>= \case
|
>>= \case
|
||||||
VRight GHCTargetVersion{..} -> do
|
VRight GHCTargetVersion{..} -> do
|
||||||
runLogger
|
runLogger
|
||||||
$ $(logInfo)
|
$ $(logInfo) $
|
||||||
[i|Stack #{prettyVer _tvVersion} successfully set as default version|]
|
"Stack " <> prettyVer _tvVersion <> " successfully set as default version"
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||||
@ -1974,18 +1977,18 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
liftIO $ brickMain s' loggerConfig >> pure ExitSuccess
|
liftIO $ brickMain s' loggerConfig >> pure ExitSuccess
|
||||||
#endif
|
#endif
|
||||||
Install (Right iopts) -> do
|
Install (Right iopts) -> do
|
||||||
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
|
runLogger ($(logWarn) "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
|
||||||
installGHC iopts
|
installGHC iopts
|
||||||
Install (Left (InstallGHC iopts)) -> installGHC iopts
|
Install (Left (InstallGHC iopts)) -> installGHC iopts
|
||||||
Install (Left (InstallCabal iopts)) -> installCabal iopts
|
Install (Left (InstallCabal iopts)) -> installCabal iopts
|
||||||
Install (Left (InstallHLS iopts)) -> installHLS iopts
|
Install (Left (InstallHLS iopts)) -> installHLS iopts
|
||||||
Install (Left (InstallStack iopts)) -> installStack iopts
|
Install (Left (InstallStack iopts)) -> installStack iopts
|
||||||
InstallCabalLegacy iopts -> do
|
InstallCabalLegacy iopts -> do
|
||||||
runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
|
runLogger ($(logWarn) "This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.")
|
||||||
installCabal iopts
|
installCabal iopts
|
||||||
|
|
||||||
Set (Right sopts) -> do
|
Set (Right sopts) -> do
|
||||||
runLogger ($(logWarn) [i|This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.|])
|
runLogger ($(logWarn) "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
|
||||||
setGHC' sopts
|
setGHC' sopts
|
||||||
Set (Left (SetGHC sopts)) -> setGHC' sopts
|
Set (Left (SetGHC sopts)) -> setGHC' sopts
|
||||||
Set (Left (SetCabal sopts)) -> setCabal' sopts
|
Set (Left (SetCabal sopts)) -> setCabal' sopts
|
||||||
@ -2000,7 +2003,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
)
|
)
|
||||||
|
|
||||||
Rm (Right rmopts) -> do
|
Rm (Right rmopts) -> do
|
||||||
runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|])
|
runLogger ($(logWarn) "This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.")
|
||||||
rmGHC' rmopts
|
rmGHC' rmopts
|
||||||
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
|
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
|
||||||
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
|
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
|
||||||
@ -2058,15 +2061,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
putStr (T.unpack $ tVerToText tv)
|
putStr (T.unpack $ tVerToText tv)
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||||
runLogger $ $(logWarn)
|
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|]
|
"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
|
pure ExitSuccess
|
||||||
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
||||||
case keepDirs settings of
|
case keepDirs settings of
|
||||||
Never -> myLoggerT loggerConfig $ $(logError) $ T.pack $ prettyShow err
|
Never -> myLoggerT loggerConfig $ $(logError) $ T.pack $ prettyShow err
|
||||||
_ -> myLoggerT loggerConfig $ ($(logError) [i|#{prettyShow err}
|
_ -> myLoggerT loggerConfig $ ($(logError) $ T.pack (prettyShow err) <> "\n" <>
|
||||||
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
|
"Check the logs at " <> T.pack logsDir <> " and the build directory "
|
||||||
Make sure to clean up #{tmpdir} afterwards.|])
|
<> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||||
|
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||||
pure $ ExitFailure 9
|
pure $ ExitFailure 9
|
||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||||
@ -2075,7 +2079,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||||||
Config InitConfig -> do
|
Config InitConfig -> do
|
||||||
path <- getConfigFilePath
|
path <- getConfigFilePath
|
||||||
writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
|
writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
|
||||||
runLogger $ $(logDebug) [i|"config.yaml initialized at #{path}|]
|
runLogger $ $(logDebug) $ "config.yaml initialized at " <> T.pack path
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
|
|
||||||
Config ShowConfig -> do
|
Config ShowConfig -> do
|
||||||
@ -2089,7 +2093,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||||||
pure $ ExitFailure 55
|
pure $ ExitFailure 55
|
||||||
_ -> do
|
_ -> do
|
||||||
r <- runE @'[JSONError] $ do
|
r <- runE @'[JSONError] $ do
|
||||||
settings' <- updateSettings [i|#{k}: #{v}\n|] settings
|
settings' <- updateSettings (UTF8.fromString (k <> ": " <> v <> "\n")) settings
|
||||||
path <- liftIO getConfigFilePath
|
path <- liftIO getConfigFilePath
|
||||||
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
|
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
|
||||||
runLogger $ $(logDebug) $ T.pack $ show settings'
|
runLogger $ $(logDebug) $ T.pack $ show settings'
|
||||||
@ -2098,8 +2102,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||||||
case r of
|
case r of
|
||||||
VRight _ -> pure ExitSuccess
|
VRight _ -> pure ExitSuccess
|
||||||
VLeft (V (JSONDecodeError e)) -> do
|
VLeft (V (JSONDecodeError e)) -> do
|
||||||
runLogger $ $(logError)
|
runLogger $ $(logError) $ "Error decoding config: " <> T.pack e
|
||||||
[i|Error decoding config: #{e}|]
|
|
||||||
pure $ ExitFailure 65
|
pure $ ExitFailure 65
|
||||||
VLeft _ -> pure $ ExitFailure 65
|
VLeft _ -> pure $ ExitFailure 65
|
||||||
|
|
||||||
@ -2148,13 +2151,13 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||||||
VRight (v', dls) -> do
|
VRight (v', dls) -> do
|
||||||
let pretty_v = prettyVer v'
|
let pretty_v = prettyVer v'
|
||||||
let vi = fromJust $ snd <$> getLatest dls GHCup
|
let vi = fromJust $ snd <$> getLatest dls GHCup
|
||||||
runLogger $ $(logInfo)
|
runLogger $ $(logInfo) $
|
||||||
[i|Successfully upgraded GHCup to version #{pretty_v}|]
|
"Successfully upgraded GHCup to version " <> pretty_v
|
||||||
forM_ (_viPostInstall vi) $ \msg ->
|
forM_ (_viPostInstall vi) $ \msg ->
|
||||||
runLogger $ $(logInfo) msg
|
runLogger $ $(logInfo) msg
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
VLeft (V NoUpdate) -> do
|
VLeft (V NoUpdate) -> do
|
||||||
runLogger $ $(logWarn) [i|No GHCup update available|]
|
runLogger $ $(logWarn) "No GHCup update available"
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||||
@ -2192,8 +2195,8 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||||||
case muri of
|
case muri of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
runLogger
|
runLogger
|
||||||
($(logWarn)
|
($(logWarn) $
|
||||||
[i|Could not find ChangeLog for #{tool}, version #{either (T.unpack . prettyVer) show ver'}|]
|
"Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver'
|
||||||
)
|
)
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
Just uri -> do
|
Just uri -> do
|
||||||
@ -2215,7 +2218,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
|||||||
Nothing
|
Nothing
|
||||||
>>= \case
|
>>= \case
|
||||||
Right _ -> pure ExitSuccess
|
Right _ -> pure ExitSuccess
|
||||||
Left e -> runLogger ($(logError) [i|#{e}|])
|
Left e -> runLogger ($(logError) (T.pack $ prettyShow e))
|
||||||
>> pure (ExitFailure 13)
|
>> pure (ExitFailure 13)
|
||||||
else putStrLn uri' >> pure ExitSuccess
|
else putStrLn uri' >> pure ExitSuccess
|
||||||
|
|
||||||
@ -2568,46 +2571,46 @@ checkForUpdates = do
|
|||||||
forM_ (getLatest dls GHCup) $ \(l, _) -> do
|
forM_ (getLatest dls GHCup) $ \(l, _) -> do
|
||||||
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
|
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
|
||||||
when (l > ghc_ver)
|
when (l > ghc_ver)
|
||||||
$ $(logWarn)
|
$ $(logWarn) $
|
||||||
[i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
|
"New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'"
|
||||||
|
|
||||||
forM_ (getLatest dls GHC) $ \(l, _) -> do
|
forM_ (getLatest dls GHC) $ \(l, _) -> do
|
||||||
let mghc_ver = latestInstalled GHC
|
let mghc_ver = latestInstalled GHC
|
||||||
forM mghc_ver $ \ghc_ver ->
|
forM mghc_ver $ \ghc_ver ->
|
||||||
when (l > ghc_ver)
|
when (l > ghc_ver)
|
||||||
$ $(logWarn)
|
$ $(logWarn) $
|
||||||
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
|
"New GHC version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install ghc " <> prettyVer l <> "'"
|
||||||
|
|
||||||
forM_ (getLatest dls Cabal) $ \(l, _) -> do
|
forM_ (getLatest dls Cabal) $ \(l, _) -> do
|
||||||
let mcabal_ver = latestInstalled Cabal
|
let mcabal_ver = latestInstalled Cabal
|
||||||
forM mcabal_ver $ \cabal_ver ->
|
forM mcabal_ver $ \cabal_ver ->
|
||||||
when (l > cabal_ver)
|
when (l > cabal_ver)
|
||||||
$ $(logWarn)
|
$ $(logWarn) $
|
||||||
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
|
"New Cabal version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install cabal " <> prettyVer l <> "'"
|
||||||
|
|
||||||
forM_ (getLatest dls HLS) $ \(l, _) -> do
|
forM_ (getLatest dls HLS) $ \(l, _) -> do
|
||||||
let mhls_ver = latestInstalled HLS
|
let mhls_ver = latestInstalled HLS
|
||||||
forM mhls_ver $ \hls_ver ->
|
forM mhls_ver $ \hls_ver ->
|
||||||
when (l > hls_ver)
|
when (l > hls_ver)
|
||||||
$ $(logWarn)
|
$ $(logWarn) $
|
||||||
[i|New HLS version available: #{prettyVer l}. To upgrade, run 'ghcup install hls #{prettyVer l}'|]
|
"New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'"
|
||||||
|
|
||||||
forM_ (getLatest dls Stack) $ \(l, _) -> do
|
forM_ (getLatest dls Stack) $ \(l, _) -> do
|
||||||
let mstack_ver = latestInstalled Stack
|
let mstack_ver = latestInstalled Stack
|
||||||
forM mstack_ver $ \stack_ver ->
|
forM mstack_ver $ \stack_ver ->
|
||||||
when (l > stack_ver)
|
when (l > stack_ver)
|
||||||
$ $(logWarn)
|
$ $(logWarn) $
|
||||||
[i|New Stack version available: #{prettyVer l}. To upgrade, run 'ghcup install stack #{prettyVer l}'|]
|
"New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'"
|
||||||
|
|
||||||
|
|
||||||
prettyDebugInfo :: DebugInfo -> String
|
prettyDebugInfo :: DebugInfo -> String
|
||||||
prettyDebugInfo DebugInfo {..} = [i|Debug Info
|
prettyDebugInfo DebugInfo {..} = "Debug Info" <> "\n" <>
|
||||||
==========
|
"==========" <> "\n" <>
|
||||||
GHCup base dir: #{diBaseDir}
|
"GHCup base dir: " <> diBaseDir <> "\n" <>
|
||||||
GHCup bin dir: #{diBinDir}
|
"GHCup bin dir: " <> diBinDir <> "\n" <>
|
||||||
GHCup GHC directory: #{diGHCDir}
|
"GHCup GHC directory: " <> diGHCDir <> "\n" <>
|
||||||
GHCup cache directory: #{diCacheDir}
|
"GHCup cache directory: " <> diCacheDir <> "\n" <>
|
||||||
Architecture: #{prettyShow diArch}
|
"Architecture: " <> prettyShow diArch <> "\n" <>
|
||||||
Platform: #{prettyShow diPlatform}
|
"Platform: " <> prettyShow diPlatform <> "\n" <>
|
||||||
Version: #{describe_result}|]
|
"Version: " <> describe_result
|
||||||
|
|
||||||
|
|||||||
@ -123,7 +123,6 @@ library
|
|||||||
, safe-exceptions ^>=0.1
|
, safe-exceptions ^>=0.1
|
||||||
, split ^>=0.2.3.4
|
, split ^>=0.2.3.4
|
||||||
, strict-base ^>=0.4
|
, strict-base ^>=0.4
|
||||||
, string-interpolate >=0.2.0.0 && <0.4
|
|
||||||
, template-haskell >=2.7 && <2.18
|
, template-haskell >=2.7 && <2.18
|
||||||
, temporary ^>=1.3
|
, temporary ^>=1.3
|
||||||
, text ^>=1.2.4.0
|
, text ^>=1.2.4.0
|
||||||
@ -205,7 +204,6 @@ executable ghcup
|
|||||||
, resourcet ^>=1.2.2
|
, resourcet ^>=1.2.2
|
||||||
, safe ^>=0.3.18
|
, safe ^>=0.3.18
|
||||||
, safe-exceptions ^>=0.1
|
, safe-exceptions ^>=0.1
|
||||||
, string-interpolate >=0.2.0.0 && <0.4
|
|
||||||
, template-haskell >=2.7 && <2.18
|
, template-haskell >=2.7 && <2.18
|
||||||
, text ^>=1.2.4.0
|
, text ^>=1.2.4.0
|
||||||
, uri-bytestring ^>=0.3.2.2
|
, uri-bytestring ^>=0.3.2.2
|
||||||
@ -269,7 +267,6 @@ executable ghcup-gen
|
|||||||
, regex-posix ^>=0.96
|
, regex-posix ^>=0.96
|
||||||
, resourcet ^>=1.2.2
|
, resourcet ^>=1.2.2
|
||||||
, safe-exceptions ^>=0.1
|
, safe-exceptions ^>=0.1
|
||||||
, string-interpolate >=0.2.0.0 && <0.4
|
|
||||||
, text ^>=1.2.4.0
|
, text ^>=1.2.4.0
|
||||||
, transformers ^>=0.5
|
, transformers ^>=0.5
|
||||||
, versions >=4.0.1 && <5.1
|
, versions >=4.0.1 && <5.1
|
||||||
|
|||||||
122
lib/GHCup.hs
122
lib/GHCup.hs
@ -61,7 +61,6 @@ import Data.List
|
|||||||
import Data.List.Extra
|
import Data.List.Extra
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.String ( fromString )
|
import Data.String ( fromString )
|
||||||
import Data.String.Interpolate
|
|
||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
import Data.Time.Format.ISO8601
|
import Data.Time.Format.ISO8601
|
||||||
@ -90,6 +89,7 @@ import qualified Data.ByteString as B
|
|||||||
import qualified Data.ByteString.Lazy as BL
|
import qualified Data.ByteString.Lazy as BL
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Text.IO as T
|
||||||
import qualified Data.Text.Encoding as E
|
import qualified Data.Text.Encoding as E
|
||||||
#if defined(IS_WINDOWS)
|
#if defined(IS_WINDOWS)
|
||||||
import qualified System.Win32.File as Win32
|
import qualified System.Win32.File as Win32
|
||||||
@ -202,7 +202,7 @@ installGHCBindist :: ( MonadFail m
|
|||||||
installGHCBindist dlinfo ver isoFilepath = do
|
installGHCBindist dlinfo ver isoFilepath = do
|
||||||
let tver = mkTVer ver
|
let tver = mkTVer ver
|
||||||
|
|
||||||
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
|
lift $ $(logDebug) $ "Requested to install GHC with " <> prettyVer ver
|
||||||
|
|
||||||
case isoFilepath of
|
case isoFilepath of
|
||||||
-- we only care for already installed errors in regular (non-isolated) installs
|
-- we only care for already installed errors in regular (non-isolated) installs
|
||||||
@ -219,7 +219,7 @@ installGHCBindist dlinfo ver isoFilepath = do
|
|||||||
|
|
||||||
case isoFilepath of
|
case isoFilepath of
|
||||||
Just isoDir -> do -- isolated install
|
Just isoDir -> do -- isolated install
|
||||||
lift $ $(logInfo) [i|isolated installing GHC to #{isoDir}|]
|
lift $ $(logInfo) $ "isolated installing GHC to " <> T.pack isoDir
|
||||||
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver
|
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver
|
||||||
Nothing -> do -- regular install
|
Nothing -> do -- regular install
|
||||||
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
|
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
|
||||||
@ -417,7 +417,7 @@ installCabalBindist :: ( MonadMask m
|
|||||||
m
|
m
|
||||||
()
|
()
|
||||||
installCabalBindist dlinfo ver isoFilepath = do
|
installCabalBindist dlinfo ver isoFilepath = do
|
||||||
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
|
lift $ $(logDebug) $ "Requested to install cabal version " <> prettyVer ver
|
||||||
|
|
||||||
PlatformRequest {..} <- lift getPlatformReq
|
PlatformRequest {..} <- lift getPlatformReq
|
||||||
Dirs {..} <- lift getDirs
|
Dirs {..} <- lift getDirs
|
||||||
@ -448,7 +448,7 @@ installCabalBindist dlinfo ver isoFilepath = do
|
|||||||
|
|
||||||
case isoFilepath of
|
case isoFilepath of
|
||||||
Just isoDir -> do -- isolated install
|
Just isoDir -> do -- isolated install
|
||||||
lift $ $(logInfo) [i|isolated installing Cabal to #{isoDir}|]
|
lift $ $(logInfo) $ "isolated installing Cabal to " <> T.pack isoDir
|
||||||
liftE $ installCabalUnpacked workdir isoDir Nothing
|
liftE $ installCabalUnpacked workdir isoDir Nothing
|
||||||
|
|
||||||
Nothing -> do -- regular install
|
Nothing -> do -- regular install
|
||||||
@ -546,7 +546,7 @@ installHLSBindist :: ( MonadMask m
|
|||||||
m
|
m
|
||||||
()
|
()
|
||||||
installHLSBindist dlinfo ver isoFilepath = do
|
installHLSBindist dlinfo ver isoFilepath = do
|
||||||
lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
|
lift $ $(logDebug) $ "Requested to install hls version " <> prettyVer ver
|
||||||
|
|
||||||
PlatformRequest {..} <- lift getPlatformReq
|
PlatformRequest {..} <- lift getPlatformReq
|
||||||
Dirs {..} <- lift getDirs
|
Dirs {..} <- lift getDirs
|
||||||
@ -572,7 +572,7 @@ installHLSBindist dlinfo ver isoFilepath = do
|
|||||||
|
|
||||||
case isoFilepath of
|
case isoFilepath of
|
||||||
Just isoDir -> do
|
Just isoDir -> do
|
||||||
lift $ $(logInfo) [i|isolated installing HLS to #{isoDir}|]
|
lift $ $(logInfo) $ "isolated installing HLS to " <> T.pack isoDir
|
||||||
liftE $ installHLSUnpacked workdir isoDir Nothing
|
liftE $ installHLSUnpacked workdir isoDir Nothing
|
||||||
|
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
@ -722,7 +722,7 @@ installStackBindist :: ( MonadMask m
|
|||||||
m
|
m
|
||||||
()
|
()
|
||||||
installStackBindist dlinfo ver isoFilepath = do
|
installStackBindist dlinfo ver isoFilepath = do
|
||||||
lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
|
lift $ $(logDebug) $ "Requested to install stack version " <> prettyVer ver
|
||||||
|
|
||||||
PlatformRequest {..} <- lift getPlatformReq
|
PlatformRequest {..} <- lift getPlatformReq
|
||||||
Dirs {..} <- lift getDirs
|
Dirs {..} <- lift getDirs
|
||||||
@ -747,7 +747,7 @@ installStackBindist dlinfo ver isoFilepath = do
|
|||||||
|
|
||||||
case isoFilepath of
|
case isoFilepath of
|
||||||
Just isoDir -> do -- isolated install
|
Just isoDir -> do -- isolated install
|
||||||
lift $ $(logInfo) [i|isolated installing Stack to #{isoDir}|]
|
lift $ $(logInfo) $ "isolated installing Stack to " <> T.pack isoDir
|
||||||
liftE $ installStackUnpacked workdir isoDir Nothing
|
liftE $ installStackUnpacked workdir isoDir Nothing
|
||||||
Nothing -> do -- regular install
|
Nothing -> do -- regular install
|
||||||
liftE $ installStackUnpacked workdir binDir (Just ver)
|
liftE $ installStackUnpacked workdir binDir (Just ver)
|
||||||
@ -829,7 +829,7 @@ setGHC ver sghc = do
|
|||||||
SetGHCOnly -> pure $ Just file
|
SetGHCOnly -> pure $ Just file
|
||||||
SetGHC_XY -> do
|
SetGHC_XY -> do
|
||||||
handle
|
handle
|
||||||
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
|
(\(e :: ParseError) -> lift $ $(logWarn) (T.pack $ displayException e) >> pure Nothing)
|
||||||
$ do
|
$ do
|
||||||
(mj, mi) <- getMajorMinorV (_tvVersion ver)
|
(mj, mi) <- getMajorMinorV (_tvVersion ver)
|
||||||
let major' = intToText mj <> "." <> intToText mi
|
let major' = intToText mj <> "." <> intToText mi
|
||||||
@ -871,9 +871,9 @@ setGHC ver sghc = do
|
|||||||
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
|
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
|
||||||
let fullF = destdir </> sharedir
|
let fullF = destdir </> sharedir
|
||||||
let targetF = "." </> "ghc" </> ver' </> sharedir
|
let targetF = "." </> "ghc" </> ver' </> sharedir
|
||||||
$(logDebug) [i|rm -f #{fullF}|]
|
$(logDebug) $ "rm -f " <> T.pack fullF
|
||||||
hideError doesNotExistErrorType $ rmDirectoryLink fullF
|
hideError doesNotExistErrorType $ rmDirectoryLink fullF
|
||||||
$(logDebug) [i|ln -s #{targetF} #{fullF}|]
|
$(logDebug) $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF
|
||||||
liftIO
|
liftIO
|
||||||
#if defined(IS_WINDOWS)
|
#if defined(IS_WINDOWS)
|
||||||
-- On windows we need to be more permissive
|
-- On windows we need to be more permissive
|
||||||
@ -939,7 +939,7 @@ setHLS ver = do
|
|||||||
-- selected version, so we could end up with stray or incorrect symlinks.
|
-- selected version, so we could end up with stray or incorrect symlinks.
|
||||||
oldSyms <- lift hlsSymlinks
|
oldSyms <- lift hlsSymlinks
|
||||||
forM_ oldSyms $ \f -> do
|
forM_ oldSyms $ \f -> do
|
||||||
lift $ $(logDebug) [i|rm #{binDir </> f}|]
|
lift $ $(logDebug) $ "rm " <> T.pack (binDir </> f)
|
||||||
lift $ rmLink (binDir </> f)
|
lift $ rmLink (binDir </> f)
|
||||||
|
|
||||||
-- set haskell-language-server-<ghcver> symlinks
|
-- set haskell-language-server-<ghcver> symlinks
|
||||||
@ -1126,7 +1126,7 @@ listVersions lt' criteria = do
|
|||||||
}
|
}
|
||||||
Left e -> do
|
Left e -> do
|
||||||
$(logWarn)
|
$(logWarn)
|
||||||
[i|Could not parse version of stray directory #{e}|]
|
$ "Could not parse version of stray directory" <> T.pack e
|
||||||
pure Nothing
|
pure Nothing
|
||||||
|
|
||||||
strayCabals :: ( MonadReader env m
|
strayCabals :: ( MonadReader env m
|
||||||
@ -1161,7 +1161,7 @@ listVersions lt' criteria = do
|
|||||||
}
|
}
|
||||||
Left e -> do
|
Left e -> do
|
||||||
$(logWarn)
|
$(logWarn)
|
||||||
[i|Could not parse version of stray directory #{e}|]
|
$ "Could not parse version of stray directory" <> T.pack e
|
||||||
pure Nothing
|
pure Nothing
|
||||||
|
|
||||||
strayHLS :: ( MonadReader env m
|
strayHLS :: ( MonadReader env m
|
||||||
@ -1195,7 +1195,7 @@ listVersions lt' criteria = do
|
|||||||
}
|
}
|
||||||
Left e -> do
|
Left e -> do
|
||||||
$(logWarn)
|
$(logWarn)
|
||||||
[i|Could not parse version of stray directory #{e}|]
|
$ "Could not parse version of stray directory" <> T.pack e
|
||||||
pure Nothing
|
pure Nothing
|
||||||
|
|
||||||
strayStacks :: ( MonadReader env m
|
strayStacks :: ( MonadReader env m
|
||||||
@ -1230,7 +1230,7 @@ listVersions lt' criteria = do
|
|||||||
}
|
}
|
||||||
Left e -> do
|
Left e -> do
|
||||||
$(logWarn)
|
$(logWarn)
|
||||||
[i|Could not parse version of stray directory #{e}|]
|
$ "Could not parse version of stray directory" <> T.pack e
|
||||||
pure Nothing
|
pure Nothing
|
||||||
|
|
||||||
currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult
|
currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult
|
||||||
@ -1373,23 +1373,23 @@ rmGHCVer ver = do
|
|||||||
|
|
||||||
-- this isn't atomic, order matters
|
-- this isn't atomic, order matters
|
||||||
when isSetGHC $ do
|
when isSetGHC $ do
|
||||||
lift $ $(logInfo) [i|Removing ghc symlinks|]
|
lift $ $(logInfo) "Removing ghc symlinks"
|
||||||
liftE $ rmPlain (_tvTarget ver)
|
liftE $ rmPlain (_tvTarget ver)
|
||||||
|
|
||||||
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
|
lift $ $(logInfo) "Removing ghc-x.y.z symlinks"
|
||||||
liftE $ rmMinorSymlinks ver
|
liftE $ rmMinorSymlinks ver
|
||||||
|
|
||||||
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
|
lift $ $(logInfo) "Removing/rewiring ghc-x.y symlinks"
|
||||||
-- first remove
|
-- first remove
|
||||||
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
|
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
|
||||||
-- then fix them (e.g. with an earlier version)
|
-- then fix them (e.g. with an earlier version)
|
||||||
|
|
||||||
lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
|
lift $ $(logInfo) $ "Removing directory recursively: " <> T.pack dir
|
||||||
lift $ recyclePathForcibly dir
|
lift $ recyclePathForcibly dir
|
||||||
|
|
||||||
v' <-
|
v' <-
|
||||||
handle
|
handle
|
||||||
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
|
(\(e :: ParseError) -> lift $ $(logWarn) (T.pack $ displayException e) >> pure Nothing)
|
||||||
$ fmap Just
|
$ fmap Just
|
||||||
$ getMajorMinorV (_tvVersion ver)
|
$ getMajorMinorV (_tvVersion ver)
|
||||||
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
|
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
|
||||||
@ -1460,7 +1460,7 @@ rmHLSVer ver = do
|
|||||||
oldSyms <- lift hlsSymlinks
|
oldSyms <- lift hlsSymlinks
|
||||||
forM_ oldSyms $ \f -> do
|
forM_ oldSyms $ \f -> do
|
||||||
let fullF = binDir </> f
|
let fullF = binDir </> f
|
||||||
lift $ $(logDebug) [i|rm #{fullF}|]
|
lift $ $(logDebug) $ "rm " <> T.pack fullF
|
||||||
lift $ rmLink fullF
|
lift $ rmLink fullF
|
||||||
-- set latest hls
|
-- set latest hls
|
||||||
hlsVers <- lift $ fmap rights getInstalledHLSs
|
hlsVers <- lift $ fmap rights getInstalledHLSs
|
||||||
@ -1603,7 +1603,7 @@ rmGhcupDirs = do
|
|||||||
handleRm $ rmBinDir binDir
|
handleRm $ rmBinDir binDir
|
||||||
handleRm $ rmDir recycleDir
|
handleRm $ rmDir recycleDir
|
||||||
#if defined(IS_WINDOWS)
|
#if defined(IS_WINDOWS)
|
||||||
$logInfo [i|removing #{(baseDir </> "msys64")}|]
|
$logInfo $ "removing " <> T.pack (baseDir </> "msys64")
|
||||||
handleRm $ rmPathForcibly (baseDir </> "msys64")
|
handleRm $ rmPathForcibly (baseDir </> "msys64")
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
@ -1615,8 +1615,8 @@ rmGhcupDirs = do
|
|||||||
|
|
||||||
where
|
where
|
||||||
handleRm :: (MonadCatch m, MonadLogger m) => m () -> m ()
|
handleRm :: (MonadCatch m, MonadLogger m) => m () -> m ()
|
||||||
handleRm = handleIO (\e -> $logDebug [i|Part of the cleanup action failed with error: #{displayException e}
|
handleRm = handleIO (\e -> $logDebug $ "Part of the cleanup action failed with error: " <> T.pack (displayException e) <> "\n"
|
||||||
continuing regardless...|])
|
<> "continuing regardless...")
|
||||||
|
|
||||||
rmEnvFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
rmEnvFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||||
rmEnvFile enFilePath = do
|
rmEnvFile enFilePath = do
|
||||||
@ -1634,7 +1634,7 @@ continuing regardless...|])
|
|||||||
-- an error leaks through, we catch it here as well,
|
-- an error leaks through, we catch it here as well,
|
||||||
-- althought 'deleteFile' should already handle it.
|
-- althought 'deleteFile' should already handle it.
|
||||||
hideErrorDef [doesNotExistErrorType] () $ do
|
hideErrorDef [doesNotExistErrorType] () $ do
|
||||||
$logInfo [i|removing #{dir}|]
|
$logInfo $ "removing " <> T.pack dir
|
||||||
contents <- liftIO $ getDirectoryContentsRecursive dir
|
contents <- liftIO $ getDirectoryContentsRecursive dir
|
||||||
forM_ contents (deleteFile . (dir </>))
|
forM_ contents (deleteFile . (dir </>))
|
||||||
|
|
||||||
@ -1783,7 +1783,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
|
|||||||
(workdir, tmpUnpack, tver) <- case targetGhc of
|
(workdir, tmpUnpack, tver) <- case targetGhc of
|
||||||
-- unpack from version tarball
|
-- unpack from version tarball
|
||||||
Left tver -> do
|
Left tver -> do
|
||||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
|
lift $ $(logDebug) $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap
|
||||||
|
|
||||||
-- download source tarball
|
-- download source tarball
|
||||||
dlInfo <-
|
dlInfo <-
|
||||||
@ -1808,7 +1808,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
|
|||||||
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
|
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
|
||||||
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
|
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
|
||||||
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
|
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
|
||||||
lift $ $(logInfo) [i|Fetching git repo #{rep} at ref #{ref} (this may take a while)|]
|
lift $ $(logInfo) $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
|
||||||
lEM $ git [ "init" ]
|
lEM $ git [ "init" ]
|
||||||
lEM $ git [ "remote"
|
lEM $ git [ "remote"
|
||||||
, "add"
|
, "add"
|
||||||
@ -1835,7 +1835,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
|
|||||||
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
|
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
|
||||||
|
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
||||||
lift $ $(logInfo) [i|Git version #{ref} corresponds to GHC version #{prettyVer tver}|]
|
lift $ $(logInfo) $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver
|
||||||
|
|
||||||
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
|
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
|
||||||
-- the version that's installed may differ from the
|
-- the version that's installed may differ from the
|
||||||
@ -1847,9 +1847,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
|
|||||||
when alreadyInstalled $ do
|
when alreadyInstalled $ do
|
||||||
case isolateDir of
|
case isolateDir of
|
||||||
Just isoDir ->
|
Just isoDir ->
|
||||||
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Isolate installing to #{isoDir} |]
|
lift $ $(logWarn) $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Isolate installing to " <> T.pack isoDir
|
||||||
Nothing ->
|
Nothing ->
|
||||||
lift $ $(logWarn) [i|GHC #{prettyShow tver} already installed. Will overwrite existing version.|]
|
lift $ $(logWarn) $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Will overwrite existing version."
|
||||||
lift $ $(logWarn)
|
lift $ $(logWarn)
|
||||||
"...waiting for 10 seconds before continuing, you can still abort..."
|
"...waiting for 10 seconds before continuing, you can still abort..."
|
||||||
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
|
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
|
||||||
@ -1877,7 +1877,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
|
|||||||
Nothing ->
|
Nothing ->
|
||||||
-- only remove old ghc in regular installs
|
-- only remove old ghc in regular installs
|
||||||
when alreadyInstalled $ do
|
when alreadyInstalled $ do
|
||||||
lift $ $(logInfo) [i|Deleting existing installation|]
|
lift $ $(logInfo) "Deleting existing installation"
|
||||||
liftE $ rmGHCVer tver
|
liftE $ rmGHCVer tver
|
||||||
|
|
||||||
_ -> pure ()
|
_ -> pure ()
|
||||||
@ -1952,11 +1952,11 @@ endif|]
|
|||||||
|
|
||||||
liftE $ configureBindist bghc tver workdir ghcdir
|
liftE $ configureBindist bghc tver workdir ghcdir
|
||||||
|
|
||||||
lift $ $(logInfo) [i|Building (this may take a while)...|]
|
lift $ $(logInfo) "Building (this may take a while)..."
|
||||||
hadrian_build <- liftE $ findHadrianFile workdir
|
hadrian_build <- liftE $ findHadrianFile workdir
|
||||||
lEM $ execLogged hadrian_build
|
lEM $ execLogged hadrian_build
|
||||||
( maybe [] (\j -> [[i|-j#{j}|]] ) jobs
|
( maybe [] (\j -> ["-j" <> show j] ) jobs
|
||||||
++ maybe [] (\bf -> [[i|--flavour=#{bf}|]]) buildFlavour
|
++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour
|
||||||
++ ["binary-dist"]
|
++ ["binary-dist"]
|
||||||
)
|
)
|
||||||
(Just workdir) "ghc-make" Nothing
|
(Just workdir) "ghc-make" Nothing
|
||||||
@ -2018,19 +2018,19 @@ endif|]
|
|||||||
(FileDoesNotExistError bc)
|
(FileDoesNotExistError bc)
|
||||||
(liftIO $ copyFile bc (build_mk workdir))
|
(liftIO $ copyFile bc (build_mk workdir))
|
||||||
Nothing ->
|
Nothing ->
|
||||||
liftIO $ B.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)
|
liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)
|
||||||
|
|
||||||
liftE $ checkBuildConfig (build_mk workdir)
|
liftE $ checkBuildConfig (build_mk workdir)
|
||||||
|
|
||||||
lift $ $(logInfo) [i|Building (this may take a while)...|]
|
lift $ $(logInfo) "Building (this may take a while)..."
|
||||||
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
|
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
|
||||||
|
|
||||||
if | isCross tver -> do
|
if | isCross tver -> do
|
||||||
lift $ $(logInfo) [i|Installing cross toolchain...|]
|
lift $ $(logInfo) "Installing cross toolchain..."
|
||||||
lEM $ make ["install"] (Just workdir)
|
lEM $ make ["install"] (Just workdir)
|
||||||
pure Nothing
|
pure Nothing
|
||||||
| otherwise -> do
|
| otherwise -> do
|
||||||
lift $ $(logInfo) [i|Creating bindist...|]
|
lift $ $(logInfo) "Creating bindist..."
|
||||||
lEM $ make ["binary-dist"] (Just workdir)
|
lEM $ make ["binary-dist"] (Just workdir)
|
||||||
[tar] <- liftIO $ findFiles
|
[tar] <- liftIO $ findFiles
|
||||||
workdir
|
workdir
|
||||||
@ -2071,11 +2071,20 @@ endif|]
|
|||||||
. SHA256.hashlazy
|
. SHA256.hashlazy
|
||||||
$ c
|
$ c
|
||||||
cTime <- liftIO getCurrentTime
|
cTime <- liftIO getCurrentTime
|
||||||
let tarName = makeValid [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|]
|
let tarName = makeValid ("ghc-"
|
||||||
|
<> T.unpack (tVerToText tver)
|
||||||
|
<> "-"
|
||||||
|
<> pfReqToString pfreq
|
||||||
|
<> "-"
|
||||||
|
<> iso8601Show cTime
|
||||||
|
<> "-"
|
||||||
|
<> T.unpack cDigest
|
||||||
|
<> ".tar"
|
||||||
|
<> takeExtension tar)
|
||||||
let tarPath = cacheDir </> tarName
|
let tarPath = cacheDir </> tarName
|
||||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
|
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
|
||||||
tarPath
|
tarPath
|
||||||
lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
|
lift $ $(logInfo) $ "Copied bindist to " <> T.pack tarPath
|
||||||
pure tarPath
|
pure tarPath
|
||||||
|
|
||||||
checkBuildConfig :: (MonadCatch m, MonadIO m, MonadLogger m)
|
checkBuildConfig :: (MonadCatch m, MonadIO m, MonadLogger m)
|
||||||
@ -2100,13 +2109,12 @@ endif|]
|
|||||||
_ -> pure ()
|
_ -> pure ()
|
||||||
|
|
||||||
forM_ buildFlavour $ \bf ->
|
forM_ buildFlavour $ \bf ->
|
||||||
when ([i|BuildFlavour = #{bf}|] `notElem` lines') $ do
|
when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do
|
||||||
lift $ $(logWarn) [i|Customly specified build config overwrites --flavour=#{bf} switch! Waiting 5 seconds...|]
|
lift $ $(logWarn) $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..."
|
||||||
liftIO $ threadDelay 5000000
|
liftIO $ threadDelay 5000000
|
||||||
|
|
||||||
addBuildFlavourToConf bc = case buildFlavour of
|
addBuildFlavourToConf bc = case buildFlavour of
|
||||||
Just bf -> [i|BuildFlavour = #{bf}
|
Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc
|
||||||
|] <> [i|#{bc}|]
|
|
||||||
Nothing -> bc
|
Nothing -> bc
|
||||||
|
|
||||||
isCross :: GHCTargetVersion -> Bool
|
isCross :: GHCTargetVersion -> Bool
|
||||||
@ -2224,7 +2232,7 @@ upgradeGHCup mtarget force' = do
|
|||||||
Dirs {..} <- lift getDirs
|
Dirs {..} <- lift getDirs
|
||||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||||
|
|
||||||
lift $ $(logInfo) [i|Upgrading GHCup...|]
|
lift $ $(logInfo) "Upgrading GHCup..."
|
||||||
let latestVer = fromJust $ fst <$> getLatest dls GHCup
|
let latestVer = fromJust $ fst <$> getLatest dls GHCup
|
||||||
when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
|
when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
|
||||||
dli <- liftE $ getDownloadInfo GHCup latestVer
|
dli <- liftE $ getDownloadInfo GHCup latestVer
|
||||||
@ -2233,20 +2241,28 @@ upgradeGHCup mtarget force' = do
|
|||||||
p <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp (Just fn) False
|
p <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp (Just fn) False
|
||||||
let destDir = takeDirectory destFile
|
let destDir = takeDirectory destFile
|
||||||
destFile = fromMaybe (binDir </> fn) mtarget
|
destFile = fromMaybe (binDir </> fn) mtarget
|
||||||
lift $ $(logDebug) [i|mkdir -p #{destDir}|]
|
lift $ $(logDebug) $ "mkdir -p " <> T.pack destDir
|
||||||
liftIO $ createDirRecursive' destDir
|
liftIO $ createDirRecursive' destDir
|
||||||
lift $ $(logDebug) [i|rm -f #{destFile}|]
|
lift $ $(logDebug) $ "rm -f " <> T.pack destFile
|
||||||
lift $ hideError NoSuchThing $ recycleFile destFile
|
lift $ hideError NoSuchThing $ recycleFile destFile
|
||||||
lift $ $(logDebug) [i|cp #{p} #{destFile}|]
|
lift $ $(logDebug) $ "cp " <> T.pack p <> " " <> T.pack destFile
|
||||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
||||||
destFile
|
destFile
|
||||||
lift $ chmod_755 destFile
|
lift $ chmod_755 destFile
|
||||||
|
|
||||||
liftIO (isInPath destFile) >>= \b -> unless b $
|
liftIO (isInPath destFile) >>= \b -> unless b $
|
||||||
lift $ $(logWarn) [i|"#{takeFileName destFile}" is not in PATH! You have to add it in order to use ghcup.|]
|
lift $ $(logWarn) $ T.pack (takeFileName destFile) <> " is not in PATH! You have to add it in order to use ghcup."
|
||||||
liftIO (isShadowed destFile) >>= \case
|
liftIO (isShadowed destFile) >>= \case
|
||||||
Nothing -> pure ()
|
Nothing -> pure ()
|
||||||
Just pa -> lift $ $(logWarn) [i|ghcup is shadowed by "#{pa}". The upgrade will not be in effect, unless you remove "#{pa}" or make sure "#{destDir}" comes before "#{takeFileName pa}" in PATH.|]
|
Just pa -> lift $ $(logWarn) $ "ghcup is shadowed by "
|
||||||
|
<> T.pack pa
|
||||||
|
<> ". The upgrade will not be in effect, unless you remove "
|
||||||
|
<> T.pack pa
|
||||||
|
<> " or make sure "
|
||||||
|
<> T.pack destDir
|
||||||
|
<> " comes before "
|
||||||
|
<> T.pack (takeFileName pa)
|
||||||
|
<> " in PATH."
|
||||||
|
|
||||||
pure latestVer
|
pure latestVer
|
||||||
|
|
||||||
@ -2278,7 +2294,7 @@ postGHCInstall ver@GHCTargetVersion {..} = do
|
|||||||
-- Create ghc-x.y symlinks. This may not be the current
|
-- Create ghc-x.y symlinks. This may not be the current
|
||||||
-- version, create it regardless.
|
-- version, create it regardless.
|
||||||
v' <-
|
v' <-
|
||||||
handle (\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
|
handle (\(e :: ParseError) -> lift $ $(logWarn) (T.pack $ displayException e) >> pure Nothing)
|
||||||
$ fmap Just
|
$ fmap Just
|
||||||
$ getMajorMinorV _tvVersion
|
$ getMajorMinorV _tvVersion
|
||||||
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget)
|
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget)
|
||||||
|
|||||||
@ -59,7 +59,6 @@ import Data.CaseInsensitive ( mk )
|
|||||||
#endif
|
#endif
|
||||||
import Data.List.Extra
|
import Data.List.Extra
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.String.Interpolate
|
|
||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
import Data.Time.Clock.POSIX
|
import Data.Time.Clock.POSIX
|
||||||
import Data.Versions
|
import Data.Versions
|
||||||
@ -187,13 +186,13 @@ getBase uri = do
|
|||||||
|
|
||||||
-- if we didn't get a filepath from the download, use the cached yaml
|
-- if we didn't get a filepath from the download, use the cached yaml
|
||||||
actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
|
actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
|
||||||
lift $ $(logDebug) [i|Decoding yaml at: #{actualYaml}|]
|
lift $ $(logDebug) $ "Decoding yaml at: " <> T.pack actualYaml
|
||||||
|
|
||||||
liftE
|
liftE
|
||||||
. onE_ (onError actualYaml)
|
. onE_ (onError actualYaml)
|
||||||
. lEM' @_ @_ @'[JSONError] JSONDecodeError
|
. lEM' @_ @_ @'[JSONError] JSONDecodeError
|
||||||
. fmap (first (\e -> [i|#{displayException e}
|
. fmap (first (\e -> unlines [displayException e
|
||||||
Consider removing "#{actualYaml}" manually.|]))
|
,"Consider removing " <> actualYaml <> " manually."]))
|
||||||
. liftIO
|
. liftIO
|
||||||
. Y.decodeFileEither
|
. Y.decodeFileEither
|
||||||
$ actualYaml
|
$ actualYaml
|
||||||
@ -203,12 +202,12 @@ Consider removing "#{actualYaml}" manually.|]))
|
|||||||
onError :: (MonadLogger m, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
|
onError :: (MonadLogger m, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
|
||||||
onError fp = do
|
onError fp = do
|
||||||
let efp = etagsFile fp
|
let efp = etagsFile fp
|
||||||
handleIO (\e -> $(logWarn) [i|Couldn't remove file #{efp}, error was: #{displayException e}|])
|
handleIO (\e -> $(logWarn) $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
|
||||||
(hideError doesNotExistErrorType $ rmFile efp)
|
(hideError doesNotExistErrorType $ rmFile efp)
|
||||||
liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
|
liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
|
||||||
warnCache s = do
|
warnCache s = do
|
||||||
lift $ $(logWarn) [i|Could not get download info, trying cached version (this may not be recent!)|]
|
lift $ $(logWarn) "Could not get download info, trying cached version (this may not be recent!)"
|
||||||
lift $ $(logDebug) [i|Error was: #{s}|]
|
lift $ $(logDebug) $ "Error was: " <> T.pack s
|
||||||
|
|
||||||
-- First check if the json file is in the ~/.ghcup/cache dir
|
-- First check if the json file is in the ~/.ghcup/cache dir
|
||||||
-- and check it's access time. If it has been accessed within the
|
-- and check it's access time. If it has been accessed within the
|
||||||
@ -327,7 +326,7 @@ download uri eDigest dest mfn etags
|
|||||||
| scheme == "http" = dl
|
| scheme == "http" = dl
|
||||||
| scheme == "file" = do
|
| scheme == "file" = do
|
||||||
let destFile' = T.unpack . decUTF8Safe $ path
|
let destFile' = T.unpack . decUTF8Safe $ path
|
||||||
lift $ $(logDebug) [i|using local file: #{destFile'}|]
|
lift $ $(logDebug) $ "using local file: " <> T.pack destFile'
|
||||||
forM_ eDigest (liftE . flip checkDigest destFile')
|
forM_ eDigest (liftE . flip checkDigest destFile')
|
||||||
pure destFile'
|
pure destFile'
|
||||||
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
|
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
|
||||||
@ -336,7 +335,7 @@ download uri eDigest dest mfn etags
|
|||||||
scheme = view (uriSchemeL' % schemeBSL') uri
|
scheme = view (uriSchemeL' % schemeBSL') uri
|
||||||
dl = do
|
dl = do
|
||||||
destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
|
destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
|
||||||
lift $ $(logInfo) [i|downloading: #{uri'} as file #{destFile}|]
|
lift $ $(logInfo) $ "downloading: " <> uri' <> " as file " <> T.pack destFile
|
||||||
|
|
||||||
-- destination dir must exist
|
-- destination dir must exist
|
||||||
liftIO $ createDirRecursive' dest
|
liftIO $ createDirRecursive' dest
|
||||||
@ -362,7 +361,7 @@ download uri eDigest dest mfn etags
|
|||||||
metag <- readETag destFile
|
metag <- readETag destFile
|
||||||
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
|
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
|
||||||
(o' ++ (if etags then ["--dump-header", dh] else [])
|
(o' ++ (if etags then ["--dump-header", dh] else [])
|
||||||
++ maybe [] (\t -> ["-H", [i|If-None-Match: #{t}|]]) metag
|
++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
|
||||||
++ ["-fL", "-o", destFile <.> "tmp", T.unpack uri']) Nothing Nothing
|
++ ["-fL", "-o", destFile <.> "tmp", T.unpack uri']) Nothing Nothing
|
||||||
headers <- liftIO $ T.readFile dh
|
headers <- liftIO $ T.readFile dh
|
||||||
|
|
||||||
@ -371,9 +370,9 @@ download uri eDigest dest mfn etags
|
|||||||
case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of
|
case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of
|
||||||
Just (http':sc:_)
|
Just (http':sc:_)
|
||||||
| sc == "304"
|
| sc == "304"
|
||||||
, T.pack "HTTP" `T.isPrefixOf` http' -> $logDebug [i|Status code was 304, not overwriting|]
|
, T.pack "HTTP" `T.isPrefixOf` http' -> $logDebug "Status code was 304, not overwriting"
|
||||||
| T.pack "HTTP" `T.isPrefixOf` http' -> do
|
| T.pack "HTTP" `T.isPrefixOf` http' -> do
|
||||||
$logDebug [i|Status code was #{sc}, overwriting|]
|
$logDebug $ "Status code was " <> sc <> ", overwriting"
|
||||||
liftIO $ copyFile (destFile <.> "tmp") destFile
|
liftIO $ copyFile (destFile <.> "tmp") destFile
|
||||||
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
|
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
|
||||||
:: V '[MalformedHeaders]))
|
:: V '[MalformedHeaders]))
|
||||||
@ -389,7 +388,7 @@ download uri eDigest dest mfn etags
|
|||||||
if etags
|
if etags
|
||||||
then do
|
then do
|
||||||
metag <- readETag destFile
|
metag <- readETag destFile
|
||||||
let opts = o' ++ maybe [] (\t -> ["--header", [i|If-None-Match: #{t}|]]) metag
|
let opts = o' ++ maybe [] (\t -> ["--header", "If-None-Match: " <> T.unpack t]) metag
|
||||||
++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
|
++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
|
||||||
CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
|
CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
|
||||||
case _exitCode of
|
case _exitCode of
|
||||||
@ -453,7 +452,7 @@ download uri eDigest dest mfn etags
|
|||||||
$logDebug "Couldn't parse etags, no input: "
|
$logDebug "Couldn't parse etags, no input: "
|
||||||
pure Nothing
|
pure Nothing
|
||||||
(Just [_, etag']) -> do
|
(Just [_, etag']) -> do
|
||||||
$logDebug [i|Parsed etag: #{etag'}|]
|
$logDebug $ "Parsed etag: " <> etag'
|
||||||
pure (Just etag')
|
pure (Just etag')
|
||||||
(Just xs) -> do
|
(Just xs) -> do
|
||||||
$logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
|
$logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
|
||||||
@ -466,10 +465,10 @@ download uri eDigest dest mfn etags
|
|||||||
writeEtags destFile getTags = do
|
writeEtags destFile getTags = do
|
||||||
getTags >>= \case
|
getTags >>= \case
|
||||||
Just t -> do
|
Just t -> do
|
||||||
$logDebug [i|Writing etagsFile #{(etagsFile destFile)}|]
|
$logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile)
|
||||||
liftIO $ T.writeFile (etagsFile destFile) t
|
liftIO $ T.writeFile (etagsFile destFile) t
|
||||||
Nothing ->
|
Nothing ->
|
||||||
$logDebug [i|No etags files written|]
|
$logDebug "No etags files written"
|
||||||
|
|
||||||
readETag :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
|
readETag :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
|
||||||
readETag fp = do
|
readETag fp = do
|
||||||
@ -479,13 +478,13 @@ download uri eDigest dest mfn etags
|
|||||||
rE <- try @_ @SomeException $ liftIO $ fmap stripNewline' $ T.readFile (etagsFile fp)
|
rE <- try @_ @SomeException $ liftIO $ fmap stripNewline' $ T.readFile (etagsFile fp)
|
||||||
case rE of
|
case rE of
|
||||||
(Right et) -> do
|
(Right et) -> do
|
||||||
$logDebug [i|Read etag: #{et}|]
|
$logDebug $ "Read etag: " <> et
|
||||||
pure (Just et)
|
pure (Just et)
|
||||||
(Left _) -> do
|
(Left _) -> do
|
||||||
$logDebug [i|Etag file doesn't exist (yet)|]
|
$logDebug "Etag file doesn't exist (yet)"
|
||||||
pure Nothing
|
pure Nothing
|
||||||
else do
|
else do
|
||||||
$logDebug [i|Skipping and deleting etags file because destination file #{fp} doesn't exist|]
|
$logDebug $ "Skipping and deleting etags file because destination file " <> T.pack fp <> " doesn't exist"
|
||||||
liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
|
liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
|
||||||
pure Nothing
|
pure Nothing
|
||||||
|
|
||||||
@ -563,7 +562,7 @@ checkDigest eDigest file = do
|
|||||||
let verify = not noVerify
|
let verify = not noVerify
|
||||||
when verify $ do
|
when verify $ do
|
||||||
let p' = takeFileName file
|
let p' = takeFileName file
|
||||||
lift $ $(logInfo) [i|verifying digest of: #{p'}|]
|
lift $ $(logInfo) $ "verifying digest of: " <> T.pack p'
|
||||||
c <- liftIO $ L.readFile file
|
c <- liftIO $ L.readFile file
|
||||||
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
|
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
|
||||||
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
|
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
|
||||||
|
|||||||
@ -4,7 +4,6 @@
|
|||||||
{-# LANGUAGE ExistentialQuantification #-}
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
|
||||||
@ -25,7 +24,6 @@ import Codec.Archive
|
|||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
import Data.ByteString ( ByteString )
|
import Data.ByteString ( ByteString )
|
||||||
import Data.CaseInsensitive ( CI )
|
import Data.CaseInsensitive ( CI )
|
||||||
import Data.String.Interpolate
|
|
||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
import Data.Versions
|
import Data.Versions
|
||||||
import Haskus.Utils.Variant
|
import Haskus.Utils.Variant
|
||||||
@ -34,6 +32,7 @@ import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
|
|||||||
import URI.ByteString
|
import URI.ByteString
|
||||||
|
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -88,7 +87,7 @@ data UnknownArchive = UnknownArchive FilePath
|
|||||||
|
|
||||||
instance Pretty UnknownArchive where
|
instance Pretty UnknownArchive where
|
||||||
pPrint (UnknownArchive file) =
|
pPrint (UnknownArchive file) =
|
||||||
text [i|The archive format is unknown. We don't know how to extract the file "#{file}"|]
|
text $ "The archive format is unknown. We don't know how to extract the file " <> file
|
||||||
|
|
||||||
-- | The scheme is not supported (such as ftp).
|
-- | The scheme is not supported (such as ftp).
|
||||||
data UnsupportedScheme = UnsupportedScheme
|
data UnsupportedScheme = UnsupportedScheme
|
||||||
@ -111,7 +110,7 @@ data TagNotFound = TagNotFound Tag Tool
|
|||||||
|
|
||||||
instance Pretty TagNotFound where
|
instance Pretty TagNotFound where
|
||||||
pPrint (TagNotFound tag tool) =
|
pPrint (TagNotFound tag tool) =
|
||||||
text "Unable to find tag" <+> pPrint tag <+> text [i|of tool "#{tool}"|]
|
text "Unable to find tag" <+> pPrint tag <+> text "of tool" <+> pPrint tool
|
||||||
|
|
||||||
-- | Unable to find the next version of a tool (the one after the currently
|
-- | Unable to find the next version of a tool (the one after the currently
|
||||||
-- set one).
|
-- set one).
|
||||||
@ -120,7 +119,7 @@ data NextVerNotFound = NextVerNotFound Tool
|
|||||||
|
|
||||||
instance Pretty NextVerNotFound where
|
instance Pretty NextVerNotFound where
|
||||||
pPrint (NextVerNotFound tool) =
|
pPrint (NextVerNotFound tool) =
|
||||||
text [i|Unable to find next (the one after the currently set one) version of tool "#{tool}"|]
|
text "Unable to find next (the one after the currently set one) version of tool" <+> pPrint tool
|
||||||
|
|
||||||
-- | The tool (such as GHC) is already installed with that version.
|
-- | The tool (such as GHC) is already installed with that version.
|
||||||
data AlreadyInstalled = AlreadyInstalled Tool Version
|
data AlreadyInstalled = AlreadyInstalled Tool Version
|
||||||
@ -128,14 +127,14 @@ data AlreadyInstalled = AlreadyInstalled Tool Version
|
|||||||
|
|
||||||
instance Pretty AlreadyInstalled where
|
instance Pretty AlreadyInstalled where
|
||||||
pPrint (AlreadyInstalled tool ver') =
|
pPrint (AlreadyInstalled tool ver') =
|
||||||
text [i|#{tool}-#{prettyShow ver'} is already installed|]
|
pPrint tool <+> text "-" <+> pPrint ver' <+> text "is already installed"
|
||||||
|
|
||||||
-- | The Directory is supposed to be empty, but wasn't.
|
-- | The Directory is supposed to be empty, but wasn't.
|
||||||
data DirNotEmpty = DirNotEmpty {path :: FilePath}
|
data DirNotEmpty = DirNotEmpty {path :: FilePath}
|
||||||
|
|
||||||
instance Pretty DirNotEmpty where
|
instance Pretty DirNotEmpty where
|
||||||
pPrint (DirNotEmpty path) = do
|
pPrint (DirNotEmpty path) = do
|
||||||
text [i|The directory was expected to be empty, but isn't: #{path}|]
|
text $ "The directory was expected to be empty, but isn't: " <> path
|
||||||
|
|
||||||
-- | The tool is not installed. Some operations rely on a tool
|
-- | The tool is not installed. Some operations rely on a tool
|
||||||
-- to be installed (such as setting the current GHC version).
|
-- to be installed (such as setting the current GHC version).
|
||||||
@ -144,7 +143,7 @@ data NotInstalled = NotInstalled Tool GHCTargetVersion
|
|||||||
|
|
||||||
instance Pretty NotInstalled where
|
instance Pretty NotInstalled where
|
||||||
pPrint (NotInstalled tool ver) =
|
pPrint (NotInstalled tool ver) =
|
||||||
text [i|The version "#{prettyShow ver}" of the tool "#{tool}" is not installed.|]
|
text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."
|
||||||
|
|
||||||
-- | An executable was expected to be in PATH, but was not found.
|
-- | An executable was expected to be in PATH, but was not found.
|
||||||
data NotFoundInPATH = NotFoundInPATH FilePath
|
data NotFoundInPATH = NotFoundInPATH FilePath
|
||||||
@ -152,7 +151,7 @@ data NotFoundInPATH = NotFoundInPATH FilePath
|
|||||||
|
|
||||||
instance Pretty NotFoundInPATH where
|
instance Pretty NotFoundInPATH where
|
||||||
pPrint (NotFoundInPATH exe) =
|
pPrint (NotFoundInPATH exe) =
|
||||||
text [i|The exe "#{exe}" was not found in PATH.|]
|
text $ "The exe " <> exe <> " was not found in PATH."
|
||||||
|
|
||||||
-- | JSON decoding failed.
|
-- | JSON decoding failed.
|
||||||
data JSONError = JSONDecodeError String
|
data JSONError = JSONDecodeError String
|
||||||
@ -160,7 +159,7 @@ data JSONError = JSONDecodeError String
|
|||||||
|
|
||||||
instance Pretty JSONError where
|
instance Pretty JSONError where
|
||||||
pPrint (JSONDecodeError err) =
|
pPrint (JSONDecodeError err) =
|
||||||
text [i|JSON decoding failed with: #{err}|]
|
text $ "JSON decoding failed with: " <> err
|
||||||
|
|
||||||
-- | A file that is supposed to exist does not exist
|
-- | A file that is supposed to exist does not exist
|
||||||
-- (e.g. when we use file scheme to "download" something).
|
-- (e.g. when we use file scheme to "download" something).
|
||||||
@ -169,7 +168,7 @@ data FileDoesNotExistError = FileDoesNotExistError FilePath
|
|||||||
|
|
||||||
instance Pretty FileDoesNotExistError where
|
instance Pretty FileDoesNotExistError where
|
||||||
pPrint (FileDoesNotExistError file) =
|
pPrint (FileDoesNotExistError file) =
|
||||||
text [i|File "#{file}" does not exist.|]
|
text $ "File " <> file <> " does not exist."
|
||||||
|
|
||||||
-- | The file already exists
|
-- | The file already exists
|
||||||
-- (e.g. when we use isolated installs with the same path).
|
-- (e.g. when we use isolated installs with the same path).
|
||||||
@ -179,7 +178,7 @@ data FileAlreadyExistsError = FileAlreadyExistsError FilePath
|
|||||||
|
|
||||||
instance Pretty FileAlreadyExistsError where
|
instance Pretty FileAlreadyExistsError where
|
||||||
pPrint (FileAlreadyExistsError file) =
|
pPrint (FileAlreadyExistsError file) =
|
||||||
text [i|File "#{file}" Already exists.|]
|
text $ "File " <> file <> " Already exists."
|
||||||
|
|
||||||
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
|
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
|
||||||
deriving Show
|
deriving Show
|
||||||
@ -194,7 +193,7 @@ data DigestError = DigestError Text Text
|
|||||||
|
|
||||||
instance Pretty DigestError where
|
instance Pretty DigestError where
|
||||||
pPrint (DigestError currentDigest expectedDigest) =
|
pPrint (DigestError currentDigest expectedDigest) =
|
||||||
text [i|Digest error: expected "#{expectedDigest}", but got "#{currentDigest}"|]
|
text "Digest error: expected" <+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest
|
||||||
|
|
||||||
-- | Unexpected HTTP status.
|
-- | Unexpected HTTP status.
|
||||||
data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
|
data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
|
||||||
@ -202,7 +201,7 @@ data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
|
|||||||
|
|
||||||
instance Pretty HTTPStatusError where
|
instance Pretty HTTPStatusError where
|
||||||
pPrint (HTTPStatusError status _) =
|
pPrint (HTTPStatusError status _) =
|
||||||
text [i|Unexpected HTTP status: #{status}|]
|
text "Unexpected HTTP status:" <+> pPrint status
|
||||||
|
|
||||||
-- | Malformed headers.
|
-- | Malformed headers.
|
||||||
data MalformedHeaders = MalformedHeaders Text
|
data MalformedHeaders = MalformedHeaders Text
|
||||||
@ -210,7 +209,7 @@ data MalformedHeaders = MalformedHeaders Text
|
|||||||
|
|
||||||
instance Pretty MalformedHeaders where
|
instance Pretty MalformedHeaders where
|
||||||
pPrint (MalformedHeaders h) =
|
pPrint (MalformedHeaders h) =
|
||||||
text [i|Headers are malformed: #{h}|]
|
text "Headers are malformed: " <+> pPrint h
|
||||||
|
|
||||||
-- | Unexpected HTTP status.
|
-- | Unexpected HTTP status.
|
||||||
data HTTPNotModified = HTTPNotModified Text
|
data HTTPNotModified = HTTPNotModified Text
|
||||||
@ -218,7 +217,7 @@ data HTTPNotModified = HTTPNotModified Text
|
|||||||
|
|
||||||
instance Pretty HTTPNotModified where
|
instance Pretty HTTPNotModified where
|
||||||
pPrint (HTTPNotModified etag) =
|
pPrint (HTTPNotModified etag) =
|
||||||
text [i|Remote resource not modifed, etag was: #{etag}|]
|
text "Remote resource not modifed, etag was:" <+> pPrint etag
|
||||||
|
|
||||||
-- | The 'Location' header was expected during a 3xx redirect, but not found.
|
-- | The 'Location' header was expected during a 3xx redirect, but not found.
|
||||||
data NoLocationHeader = NoLocationHeader
|
data NoLocationHeader = NoLocationHeader
|
||||||
@ -226,7 +225,7 @@ data NoLocationHeader = NoLocationHeader
|
|||||||
|
|
||||||
instance Pretty NoLocationHeader where
|
instance Pretty NoLocationHeader where
|
||||||
pPrint NoLocationHeader =
|
pPrint NoLocationHeader =
|
||||||
text [i|The 'Location' header was expected during a 3xx redirect, but not found.|]
|
text "The 'Location' header was expected during a 3xx redirect, but not found."
|
||||||
|
|
||||||
-- | Too many redirects.
|
-- | Too many redirects.
|
||||||
data TooManyRedirs = TooManyRedirs
|
data TooManyRedirs = TooManyRedirs
|
||||||
@ -234,7 +233,7 @@ data TooManyRedirs = TooManyRedirs
|
|||||||
|
|
||||||
instance Pretty TooManyRedirs where
|
instance Pretty TooManyRedirs where
|
||||||
pPrint TooManyRedirs =
|
pPrint TooManyRedirs =
|
||||||
text [i|Too many redirections.|]
|
text "Too many redirections."
|
||||||
|
|
||||||
-- | A patch could not be applied.
|
-- | A patch could not be applied.
|
||||||
data PatchFailed = PatchFailed
|
data PatchFailed = PatchFailed
|
||||||
@ -242,7 +241,7 @@ data PatchFailed = PatchFailed
|
|||||||
|
|
||||||
instance Pretty PatchFailed where
|
instance Pretty PatchFailed where
|
||||||
pPrint PatchFailed =
|
pPrint PatchFailed =
|
||||||
text [i|A patch could not be applied.|]
|
text "A patch could not be applied."
|
||||||
|
|
||||||
-- | The tool requirements could not be found.
|
-- | The tool requirements could not be found.
|
||||||
data NoToolRequirements = NoToolRequirements
|
data NoToolRequirements = NoToolRequirements
|
||||||
@ -250,35 +249,35 @@ data NoToolRequirements = NoToolRequirements
|
|||||||
|
|
||||||
instance Pretty NoToolRequirements where
|
instance Pretty NoToolRequirements where
|
||||||
pPrint NoToolRequirements =
|
pPrint NoToolRequirements =
|
||||||
text [i|The Tool requirements could not be found.|]
|
text "The Tool requirements could not be found."
|
||||||
|
|
||||||
data InvalidBuildConfig = InvalidBuildConfig Text
|
data InvalidBuildConfig = InvalidBuildConfig Text
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
instance Pretty InvalidBuildConfig where
|
instance Pretty InvalidBuildConfig where
|
||||||
pPrint (InvalidBuildConfig reason) =
|
pPrint (InvalidBuildConfig reason) =
|
||||||
text [i|The build config is invalid. Reason was: #{reason}|]
|
text "The build config is invalid. Reason was:" <+> pPrint reason
|
||||||
|
|
||||||
data NoToolVersionSet = NoToolVersionSet Tool
|
data NoToolVersionSet = NoToolVersionSet Tool
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
instance Pretty NoToolVersionSet where
|
instance Pretty NoToolVersionSet where
|
||||||
pPrint (NoToolVersionSet tool) =
|
pPrint (NoToolVersionSet tool) =
|
||||||
text [i|No version is set for tool "#{tool}".|]
|
text "No version is set for tool" <+> pPrint tool <+> text "."
|
||||||
|
|
||||||
data NoNetwork = NoNetwork
|
data NoNetwork = NoNetwork
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
instance Pretty NoNetwork where
|
instance Pretty NoNetwork where
|
||||||
pPrint NoNetwork =
|
pPrint NoNetwork =
|
||||||
text [i|A download was required or requested, but '--offline' was specified.|]
|
text "A download was required or requested, but '--offline' was specified."
|
||||||
|
|
||||||
data HadrianNotFound = HadrianNotFound
|
data HadrianNotFound = HadrianNotFound
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
instance Pretty HadrianNotFound where
|
instance Pretty HadrianNotFound where
|
||||||
pPrint HadrianNotFound =
|
pPrint HadrianNotFound =
|
||||||
text [i|Could not find Hadrian build files. Does this GHC version support Hadrian builds?|]
|
text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
|
||||||
|
|
||||||
|
|
||||||
-------------------------
|
-------------------------
|
||||||
@ -300,17 +299,17 @@ data BuildFailed = forall es . (Pretty (V es), Show (V es)) => BuildFailed FileP
|
|||||||
|
|
||||||
instance Pretty BuildFailed where
|
instance Pretty BuildFailed where
|
||||||
pPrint (BuildFailed path reason) =
|
pPrint (BuildFailed path reason) =
|
||||||
text [i|BuildFailed failed in dir "#{path}": |] <> pPrint reason
|
text "BuildFailed failed in dir" <+> text (path <> ":") <+> pPrint reason
|
||||||
|
|
||||||
deriving instance Show BuildFailed
|
deriving instance Show BuildFailed
|
||||||
|
|
||||||
|
|
||||||
-- | Setting the current GHC version failed.
|
-- | Setting the current GHC version failed.
|
||||||
data GHCupSetError = forall es . Show (V es) => GHCupSetError (V es)
|
data GHCupSetError = forall es . (Show (V es), Pretty (V es)) => GHCupSetError (V es)
|
||||||
|
|
||||||
instance Pretty GHCupSetError where
|
instance Pretty GHCupSetError where
|
||||||
pPrint (GHCupSetError reason) =
|
pPrint (GHCupSetError reason) =
|
||||||
text [i|Setting the current GHC version failed: #{reason}|]
|
text "Setting the current GHC version failed:" <+> pPrint reason
|
||||||
|
|
||||||
deriving instance Show GHCupSetError
|
deriving instance Show GHCupSetError
|
||||||
|
|
||||||
@ -326,7 +325,7 @@ data ParseError = ParseError String
|
|||||||
|
|
||||||
instance Pretty ParseError where
|
instance Pretty ParseError where
|
||||||
pPrint (ParseError reason) =
|
pPrint (ParseError reason) =
|
||||||
text [i|Parsing failed: #{reason}|]
|
text "Parsing failed:" <+> pPrint reason
|
||||||
|
|
||||||
instance Exception ParseError
|
instance Exception ParseError
|
||||||
|
|
||||||
@ -336,7 +335,7 @@ data UnexpectedListLength = UnexpectedListLength String
|
|||||||
|
|
||||||
instance Pretty UnexpectedListLength where
|
instance Pretty UnexpectedListLength where
|
||||||
pPrint (UnexpectedListLength reason) =
|
pPrint (UnexpectedListLength reason) =
|
||||||
text [i|List length unexpected: #{reason}|]
|
text "List length unexpected:" <+> pPrint reason
|
||||||
|
|
||||||
instance Exception UnexpectedListLength
|
instance Exception UnexpectedListLength
|
||||||
|
|
||||||
@ -345,7 +344,7 @@ data NoUrlBase = NoUrlBase Text
|
|||||||
|
|
||||||
instance Pretty NoUrlBase where
|
instance Pretty NoUrlBase where
|
||||||
pPrint (NoUrlBase url) =
|
pPrint (NoUrlBase url) =
|
||||||
text [i|Couldn't get a base filename from url #{url}|]
|
text "Couldn't get a base filename from url" <+> pPrint url
|
||||||
|
|
||||||
instance Exception NoUrlBase
|
instance Exception NoUrlBase
|
||||||
|
|
||||||
@ -370,21 +369,21 @@ instance
|
|||||||
|
|
||||||
instance Pretty URIParseError where
|
instance Pretty URIParseError where
|
||||||
pPrint (MalformedScheme reason) =
|
pPrint (MalformedScheme reason) =
|
||||||
text [i|Failed to parse URI. Malformed scheme: #{reason}|]
|
text "Failed to parse URI. Malformed scheme:" <+> text (show reason)
|
||||||
pPrint MalformedUserInfo =
|
pPrint MalformedUserInfo =
|
||||||
text [i|Failed to parse URI. Malformed user info.|]
|
text "Failed to parse URI. Malformed user info."
|
||||||
pPrint MalformedQuery =
|
pPrint MalformedQuery =
|
||||||
text [i|Failed to parse URI. Malformed query.|]
|
text "Failed to parse URI. Malformed query."
|
||||||
pPrint MalformedFragment =
|
pPrint MalformedFragment =
|
||||||
text [i|Failed to parse URI. Malformed fragment.|]
|
text "Failed to parse URI. Malformed fragment."
|
||||||
pPrint MalformedHost =
|
pPrint MalformedHost =
|
||||||
text [i|Failed to parse URI. Malformed host.|]
|
text "Failed to parse URI. Malformed host."
|
||||||
pPrint MalformedPort =
|
pPrint MalformedPort =
|
||||||
text [i|Failed to parse URI. Malformed port.|]
|
text "Failed to parse URI. Malformed port."
|
||||||
pPrint MalformedPath =
|
pPrint MalformedPath =
|
||||||
text [i|Failed to parse URI. Malformed path.|]
|
text "Failed to parse URI. Malformed path."
|
||||||
pPrint (OtherError err) =
|
pPrint (OtherError err) =
|
||||||
text [i|Failed to parse URI: #{err}|]
|
text "Failed to parse URI:" <+> pPrint err
|
||||||
|
|
||||||
instance Pretty ArchiveResult where
|
instance Pretty ArchiveResult where
|
||||||
pPrint ArchiveFatal = text "Archive result: fatal"
|
pPrint ArchiveFatal = text "Archive result: fatal"
|
||||||
@ -393,3 +392,6 @@ instance Pretty ArchiveResult where
|
|||||||
pPrint ArchiveRetry = text "Archive result: retry"
|
pPrint ArchiveRetry = text "Archive result: retry"
|
||||||
pPrint ArchiveOk = text "Archive result: Ok"
|
pPrint ArchiveOk = text "Archive result: Ok"
|
||||||
pPrint ArchiveEOF = text "Archive result: EOF"
|
pPrint ArchiveEOF = text "Archive result: EOF"
|
||||||
|
|
||||||
|
instance Pretty T.Text where
|
||||||
|
pPrint = text . T.unpack
|
||||||
|
|||||||
@ -33,7 +33,6 @@ import Control.Monad.Reader
|
|||||||
import Data.ByteString ( ByteString )
|
import Data.ByteString ( ByteString )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.String.Interpolate
|
|
||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
import Data.Versions
|
import Data.Versions
|
||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
@ -108,7 +107,7 @@ getPlatform = do
|
|||||||
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
|
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
|
||||||
"mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
|
"mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
|
||||||
what -> throwE $ NoCompatiblePlatform what
|
what -> throwE $ NoCompatiblePlatform what
|
||||||
lift $ $(logDebug) [i|Identified Platform as: #{prettyShow pfr}|]
|
lift $ $(logDebug) $ "Identified Platform as: " <> T.pack (prettyShow pfr)
|
||||||
pure pfr
|
pure pfr
|
||||||
where
|
where
|
||||||
getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
|
getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
|
||||||
|
|||||||
@ -115,6 +115,13 @@ data Tool = GHC
|
|||||||
| Stack
|
| Stack
|
||||||
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
|
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
|
||||||
|
|
||||||
|
instance Pretty Tool where
|
||||||
|
pPrint GHC = text "ghc"
|
||||||
|
pPrint Cabal = text "cabal"
|
||||||
|
pPrint GHCup = text "ghcup"
|
||||||
|
pPrint HLS = text "hls"
|
||||||
|
pPrint Stack = text "stack"
|
||||||
|
|
||||||
instance NFData Tool
|
instance NFData Tool
|
||||||
|
|
||||||
data GlobalTool = ShimGen
|
data GlobalTool = ShimGen
|
||||||
|
|||||||
@ -62,7 +62,6 @@ import Data.List
|
|||||||
import Data.List.Extra
|
import Data.List.Extra
|
||||||
import Data.List.NonEmpty ( NonEmpty( (:|) ))
|
import Data.List.NonEmpty ( NonEmpty( (:|) ))
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.String.Interpolate
|
|
||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
import Data.Versions
|
import Data.Versions
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
@ -130,7 +129,7 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
|
|||||||
forM_ files $ \f -> do
|
forM_ files $ \f -> do
|
||||||
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
|
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
|
||||||
let fullF = binDir </> f_xyz
|
let fullF = binDir </> f_xyz
|
||||||
lift $ $(logDebug) [i|rm -f #{fullF}|]
|
lift $ $(logDebug) ("rm -f " <> T.pack fullF)
|
||||||
lift $ hideError doesNotExistErrorType $ rmLink fullF
|
lift $ hideError doesNotExistErrorType $ rmLink fullF
|
||||||
|
|
||||||
|
|
||||||
@ -152,11 +151,11 @@ rmPlain target = do
|
|||||||
files <- liftE $ ghcToolFiles tv
|
files <- liftE $ ghcToolFiles tv
|
||||||
forM_ files $ \f -> do
|
forM_ files $ \f -> do
|
||||||
let fullF = binDir </> f <> exeExt
|
let fullF = binDir </> f <> exeExt
|
||||||
lift $ $(logDebug) [i|rm -f #{fullF}|]
|
lift $ $(logDebug) ("rm -f " <> T.pack fullF)
|
||||||
lift $ hideError doesNotExistErrorType $ rmLink fullF
|
lift $ hideError doesNotExistErrorType $ rmLink fullF
|
||||||
-- old ghcup
|
-- old ghcup
|
||||||
let hdc_file = binDir </> "haddock-ghc" <> exeExt
|
let hdc_file = binDir </> "haddock-ghc" <> exeExt
|
||||||
lift $ $(logDebug) [i|rm -f #{hdc_file}|]
|
lift $ $(logDebug) ("rm -f " <> T.pack hdc_file)
|
||||||
lift $ hideError doesNotExistErrorType $ rmLink hdc_file
|
lift $ hideError doesNotExistErrorType $ rmLink hdc_file
|
||||||
|
|
||||||
|
|
||||||
@ -180,7 +179,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
|
|||||||
forM_ files $ \f -> do
|
forM_ files $ \f -> do
|
||||||
let f_xy = f <> "-" <> T.unpack v' <> exeExt
|
let f_xy = f <> "-" <> T.unpack v' <> exeExt
|
||||||
let fullF = binDir </> f_xy
|
let fullF = binDir </> f_xy
|
||||||
lift $ $(logDebug) [i|rm -f #{fullF}|]
|
lift $ $(logDebug) "rm -f #{fullF}"
|
||||||
lift $ hideError doesNotExistErrorType $ rmLink fullF
|
lift $ hideError doesNotExistErrorType $ rmLink fullF
|
||||||
|
|
||||||
|
|
||||||
@ -296,7 +295,11 @@ cabalSet = do
|
|||||||
case linkVersion =<< link of
|
case linkVersion =<< link of
|
||||||
Right v -> pure $ Just v
|
Right v -> pure $ Just v
|
||||||
Left err -> do
|
Left err -> do
|
||||||
$(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
|
$(logWarn) $ "Failed to parse cabal symlink target with: "
|
||||||
|
<> T.pack (displayException err)
|
||||||
|
<> ". The symlink "
|
||||||
|
<> T.pack cabalbin
|
||||||
|
<> " needs to point to valid cabal binary, such as 'cabal-3.4.0.0'."
|
||||||
pure Nothing
|
pure Nothing
|
||||||
where
|
where
|
||||||
-- We try to be extra permissive with link destination parsing,
|
-- We try to be extra permissive with link destination parsing,
|
||||||
@ -380,7 +383,11 @@ stackSet = do
|
|||||||
case linkVersion =<< link of
|
case linkVersion =<< link of
|
||||||
Right v -> pure $ Just v
|
Right v -> pure $ Just v
|
||||||
Left err -> do
|
Left err -> do
|
||||||
$(logWarn) [i|Failed to parse stack symlink target with: "#{err}". The symlink #{stackBin} needs to point to valid stack binary, such as 'stack-2.7.1'.|]
|
$(logWarn) $ "Failed to parse stack symlink target with: "
|
||||||
|
<> T.pack (displayException err)
|
||||||
|
<> ". The symlink "
|
||||||
|
<> T.pack stackBin
|
||||||
|
<> " needs to point to valid stack binary, such as 'stack-2.7.1'."
|
||||||
pure Nothing
|
pure Nothing
|
||||||
where
|
where
|
||||||
linkVersion :: MonadThrow m => FilePath -> m Version
|
linkVersion :: MonadThrow m => FilePath -> m Version
|
||||||
@ -602,7 +609,7 @@ unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
|
|||||||
] m ()
|
] m ()
|
||||||
unpackToDir dfp av = do
|
unpackToDir dfp av = do
|
||||||
let fn = takeFileName av
|
let fn = takeFileName av
|
||||||
lift $ $(logInfo) [i|Unpacking: #{fn} to #{dfp}|]
|
lift $ $(logInfo) $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp
|
||||||
|
|
||||||
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
|
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
|
||||||
untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp
|
untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp
|
||||||
@ -793,7 +800,7 @@ applyPatches :: (MonadReader env m, HasDirs env, MonadLogger m, MonadIO m)
|
|||||||
applyPatches pdir ddir = do
|
applyPatches pdir ddir = do
|
||||||
patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
|
patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
|
||||||
forM_ (sort patches) $ \patch' -> do
|
forM_ (sort patches) $ \patch' -> do
|
||||||
lift $ $(logInfo) [i|Applying patch #{patch'}|]
|
lift $ $(logInfo) $ "Applying patch " <> T.pack patch'
|
||||||
fmap (either (const Nothing) Just)
|
fmap (either (const Nothing) Just)
|
||||||
(exec
|
(exec
|
||||||
"patch"
|
"patch"
|
||||||
@ -864,8 +871,8 @@ runBuildAction bdir instdir action = do
|
|||||||
-- printing other errors without crashing.
|
-- printing other errors without crashing.
|
||||||
rmBDir :: (MonadLogger m, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
|
rmBDir :: (MonadLogger m, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
|
||||||
rmBDir dir = withRunInIO (\run -> run $
|
rmBDir dir = withRunInIO (\run -> run $
|
||||||
liftIO $ handleIO (\e -> run $ $(logWarn)
|
liftIO $ handleIO (\e -> run $ $(logWarn) $
|
||||||
[i|Couldn't remove build dir #{dir}, error was: #{displayException e}|])
|
"Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e))
|
||||||
$ hideError doesNotExistErrorType
|
$ hideError doesNotExistErrorType
|
||||||
$ rmPathForcibly dir)
|
$ rmPathForcibly dir)
|
||||||
|
|
||||||
@ -999,17 +1006,17 @@ createLink link exe = do
|
|||||||
fullLink = takeDirectory exe </> link
|
fullLink = takeDirectory exe </> link
|
||||||
shimContents = "path = " <> fullLink
|
shimContents = "path = " <> fullLink
|
||||||
|
|
||||||
$(logDebug) [i|rm -f #{exe}|]
|
$(logDebug) $ "rm -f " <> T.pack exe
|
||||||
rmLink exe
|
rmLink exe
|
||||||
|
|
||||||
$(logDebug) [i|ln -s #{fullLink} #{exe}|]
|
$(logDebug) $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
|
||||||
liftIO $ copyFile shimGen exe
|
liftIO $ copyFile shimGen exe
|
||||||
liftIO $ writeFile shim shimContents
|
liftIO $ writeFile shim shimContents
|
||||||
#else
|
#else
|
||||||
$(logDebug) [i|rm -f #{exe}|]
|
$(logDebug) $ "rm -f " <> T.pack exe
|
||||||
hideError doesNotExistErrorType $ recycleFile exe
|
hideError doesNotExistErrorType $ recycleFile exe
|
||||||
|
|
||||||
$(logDebug) [i|ln -s #{link} #{exe}|]
|
$(logDebug) $ "ln -s " <> T.pack link <> " " <> T.pack exe
|
||||||
liftIO $ createFileLink link exe
|
liftIO $ createFileLink link exe
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
@ -1034,8 +1041,8 @@ ensureGlobalTools = do
|
|||||||
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
|
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
|
||||||
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
|
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
|
||||||
void $ (\(DigestError _ _) -> do
|
void $ (\(DigestError _ _) -> do
|
||||||
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
|
lift $ $(logWarn) "Digest doesn't match, redownloading gs.exe..."
|
||||||
lift $ $(logDebug) [i|rm -f #{shimDownload}|]
|
lift $ $(logDebug) "rm -f #{shimDownload}"
|
||||||
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
|
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
|
||||||
liftE @'[DigestError , DownloadFailed] $ dl
|
liftE @'[DigestError , DownloadFailed] $ dl
|
||||||
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
|
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
|
||||||
|
|||||||
@ -50,7 +50,6 @@ import Control.Monad.Reader
|
|||||||
import Control.Monad.Trans.Resource hiding (throwM)
|
import Control.Monad.Trans.Resource hiding (throwM)
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.String.Interpolate
|
|
||||||
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
|
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
|
||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Optics
|
import Optics
|
||||||
@ -274,7 +273,13 @@ mkGhcupTmpDir = do
|
|||||||
let minSpace = 5000 -- a rough guess, aight?
|
let minSpace = 5000 -- a rough guess, aight?
|
||||||
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
|
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
|
||||||
when (maybe False (toBytes minSpace >) space) $ do
|
when (maybe False (toBytes minSpace >) space) $ do
|
||||||
$(logWarn) [i|Possibly insufficient disk space on #{tmpdir}. At least #{minSpace} MB are recommended, but only #{toMB (fromJust space)} are free. Consider freeing up disk space or setting TMPDIR env variable.|]
|
$(logWarn) ("Possibly insufficient disk space on "
|
||||||
|
<> T.pack tmpdir
|
||||||
|
<> ". At least "
|
||||||
|
<> T.pack (show minSpace)
|
||||||
|
<> " MB are recommended, but only "
|
||||||
|
<> toMB (fromJust space)
|
||||||
|
<> " are free. Consider freeing up disk space or setting TMPDIR env variable.")
|
||||||
$(logWarn)
|
$(logWarn)
|
||||||
"...waiting for 10 seconds before continuing anyway, you can still abort..."
|
"...waiting for 10 seconds before continuing anyway, you can still abort..."
|
||||||
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
|
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
|
||||||
@ -282,7 +287,7 @@ mkGhcupTmpDir = do
|
|||||||
liftIO $ createTempDirectory tmpdir "ghcup"
|
liftIO $ createTempDirectory tmpdir "ghcup"
|
||||||
where
|
where
|
||||||
toBytes mb = mb * 1024 * 1024
|
toBytes mb = mb * 1024 * 1024
|
||||||
toMB b = show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
|
toMB b = T.pack $ show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
|
||||||
truncate' :: Double -> Int -> Double
|
truncate' :: Double -> Int -> Double
|
||||||
truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
|
truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
|
||||||
where t = 10^n
|
where t = 10^n
|
||||||
@ -304,7 +309,7 @@ withGHCupTmpDir = snd <$> withRunInIO (\run ->
|
|||||||
(run mkGhcupTmpDir)
|
(run mkGhcupTmpDir)
|
||||||
(\fp ->
|
(\fp ->
|
||||||
handleIO (\e -> run
|
handleIO (\e -> run
|
||||||
$ $(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|])
|
$ $(logDebug) ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
|
||||||
. rmPathForcibly
|
. rmPathForcibly
|
||||||
$ fp))
|
$ fp))
|
||||||
|
|
||||||
@ -347,8 +352,8 @@ cleanupTrash = do
|
|||||||
if null contents
|
if null contents
|
||||||
then pure ()
|
then pure ()
|
||||||
else do
|
else do
|
||||||
$(logWarn) [i|Removing leftover files in #{recycleDir}|]
|
$(logWarn) ("Removing leftover files in " <> T.pack recycleDir)
|
||||||
forM_ contents (\fp -> handleIO (\e ->
|
forM_ contents (\fp -> handleIO (\e ->
|
||||||
$(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|]
|
$(logDebug) ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
|
||||||
) $ liftIO $ removePathForcibly (recycleDir </> fp))
|
) $ liftIO $ removePathForcibly (recycleDir </> fp))
|
||||||
|
|
||||||
|
|||||||
@ -1,4 +1,3 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
@ -11,7 +10,6 @@ import GHCup.Utils.Prelude
|
|||||||
import Control.Monad.Extra
|
import Control.Monad.Extra
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.String.Interpolate
|
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
import Optics hiding ((<|), (|>))
|
import Optics hiding ((<|), (|>))
|
||||||
import System.Directory
|
import System.Directory
|
||||||
@ -31,13 +29,13 @@ data ProcessError = NonZeroExit Int FilePath [String]
|
|||||||
|
|
||||||
instance Pretty ProcessError where
|
instance Pretty ProcessError where
|
||||||
pPrint (NonZeroExit e exe args) =
|
pPrint (NonZeroExit e exe args) =
|
||||||
text [i|Process "#{exe}" with arguments #{args} failed with exit code #{e}.|]
|
text "Process " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text " failed with exit code " <+> text (show e) <+> "."
|
||||||
pPrint (PTerminated exe args) =
|
pPrint (PTerminated exe args) =
|
||||||
text [i|Process "#{exe}" with arguments #{args} terminated.|]
|
text "Process " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text " terminated."
|
||||||
pPrint (PStopped exe args) =
|
pPrint (PStopped exe args) =
|
||||||
text [i|Process "#{exe}" with arguments #{args} stopped.|]
|
text "Process " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text " stopped."
|
||||||
pPrint (NoSuchPid exe args) =
|
pPrint (NoSuchPid exe args) =
|
||||||
text [i|Could not find PID for process running "#{exe}" with arguments #{args}.|]
|
text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
|
||||||
|
|
||||||
data CapturedProcess = CapturedProcess
|
data CapturedProcess = CapturedProcess
|
||||||
{ _exitCode :: ExitCode
|
{ _exitCode :: ExitCode
|
||||||
|
|||||||
@ -35,7 +35,6 @@ import Data.ByteString ( ByteString )
|
|||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
import Data.Sequence ( Seq, (|>) )
|
import Data.Sequence ( Seq, (|>) )
|
||||||
import Data.String.Interpolate
|
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Word8
|
import Data.Word8
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
@ -362,7 +361,7 @@ chmod_755 fp = do
|
|||||||
`unionFileModes` groupReadMode
|
`unionFileModes` groupReadMode
|
||||||
`unionFileModes` otherExecuteMode
|
`unionFileModes` otherExecuteMode
|
||||||
`unionFileModes` otherReadMode
|
`unionFileModes` otherReadMode
|
||||||
$(logDebug) [i|chmod 755 #{fp}|]
|
$(logDebug) ("chmod 755 " <> T.pack fp)
|
||||||
liftIO $ setFileMode fp exe_mode
|
liftIO $ setFileMode fp exe_mode
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user