Compare commits

...

35 Commits

Author SHA1 Message Date
283f2a6e46 Add ghcup whereis bindir and friends, fixes #221 2021-09-02 15:37:03 +02:00
94637dfbab Merge branch 'updates' 2021-09-01 01:00:20 +02:00
3e26d7057c Update ghc file 2021-09-01 00:44:52 +02:00
3f710112f3 Rather do it in bootstrap-haskell 2021-08-31 23:23:59 +02:00
34df41b44a Update debian image 2021-08-31 23:04:57 +02:00
3897434ef0 Create .bash_profile on windows if it doesn't exist 2021-08-31 22:59:32 +02:00
375dba9dd1 Improve hlint job 2021-08-31 22:59:32 +02:00
2edd1fb583 Merge branch 'fix-bootstrap-win' 2021-08-31 19:28:21 +02:00
11326060fb Smaller fixes to windows bootstrap 2021-08-31 18:57:38 +02:00
d343c01737 Add CI section 2021-08-31 02:17:38 +02:00
3925f78721 Merge branch 'drop-monad-logger' 2021-08-30 23:55:31 +02:00
d98e54a743 Drop yaml/libyaml 2021-08-30 23:36:11 +02:00
13143b8e4d Drop monad-logger 2021-08-30 23:36:11 +02:00
3a7895e5ea Reorder 2021-08-30 13:59:30 +02:00
2893b2e2d2 Adjust argumentlist 2021-08-30 13:49:48 +02:00
987436fed2 Adjust switch order 2021-08-30 13:47:08 +02:00
96ac66e909 Merge branch 'issue-222' 2021-08-30 11:42:28 +02:00
e5947f3490 Add BOOTSTRAP_HASKELL_MINIMAL wrt #222 2021-08-30 11:19:43 +02:00
b35fe15703 Merge branch 'remove-zipp' 2021-08-29 23:11:03 +02:00
a269b60282 Remove extra 2021-08-29 22:37:16 +02:00
fc6f7ffd73 Update stack.yaml 2021-08-29 21:21:03 +02:00
430dc2d20b Remove zip dependency 2021-08-29 20:56:17 +02:00
77c464870f Refreeze 2021-08-29 17:46:53 +02:00
dda38ec52b Merge remote-tracking branch 'origin/merge-requests/158' 2021-08-29 17:43:01 +02:00
Jan Hrček
f6b6b36eb7 Apply hlint 3.3.2 suggestions 2021-08-29 17:08:06 +02:00
Jan Hrček
3986677b06 Fix typos and simplify code 2021-08-29 14:50:49 +02:00
1fb048777c Merge branch 'cabal-plan' 2021-08-27 15:19:17 +02:00
e9c335eecc Add --cabal-plan 2021-08-27 14:59:09 +02:00
a7c7186aa4 Add ghc-8.10.7 2021-08-27 12:41:01 +02:00
e38bd61066 Fixup merge 2021-08-26 20:16:40 +02:00
b086261c3c Merge remote-tracking branch 'origin/merge-requests/149' 2021-08-26 20:12:19 +02:00
8c098d4e17 Add solus in getLinuxDistro 2021-08-26 20:09:48 +02:00
e3a9c095c6 Merge branch 'remove-string-interpolate' 2021-08-25 21:17:19 +02:00
Arjun Kathuria
df758d828b swap checkFileAlreadyExists with throwIfFileAlreadyExists 2021-08-24 20:39:07 +05:30
Arjun Kathuria
8c486e8d46 Make GHCup isolate installs non-overwriting by default 2021-08-23 20:18:45 +05:30
33 changed files with 9836 additions and 9335 deletions

View File

@@ -14,7 +14,7 @@ variables:
############################################################
.debian:
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:$DOCKER_REV"
tags:
- x86_64-linux
variables:
@@ -527,15 +527,9 @@ release:windows:
hlint:
stage: hlint
extends:
- .alpine:64bit
before_script:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
- .debian
script:
- ./.gitlab/script/hlint.sh
variables:
GHC_VERSION: "8.10.6"
CABAL_VERSION: "3.4.0.0"
JSON_VERSION: "0.0.4"
- curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s -- -r lib/ test/
allow_failure: true
artifacts:
expire_in: 2 week

File diff suppressed because it is too large Load Diff

121
README.md
View File

@@ -24,6 +24,7 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
* [Env variables](#env-variables)
* [Installing custom bindists](#installing-custom-bindists)
* [Isolated Installs](#isolated-installs)
* [CI](#ci)
* [Tips and tricks](#tips-and-tricks)
* [Design goals](#design-goals)
* [How](#how)
@@ -190,6 +191,126 @@ Examples:-
5. you can even compile ghc to an isolated location.
- `ghcup compile ghc -j 4 -v 9.0.1 -b 8.10.5 -i /home/username/my/dir/ghc`
---
### CI
On windows, ghcup can be installed automatically on a CI runner like so:
```ps
Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $false,$true,$true,$false,$false,$false,$false,"C:\"
```
On linux/darwin/freebsd, run the following on your runner:
```sh
curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh
```
This will just install `ghcup` and on windows additionally `msys2`.
#### Example github workflow
On github workflows you can use https://github.com/haskell/actions/
If you want to install ghcup manually though, here's an example config:
```yml
name: Haskell CI
on:
push:
branches: [ master ]
pull_request:
branches: [ master ]
jobs:
build-cabal:
runs-on: ${{ matrix.os }}
strategy:
fail-fast: false
matrix:
os: [ubuntu-latest, macOS-latest, windows-latest]
ghc: ['8.10.7', '9.0.1']
cabal: ['3.4.0.0']
steps:
- uses: actions/checkout@v2
- if: matrix.os == 'windows-latest'
name: Install ghcup on windows
run: Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $false,$true,$true,$false,$false,$false,$false,"C:\"
- if: matrix.os != 'windows-latest'
name: Install ghcup on non-windows
run: curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh
- if: matrix.os == 'windows-latest'
run: echo "/c/ghcup/bin" >> $GITHUB_PATH
shell: bash
- name: Install ghc/cabal
run: |
ghcup install ghc ${{ matrix.ghc }}
ghcup install cabal ${{ matrix.cabal }}
shell: bash
- name: Update cabal index
run: cabal update
shell: bash
- name: Build
run: cabal build --enable-tests --enable-benchmarks
shell: bash
- name: Run tests
run: cabal test
shell: bash
- name: Run benches
run: cabal bench
shell: bash
build-stack:
name: Stack ${{ matrix.stack }} ${{ matrix.os }}
runs-on: ${{ matrix.os }}
strategy:
fail-fast: false
matrix:
os: [ubuntu-latest, macOS-latest, windows-latest]
stack: ['latest']
steps:
- uses: actions/checkout@v2
- if: matrix.os == 'windows-latest'
name: Install ghcup on windows
run: Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $false,$true,$true,$false,$false,$false,$false,"C:\"
- if: matrix.os != 'windows-latest'
name: Install ghcup on non-windows
run: curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh
- if: matrix.os == 'windows-latest'
run: echo "/c/ghcup/bin" >> $GITHUB_PATH
shell: bash
- name: Install stack
run: ghcup install stack ${{ matrix.stack }}
shell: bash
- name: Build
run: stack build
shell: bash
- name: Run tests
run: stack test
shell: bash
- name: Run benches
run: stack bench
shell: bash
```
### Tips and tricks

View File

@@ -11,22 +11,31 @@
module Main where
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Errors
import GHCup.Platform
import GHCup.Utils.Dirs
import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.IO.Class
import Data.Char ( toLower )
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) )
#endif
import Options.Applicative hiding ( style )
import Haskus.Utils.Variant.Excepts
import System.Console.Pretty
import System.Exit
import System.IO ( stdout )
import System.IO ( stderr )
import Text.Regex.Posix
import Validate
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text.IO as T
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.Yaml as Y
import qualified Data.YAML.Aeson as Y
data Options = Options
@@ -105,10 +114,27 @@ com = subparser
main :: IO ()
main = do
let loggerConfig = LoggerConfig { lcPrintDebug = True
, colorOutter = T.hPutStr stderr
, rawOutter = \_ -> pure ()
}
dirs <- liftIO getAllDirs
let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings loggerConfig
pfreq <- (
flip runReaderT leanAppstate . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of
ValidateYAML vopts -> withValidateYamlOpts vopts validate
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (validateTarballs tarballFilter)
ValidateYAML vopts -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validate dl m)
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validateTarballs tarballFilter dl m)
pure ()
where
@@ -120,8 +146,8 @@ main = do
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit f
valAndExit f contents = do
(GHCupInfo _ av gt) <- case Y.decodeEither' contents of
(GHCupInfo _ av gt) <- case Y.decode1Strict contents of
Right r -> pure r
Left e -> die (color Red $ show e)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av gt)
Left (_, e) -> die (color Red $ show e)
f av gt
>>= exitWith

View File

@@ -12,11 +12,9 @@ module Validate where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Platform
import GHCup.Types hiding ( LeanAppState (..) )
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
import Codec.Archive
@@ -24,7 +22,6 @@ import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( runReaderT )
@@ -39,12 +36,10 @@ import Haskus.Utils.Variant.Excepts
import Optics
import System.FilePath
import System.Exit
import System.IO
import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Version as V
@@ -62,7 +57,7 @@ addError = do
liftIO $ modifyIORef ref (+ 1)
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
validate :: (Monad m, MonadReader env m, HasLog env, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> m ExitCode
@@ -89,23 +84,23 @@ validate dls _ = do
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) "All good"
lift $ logInfo "All good"
pure ExitSuccess
where
checkHasRequiredPlatforms t v tags arch pspecs = do
let v' = prettyVer v
arch' = prettyShow arch
when (notElem (Linux UnknownLinux) pspecs) $ do
lift $ $(logError) $
lift $ logError $
"Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
when ((notElem Darwin pspecs) && arch == A_64) $ do
lift $ $(logError) $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn) $
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ logWarn $
"FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
when (notElem Windows pspecs && arch == A_64) $ do
lift $ $(logError) $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
-- alpine needs to be set explicitly, because
@@ -113,12 +108,12 @@ validate dls _ = do
-- (although it could be static)
when (notElem (Linux Alpine) pspecs) $
case t of
GHCup | arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow 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|]
, arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow 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
, arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))
_ -> lift $ $(logWarn) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
, arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))
_ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
checkUniqueTags tool = do
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
@@ -138,7 +133,7 @@ validate dls _ = do
case join nonUnique of
[] -> pure ()
xs -> do
lift $ $(logError) $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
lift $ logError $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
addError
where
isUniqueTag Latest = True
@@ -154,7 +149,7 @@ validate dls _ = do
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
[_] -> pure ()
_ -> do
lift $ $(logError) $ "GHC version " <> prettyVer v <> " is not valid"
lift $ logError $ "GHC version " <> prettyVer v <> " is not valid"
addError
-- a tool must have at least one of each mandatory tags
@@ -162,7 +157,7 @@ validate dls _ = do
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do
lift $ $(logError) $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
addError
True -> pure ()
@@ -171,7 +166,7 @@ validate dls _ = do
let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
False -> do
lift $ $(logError) $ "Base tag missing from GHC ver " <> prettyVer ver
lift $ logError $ "Base tag missing from GHC ver " <> prettyVer ver
addError
True -> pure ()
@@ -184,7 +179,10 @@ data TarballFilter = TarballFilter
}
validateTarballs :: ( Monad m
, MonadLogger m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
@@ -199,45 +197,37 @@ validateTarballs :: ( Monad m
validateTarballs (TarballFilter etool versionRegex) dls gt = do
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- download/verify all tarballs
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 allDls = either (const gdlis) (const dlis) etool
when (null allDls) $ $(logError) "no tarballs selected by filter" *> addError
forM_ allDls downloadAll
-- download/verify all tarballs
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 allDls = either (const gdlis) (const dlis) etool
when (null allDls) $ logError "no tarballs selected by filter" *> (flip runReaderT ref addError)
forM_ allDls (downloadAll ref)
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) "All good"
pure ExitSuccess
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
logInfo "All good"
pure ExitSuccess
where
runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = \_ -> pure ()
}
downloadAll dli = do
dirs <- liftIO getAllDirs
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
lift $ runLogger
($(logError) $ T.pack $ prettyShow e)
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
r <-
runLogger
. flip runReaderT appstate
. runResourceT
downloadAll :: ( MonadUnliftIO m
, MonadIO m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
, MonadCatch m
, MonadMask m
, MonadThrow m
)
=> IORef Int
-> DownloadInfo
-> m ()
downloadAll ref dli = do
r <- runResourceT
. runE @'[DigestError
, DownloadFailed
, UnknownArchive
@@ -263,26 +253,26 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
VRight (Just basePath) -> do
case _dlSubdir dli of
Just (RealDir prel) -> do
lift $ $(logInfo)
logInfo
$ " verifying subdir: " <> T.pack prel
when (basePath /= prel) $ do
lift $ $(logError) $
logError $
"Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
addError
(flip runReaderT ref addError)
Just (RegexDir regexString) -> do
lift $ $(logInfo) $
logInfo $
"verifying subdir (regex): " <> T.pack regexString
let regex = makeRegexOpts
compIgnoreCase
execBlank
regexString
when (not (match regex basePath)) $ do
lift $ $(logError) $
logError $
"Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
addError
(flip runReaderT ref addError)
Nothing -> pure ()
VRight Nothing -> pure ()
VLeft e -> do
lift $ $(logError) $
logError $
"Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
addError
(flip runReaderT ref addError)

View File

@@ -13,11 +13,11 @@ module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types.Optics hiding ( getGHCupInfo )
import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils
import GHCup.Utils.Prelude ( decUTF8Safe )
import GHCup.Utils.File
import GHCup.Utils.Logger
import Brick
import Brick.Widgets.Border
@@ -29,7 +29,6 @@ import Brick.Widgets.List ( listSelectedFocusedAttr
)
import Codec.Archive
import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.Trans.Resource
@@ -417,12 +416,8 @@ install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, Monad
install' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
l <- liftIO $ readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. runResourceT
runResourceT
. runE
@'[ AlreadyInstalled
, ArchiveResult
@@ -462,7 +457,7 @@ install' _ (_, ListResult {..}) = do
>>= \case
VRight vi -> do
forM_ (_viPostInstall =<< vi) $ \msg ->
myLoggerT l $ $(logInfo) msg
logInfo msg
pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right ()
@@ -473,12 +468,9 @@ install' _ (_, ListResult {..}) = do
set' :: BrickState -> (Int, ListResult) -> IO (Either String ())
set' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. flip runReaderT settings
flip runReaderT settings
. runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
run (do
@@ -501,9 +493,7 @@ del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnlif
del' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
l <- liftIO $ readIORef logger'
let runLogger = myLoggerT l
let run = myLoggerT l . runE @'[NotInstalled]
let run = runE @'[NotInstalled]
run (do
let vi = getVersionInfo lVer lTool dls
@@ -517,7 +507,7 @@ del' _ (_, ListResult {..}) = do
>>= \case
VRight vi -> do
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg
logInfo msg
pure $ Right ()
VLeft e -> pure $ Left (prettyShow e)
@@ -546,6 +536,10 @@ settings' :: IORef AppState
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
dirs <- getAllDirs
let loggerConfig = LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
newIORef $ AppState (Settings { cache = True
, noVerify = False
, keepDirs = Never
@@ -559,27 +553,14 @@ settings' = unsafePerformIO $ do
defaultKeyBindings
(GHCupInfo mempty mempty mempty)
(PlatformRequest A_64 Darwin Nothing)
loggerConfig
logger' :: IORef LoggerConfig
{-# NOINLINE logger' #-}
logger' = unsafePerformIO
(newIORef $ LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
)
brickMain :: AppState
-> LoggerConfig
-> IO ()
brickMain s l = do
brickMain s = do
writeIORef settings' s
-- logger interpreter
writeIORef logger' l
let runLogger = myLoggerT l
no_color <- isJust <$> lookupEnv "NO_COLOR"
@@ -596,7 +577,7 @@ brickMain s l = do
)
$> ()
Left e -> do
runLogger ($(logError) $ "Error building app state: " <> T.pack (show e))
flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e)
exitWith $ ExitFailure 2
@@ -607,12 +588,9 @@ defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = Fal
getGHCupInfo :: IO (Either String GHCupInfo)
getGHCupInfo = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <-
runLogger
. flip runReaderT settings
flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE
$ getDownloadsF
@@ -625,14 +603,11 @@ getGHCupInfo = do
getAppData :: Maybe GHCupInfo
-> IO (Either String BrickData)
getAppData mgi = runExceptT $ do
l <- liftIO $ readIORef logger'
let runLogger = myLoggerT l
r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
settings <- liftIO $ readIORef settings'
runLogger . flip runReaderT settings $ do
flip runReaderT settings $ do
lV <- listVersions Nothing Nothing
pure $ BrickData (reverse lV)

View File

@@ -30,6 +30,7 @@ import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Version
import Cabal.Plan ( findPlanJson, SearchPlanJson(..) )
import Codec.Archive
import Control.Concurrent
import Control.Concurrent.Async
@@ -39,9 +40,10 @@ import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Aeson ( decodeStrict', Value )
import Data.Aeson.Encode.Pretty ( encodePretty )
import Data.Bifunctor
import Data.Char
import Data.Either
@@ -75,8 +77,7 @@ import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified Data.Yaml.Pretty as YP
import qualified Data.YAML.Aeson as Y
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
@@ -204,6 +205,11 @@ data ChangeLogOptions = ChangeLogOptions
data WhereisCommand = WhereisTool Tool (Maybe ToolVersion)
| WhereisBaseDir
| WhereisBinDir
| WhereisCacheDir
| WhereisLogsDir
| WhereisConfDir
data WhereisOptions = WhereisOptions {
directory :: Bool
@@ -832,7 +838,8 @@ configP = subparser
whereisP :: Parser WhereisCommand
whereisP = subparser
( command
(commandGroup "Tools locations:" <>
command
"ghc"
(WhereisTool GHC <$> info
( optional (toolVersionArgument Nothing (Just GHC)) <**> helper )
@@ -867,6 +874,37 @@ whereisP = subparser
command
"ghcup"
(WhereisTool GHCup <$> info ( (pure Nothing) <**> helper ) ( progDesc "Get ghcup location" ))
) <|> subparser ( commandGroup "Directory locations:"
<>
command
"basedir"
(info (pure WhereisBaseDir <**> helper)
( progDesc "Get ghcup base directory location" )
)
<>
command
"bindir"
(info (pure WhereisBinDir <**> helper)
( progDesc "Get ghcup binary directory location" )
)
<>
command
"cachedir"
(info (pure WhereisCacheDir <**> helper)
( progDesc "Get ghcup cache directory location" )
)
<>
command
"logsdir"
(info (pure WhereisLogsDir <**> helper)
( progDesc "Get ghcup logs directory location" )
)
<>
command
"confdir"
(info (pure WhereisConfDir <**> helper)
( progDesc "Get ghcup config directory location" )
)
)
where
whereisGHCFooter = [s|Discussion:
@@ -1096,19 +1134,18 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True)
dirs'
defaultKeyBindings
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
}
let runLogger = myLoggerT loggerConfig
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True)
dirs'
defaultKeyBindings
loggerConfig
mGhcUpInfo <- runLogger . flip runReaderT appState . runE $ getDownloadsF
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
case mGhcUpInfo of
VRight ghcupInfo -> do
let allTags = filter (\t -> t /= Old)
@@ -1128,14 +1165,14 @@ versionCompleter criteria tool = listIOCompleter $ do
, colorOutter = mempty
, rawOutter = mempty
}
let runLogger = myLoggerT loggerConfig
settings = Settings True False Never Curl False GHCupURL True
let settings = Settings True False Never Curl False GHCupURL True
let leanAppState = LeanAppState
settings
dirs'
defaultKeyBindings
mpFreq <- runLogger . flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- runLogger . flip runReaderT leanAppState . runE $ getDownloadsF
loggerConfig
mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
forFold mpFreq $ \pfreq -> do
forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState
@@ -1144,8 +1181,9 @@ versionCompleter criteria tool = listIOCompleter $ do
defaultKeyBindings
ghcupInfo
pfreq
loggerConfig
runEnv = runLogger . flip runReaderT appState
runEnv = flip runReaderT appState
installedVersions <- runEnv $ listVersions (Just tool) criteria
return $ T.unpack . prettyVer . lVer <$> installedVersions
@@ -1316,7 +1354,7 @@ toSettings options = do
updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings
updateSettings config settings = do
settings' <- lE' JSONDecodeError . first show . Y.decodeEither' $ config
settings' <- lE' JSONDecodeError . first snd . Y.decode1Strict $ config
pure $ mergeConf settings' settings
where
mergeConf :: UserSettings -> Settings -> Settings
@@ -1363,11 +1401,19 @@ describe_result = $( LitE . StringL <$>
)
)
plan_json :: String
plan_json = $( LitE . StringL <$>
runIO (handleIO (\_ -> pure "") $ do
fp <- findPlanJson (ProjectRelativeToDir ".")
c <- B.readFile fp
(Just res) <- pure $ decodeStrict' @Value c
pure $ T.unpack $ decUTF8Safe' $ encodePretty res
)
)
formatConfig :: UserSettings -> String
formatConfig settings
= UTF8.toString . YP.encodePretty yamlConfig $ settings
where
yamlConfig = YP.setConfCompare compare YP.defConfig
= UTF8.toString . Y.encode1Strict $ settings
main :: IO ()
main = do
@@ -1381,6 +1427,9 @@ main = do
(head . lines $ describe_result)
)
(long "version" <> help "Show version" <> hidden)
let planJson = infoOption
plan_json
(long "plan-json" <> help "Show the build-time configuration" <> internal)
let numericVersionHelp = infoOption
numericVer
( long "numeric-version"
@@ -1408,7 +1457,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
customExecParser
(prefs showHelpOnError)
(info (opts <**> helper <**> versionHelp <**> numericVersionHelp <**> listCommands)
(info (opts <**> helper <**> versionHelp <**> numericVersionHelp <**> planJson <**> listCommands)
(footerDoc (Just $ text main_footer))
)
>>= \opt@Options {..} -> do
@@ -1419,18 +1468,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(settings, keybindings) <- toSettings opt
-- logger interpreter
logfile <- flip runReaderT dirs $ initGHCupFileLogging
logfile <- flip runReaderT dirs initGHCupFileLogging
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr
, colorOutter = T.hPutStr stderr
, rawOutter =
case optCommand of
Nuke -> \_ -> pure ()
_ -> B.appendFile logfile
_ -> T.appendFile logfile
}
let runLogger = myLoggerT loggerConfig
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }
let leanAppstate = LeanAppState settings dirs keybindings loggerConfig
let runLogger = flip runReaderT leanAppstate
let siletRunLogger = flip runReaderT (leanAppstate { loggerConfig = loggerConfig { colorOutter = \_ -> pure () } } :: LeanAppState)
-------------------------
@@ -1438,7 +1489,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-------------------------
let leanAppstate = LeanAppState settings dirs keybindings
appState = do
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
@@ -1446,12 +1496,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
ghcupInfo <-
( runLogger
. flip runReaderT leanAppstate
( flip runReaderT leanAppstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF
@@ -1460,12 +1509,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
let s' = AppState settings dirs keybindings ghcupInfo pfreq
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupTrash)
(threadDelay 5000000 >> runLogger ($(logWarn) $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
race_ (liftIO $ flip runReaderT s' cleanupTrash)
(threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
case optCommand of
Nuke -> pure ()
@@ -1477,7 +1526,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Interactive -> pure ()
#endif
_ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
Nothing -> flip runReaderT s' checkForUpdates
Just _ -> pure ()
-- TODO: always run for windows
@@ -1485,7 +1534,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight _ -> pure ()
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 30)
pure s'
@@ -1510,8 +1559,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runInstTool' appstate' mInstPlatform =
runLogger
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
. runResourceT
. runE
@'[ AlreadyInstalled
@@ -1539,8 +1587,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runLeanSetGHC =
runLogger
. runLeanAppState
runLeanAppState
. runE
@'[ FileDoesNotExistError
, NotInstalled
@@ -1550,8 +1597,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
runSetGHC =
runLogger
. runAppState
runAppState
. runE
@'[ FileDoesNotExistError
, NotInstalled
@@ -1562,8 +1608,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runLeanSetCabal =
runLogger
. runLeanAppState
runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
@@ -1572,8 +1617,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
runSetCabal =
runLogger
. runAppState
runAppState
. runE
@'[ NotInstalled
, TagNotFound
@@ -1583,8 +1627,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runSetHLS =
runLogger
. runAppState
runAppState
. runE
@'[ NotInstalled
, TagNotFound
@@ -1593,8 +1636,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
runLeanSetHLS =
runLogger
. runLeanAppState
runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
@@ -1602,23 +1644,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NoToolVersionSet
]
let runListGHC = runLogger . runAppState
let runListGHC = runAppState
let runRm =
runLogger . runAppState . runE @'[NotInstalled]
runAppState . runE @'[NotInstalled]
let runNuke s' =
runLogger . flip runReaderT s' . runE @'[NotInstalled]
flip runReaderT s' . runE @'[NotInstalled]
let runDebugInfo =
runLogger
. runAppState
runAppState
. runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC =
runLogger
. runAppState
runAppState
. runResourceT
. runE
@'[ AlreadyInstalled
@@ -1638,10 +1678,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runLeanWhereIs =
runLogger
-- Don't use runLeanAppState here, which is disabled on windows.
-- This is the only command on all platforms that doesn't need full appstate.
. flip runReaderT leanAppstate
flip runReaderT leanAppstate
. runE
@'[ NotInstalled
, NoToolVersionSet
@@ -1650,8 +1689,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
runWhereIs =
runLogger
. runAppState
runAppState
. runE
@'[ NotInstalled
, NoToolVersionSet
@@ -1660,8 +1698,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
let runUpgrade =
runLogger
. runAppState
runAppState
. runResourceT
. runE
@'[ DigestError
@@ -1673,8 +1710,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
let runPrefetch =
runLogger
. runAppState
runAppState
. runResourceT
. runE
@'[ TagNotFound
@@ -1712,25 +1748,25 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "GHC installation successful"
runLogger $ logInfo "GHC installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> myLoggerT loggerConfig $ ($(logError) $ T.pack $ prettyShow err)
_ -> myLoggerT loggerConfig $ ($(logError) $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger $ (logError $ T.pack $ prettyShow err)
_ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 3
@@ -1752,18 +1788,18 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "Cabal installation successful"
runLogger $ logInfo "Cabal installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm cabal " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
let installHLS InstallOptions{..} =
@@ -1784,12 +1820,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "HLS installation successful"
runLogger $ logInfo "HLS installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"HLS ver "
<> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm hls "
@@ -1798,8 +1834,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
let installStack InstallOptions{..} =
@@ -1820,18 +1856,18 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "Stack installation successful"
runLogger $ logInfo "Stack installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"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
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
@@ -1845,11 +1881,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo) $
$ logInfo $
"GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 5
let setCabal' SetOptions{ sToolVer } =
@@ -1863,11 +1899,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo) $
$ logInfo $
"Cabal " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
let setHLS' SetOptions{ sToolVer } =
@@ -1881,11 +1917,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo) $
$ logInfo $
"HLS " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
let setStack' SetOptions{ sToolVer } =
@@ -1899,11 +1935,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo) $
$ logInfo $
"Stack " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
@@ -1916,10 +1952,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 7
let rmCabal' tv =
@@ -1932,10 +1968,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
let rmHLS' tv =
@@ -1948,10 +1984,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
let rmStack' tv =
@@ -1964,31 +2000,31 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
res <- case optCommand of
#if defined(BRICK)
Interactive -> do
s' <- appState
liftIO $ brickMain s' loggerConfig >> pure ExitSuccess
liftIO $ brickMain s' >> pure ExitSuccess
#endif
Install (Right iopts) -> do
runLogger ($(logWarn) "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
Install (Left (InstallGHC iopts)) -> installGHC iopts
Install (Left (InstallCabal iopts)) -> installCabal iopts
Install (Left (InstallHLS iopts)) -> installHLS iopts
Install (Left (InstallStack iopts)) -> installStack iopts
InstallCabalLegacy iopts -> do
runLogger ($(logWarn) "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
Set (Right sopts) -> do
runLogger ($(logWarn) "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
Set (Left (SetGHC sopts)) -> setGHC' sopts
Set (Left (SetCabal sopts)) -> setCabal' sopts
@@ -2003,7 +2039,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
Rm (Right rmopts) -> do
runLogger ($(logWarn) "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
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
@@ -2017,11 +2053,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
putStrLn $ prettyDebugInfo dinfo
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 8
Compile (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
runLogger $ $(logError) "Hadrian cross compile support is not yet implemented!"
runLogger $ logError "Hadrian cross compile support is not yet implemented!"
pure $ ExitFailure 9
Compile (CompileGHC GHCCompileOptions {..}) ->
runCompileGHC (do
@@ -2030,8 +2066,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ $(logInfo) msg
lift $ $(logInfo)
lift $ logInfo msg
lift $ logInfo
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure ()
@@ -2054,32 +2090,32 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight (vi, tv) -> do
runLogger $ $(logInfo)
runLogger $ logInfo
"GHC successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
putStr (T.unpack $ tVerToText tv)
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> myLoggerT loggerConfig $ $(logError) $ T.pack $ prettyShow err
_ -> myLoggerT loggerConfig $ ($(logError) $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 9
Config InitConfig -> do
path <- getConfigFilePath
writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
runLogger $ $(logDebug) $ "config.yaml initialized at " <> T.pack path
runLogger $ logDebug $ "config.yaml initialized at " <> T.pack path
pure ExitSuccess
Config ShowConfig -> do
@@ -2089,20 +2125,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Config (SetConfig k v) -> do
case v of
"" -> do
runLogger $ $(logError) "Empty values are not allowed"
runLogger $ logError "Empty values are not allowed"
pure $ ExitFailure 55
_ -> do
r <- runE @'[JSONError] $ do
settings' <- updateSettings (UTF8.fromString (k <> ": " <> v <> "\n")) settings
path <- liftIO getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
runLogger $ $(logDebug) $ T.pack $ show settings'
runLogger $ logDebug $ T.pack $ show settings'
pure ()
case r of
VRight _ -> pure ExitSuccess
VLeft (V (JSONDecodeError e)) -> do
runLogger $ $(logError) $ "Error decoding config: " <> T.pack e
runLogger $ logError $ "Error decoding config: " <> T.pack e
pure $ ExitFailure 65
VLeft _ -> pure $ ExitFailure 65
@@ -2118,7 +2154,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
Whereis WhereisOptions{..} (WhereisTool tool whereVer) ->
@@ -2134,9 +2170,29 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
Whereis _ WhereisBaseDir -> do
putStr baseDir
pure ExitSuccess
Whereis _ WhereisBinDir -> do
putStr binDir
pure ExitSuccess
Whereis _ WhereisCacheDir -> do
putStr cacheDir
pure ExitSuccess
Whereis _ WhereisLogsDir -> do
putStr logsDir
pure ExitSuccess
Whereis _ WhereisConfDir -> do
putStr confDir
pure ExitSuccess
Upgrade uOpts force' -> do
target <- case uOpts of
UpgradeInplace -> Just <$> liftIO getExecutablePath
@@ -2151,23 +2207,22 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight (v', dls) -> do
let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ $(logInfo) $
runLogger $ logInfo $
"Successfully upgraded GHCup to version " <> pretty_v
forM_ (_viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V NoUpdate) -> do
runLogger $ $(logWarn) "No GHCup update available"
runLogger $ logWarn "No GHCup update available"
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 11
ToolRequirements -> do
s' <- appState
flip runReaderT s'
$ runLogger
(runE
$ (runE
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do
GHCupInfo { .. } <- lift getGHCupInfo
@@ -2178,7 +2233,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 12
ChangeLog ChangeLogOptions{..} -> do
@@ -2195,7 +2250,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
case muri of
Nothing -> do
runLogger
($(logWarn) $
(logWarn $
"Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver'
)
pure ExitSuccess
@@ -2218,7 +2273,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nothing
>>= \case
Right _ -> pure ExitSuccess
Left e -> runLogger ($(logError) (T.pack $ prettyShow e))
Left e -> logError (T.pack $ prettyShow e)
>> pure (ExitFailure 13)
else putStrLn uri' >> pure ExitSuccess
@@ -2226,12 +2281,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
s' <- liftIO appState
void $ liftIO $ evaluate $ force s'
runNuke s' (do
lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
lift $ logWarn "WARNING: This will remove GHCup and all installed components from your system."
lift $ logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
liftIO $ threadDelay 10000000 -- wait 10s
lift $ $logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ $logInfo "Nuking in 3...2...1"
lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ logInfo "Nuking in 3...2...1"
lInstalled <- lift $ listVersions Nothing (Just ListInstalled)
@@ -2242,15 +2297,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
) >>= \case
VRight leftOverFiles
| null leftOverFiles -> do
runLogger $ $logInfo "Nuclear Annihilation complete!"
runLogger $ logInfo "Nuclear Annihilation complete!"
pure ExitSuccess
| otherwise -> do
runLogger $ $logError "These Files have survived Nuclear Annihilation, you may remove them manually."
runLogger $ logError "These Files have survived Nuclear Annihilation, you may remove them manually."
forM_ leftOverFiles putStrLn
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
Prefetch pfCom ->
runPrefetch (do
@@ -2281,7 +2336,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
@@ -2292,7 +2347,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ()
fromVersion :: ( MonadLogger m
fromVersion :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
@@ -2310,7 +2365,7 @@ fromVersion :: ( MonadLogger m
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion tv = fromVersion' (toSetToolVer tv)
fromVersion' :: ( MonadLogger m
fromVersion' :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
@@ -2556,11 +2611,10 @@ checkForUpdates :: ( MonadReader env m
, HasDirs env
, HasPlatformReq env
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadIO m
, MonadFail m
, MonadLogger m
)
=> m ()
checkForUpdates = do
@@ -2571,35 +2625,35 @@ checkForUpdates = do
forM_ (getLatest dls GHCup) $ \(l, _) -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver)
$ $(logWarn) $
$ logWarn $
"New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'"
forM_ (getLatest dls GHC) $ \(l, _) -> do
let mghc_ver = latestInstalled GHC
forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver)
$ $(logWarn) $
$ logWarn $
"New GHC version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install ghc " <> prettyVer l <> "'"
forM_ (getLatest dls Cabal) $ \(l, _) -> do
let mcabal_ver = latestInstalled Cabal
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
$ $(logWarn) $
$ logWarn $
"New Cabal version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install cabal " <> prettyVer l <> "'"
forM_ (getLatest dls HLS) $ \(l, _) -> do
let mhls_ver = latestInstalled HLS
forM mhls_ver $ \hls_ver ->
when (l > hls_ver)
$ $(logWarn) $
$ logWarn $
"New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'"
forM_ (getLatest dls Stack) $ \(l, _) -> do
let mstack_ver = latestInstalled Stack
forM mstack_ver $ \stack_ver ->
when (l > stack_ver)
$ $(logWarn) $
$ logWarn $
"New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'"

View File

@@ -3,6 +3,7 @@
# Main settings:
# * BOOTSTRAP_HASKELL_NONINTERACTIVE - any nonzero value for noninteractive installation
# * BOOTSTRAP_HASKELL_NO_UPGRADE - any nonzero value to not trigger the upgrade
# * BOOTSTRAP_HASKELL_MINIMAL - any nonzero value to only install ghcup
# * GHCUP_USE_XDG_DIRS - any nonzero value to respect The XDG Base Directory Specification
# * BOOTSTRAP_HASKELL_VERBOSE - any nonzero value for more verbose installation
# * BOOTSTRAP_HASKELL_GHC_VERSION - the ghc version to install
@@ -371,6 +372,13 @@ adjust_bashrc() {
echo "[[ -f ~/.bashrc ]] && source ~/.bashrc # ghcup-env" >> "${HOME}/.bash_profile"
fi
;;
MSYS*|MINGW*)
if [ ! -e "${HOME}/.bash_profile" ] ; then
echo '# generated by ghcup' > "${HOME}/.bash_profile"
echo 'test -f ~/.profile && . ~/.profile' >> "${HOME}/.bash_profile"
echo 'test -f ~/.bashrc && . ~/.bashrc' >> "${HOME}/.bash_profile"
fi
;;
esac
break ;;
@@ -591,10 +599,12 @@ ask_bashrc
ask_bashrc_answer=$?
ask_cabal_config_init
ask_cabal_config_init_answer=$?
ask_hls
ask_hls_answer=$?
ask_stack
ask_stack_answer=$?
if [ -z "${BOOTSTRAP_HASKELL_MINIMAL}" ] ; then
ask_hls
ask_hls_answer=$?
ask_stack
ask_stack_answer=$?
fi
edo mkdir -p "${GHCUP_BIN}"
@@ -620,14 +630,30 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
read -r answer </dev/tty
fi
eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
if [ -z "${BOOTSTRAP_HASKELL_MINIMAL}" ] ; then
eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
do_cabal_config_init $ask_cabal_config_init_answer
do_cabal_config_init $ask_cabal_config_init_answer
edo cabal new-update
edo cabal new-update
else # don't install ghc and cabal
case "${plat}" in
MSYS*|MINGW*)
# need to bootstrap cabal to initialize config on windows
# we'll remove it afterwards
tmp_dir="$(mktemp -d)"
eghcup --cache install cabal -i "${tmp_dir}" "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
PATH="${tmp_dir}:$PATH" do_cabal_config_init $ask_cabal_config_init_answer
rm "${tmp_dir}/cabal"
unset tmp_dir
;;
*)
;;
esac
fi
case $ask_hls_answer in
1)

View File

@@ -15,24 +15,26 @@
param (
# Run an interactive installation
[switch]$Interactive,
# Specify the install root (default: 'C:\')
[string]$InstallDir,
# Instead of installing a new MSys2, use an existing installation
[string]$ExistingMsys2Dir,
# Specify the cabal root directory (default: '$InstallDir\cabal')
[string]$CabalDir,
# Overwrite (or rather backup) a previous install
[switch]$Overwrite,
# Specify the bootstrap url (default: 'https://www.haskell.org/ghcup/sh/bootstrap-haskell')
[string]$BootstrapUrl,
# Do minimal installation of ghcup and msys2 only
[switch]$Minimal,
# Run the final bootstrap script via 'bash' instead of a full newly spawned msys2 shell
[switch]$InBash,
# Overwrite (or rather backup) a previous install
[switch]$Overwrite,
# Skip adjusting cabal.config with mingw paths
[switch]$NoAdjustCabalConfig,
# Whether to install stack as well
[switch]$InstallStack,
# Whether to install hls as well
[switch]$InstallHLS,
# Skip adjusting cabal.config with mingw paths
[switch]$NoAdjustCabalConfig
# Specify the bootstrap url (default: 'https://www.haskell.org/ghcup/sh/bootstrap-haskell')
[string]$InstallDir,
# Instead of installing a new MSys2, use an existing installation
[string]$BootstrapUrl,
# Specify the install root (default: 'C:\')
[string]$ExistingMsys2Dir,
# Specify the cabal root directory (default: '$InstallDir\cabal')
[string]$CabalDir
)
$Silent = !$Interactive
@@ -180,7 +182,7 @@ elevated command prompt:
if ($GhcupBasePrefixEnv) {
$defaultGhcupBasePrefix = $GhcupBasePrefixEnv
} else {
} elseif (!($InstallDir)) {
$partitions = Get-CimInstance win32_logicaldisk
$defaultGhcupBasePrefix = $null
foreach ($p in $partitions){
@@ -209,10 +211,10 @@ if ($Silent -and !($InstallDir)) {
$GhcupBasePrefix = $defaultGhcupBasePrefix
} elseif ($InstallDir) {
if (!(Test-Path -LiteralPath ('{0}' -f $InstallDir) -IsValid)) {
Print-Msg -color Red -msg "Not a valid directory!"
Print-Msg -color Red -msg "Not a valid directory! (InstallDir)"
Exit 1
} elseif (!(Split-Path -IsAbsolute -Path "$InstallDir")) {
Print-Msg -color Red -msg "Non-absolute Path specified!"
Print-Msg -color Red -msg "Non-absolute Path specified! (InstallDir)"
Exit 1
} else {
$GhcupBasePrefix = $InstallDir
@@ -243,7 +245,20 @@ $null = [Environment]::SetEnvironmentVariable("GHCUP_INSTALL_BASE_PREFIX", $Ghcu
$GhcupDir = ('{0}\ghcup' -f $GhcupBasePrefix)
$MsysDir = ('{0}\msys64' -f $GhcupDir)
if ($ExistingMsys2Dir) {
if (!(Test-Path -LiteralPath ('{0}' -f $ExistingMsys2Dir) -IsValid)) {
Print-Msg -color Red -msg "Not a valid directory! (ExistingMsys2Dir)"
Exit 1
} elseif (!(Split-Path -IsAbsolute -Path "$ExistingMsys2Dir")) {
Print-Msg -color Red -msg "Non-absolute Path specified! (ExistingMsys2Dir)"
Exit 1
} else {
$MsysDir = $ExistingMsys2Dir
}
} else {
$MsysDir = ('{0}\msys64' -f $GhcupDir)
}
$Bash = ('{0}\usr\bin\bash' -f $MsysDir)
if (!($BootstrapUrl)) {
$BootstrapUrl = 'https://www.haskell.org/ghcup/sh/bootstrap-haskell'
@@ -398,6 +413,7 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
Print-Msg -msg 'Setting default home directory...'
Exec "$Bash" '-lc' "sed -i -e 's/db_home:.*$/db_home: windows/' /etc/nsswitch.conf"
} elseif ($msys2Decision -eq 1) {
Print-Msg -color Yellow -msg 'Skipping MSys2 installation.'
while ($true) {
@@ -529,10 +545,14 @@ if (!($NoAdjustCabalConfig)) {
$AdjustCabalConfigExport = 'export BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG=1 ;'
}
if ($Minimal) {
$MinimalExport = 'export BOOTSTRAP_HASKELL_MINIMAL=1 ;'
}
if ((Get-Process -ID $PID).ProcessName.StartsWith("bootstrap-haskell") -Or $InBash) {
Exec "$Bash" '-lc' ('{4} {6} {7} {8} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; [[ ''{0}'' = https* ]] && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport)
Exec "$Bash" '-lc' ('{4} {6} {7} {8} {9} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; [[ ''{0}'' = https* ]] && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport)
} else {
Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} {6} {7} {8} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; [[ ''{0}'' = https* ]] && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport)
Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} {6} {7} {8} {9} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; [[ ''{0}'' = https* ]] && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport)
}

View File

@@ -8,26 +8,27 @@ package ghcup
tests: True
flags: +tui
source-repository-package
type: git
location: https://github.com/jtdaugherty/brick.git
tag: b3b96cfe66dfd398d338e3feb2b6855e66a35190
source-repository-package
type: git
location: https://github.com/Bodigrim/tar
tag: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
source-repository-package
type: git
location: https://github.com/bgamari/terminal-size
tag: 34ea816bd63f75f800eedac12c6908c6f3736036
source-repository-package
type: git
location: https://github.com/hasufell/libarchive
tag: 8587aab78dd515928024ecd82c8f215e06db85cd
constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
package aeson-pretty
flags: +lib-only
package cabal-plan
flags: -exe
allow-newer: base, ghc-prim, template-haskell, language-c
with-compiler: ghc-8.10.5
with-compiler: ghc-8.10.7

View File

@@ -1,15 +1,18 @@
active-repositories: hackage.haskell.org:merge
constraints: any.Cabal ==3.2.1.0,
any.HUnit ==1.6.2.0,
any.HsOpenSSL ==0.11.7,
any.HsOpenSSL ==0.11.7.1,
HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
any.HsYAML ==0.2.1.0,
HsYAML -exe,
any.HsYAML-aeson ==0.2.0.0,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.2,
any.aeson ==1.5.6.0,
aeson -bytestring-builder -cffi -developer -fast,
any.aeson-pretty ==0.8.8,
aeson-pretty -lib-only,
aeson-pretty +lib-only,
any.alex ==3.2.6,
alex +small_base,
any.ansi-terminal ==0.11,
@@ -22,8 +25,7 @@ constraints: any.Cabal ==3.2.1.0,
async -bench,
any.attoparsec ==0.13.2.5,
attoparsec -developer,
any.auto-update ==0.1.6,
any.base ==4.14.2.0,
any.base ==4.14.3.0,
any.base-compat ==0.11.2,
any.base-compat-batteries ==0.11.2,
any.base-orphans ==0.8.4,
@@ -32,41 +34,34 @@ constraints: any.Cabal ==3.2.1.0,
any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged,
any.binary ==0.8.8.0,
any.bindings-DSL ==1.0.25,
any.blaze-builder ==0.4.2.1,
any.brick ==0.63,
any.brick ==0.64,
brick -demos,
any.bytestring ==0.10.12.0,
any.bz2 ==1.0.1.0,
bz2 -cross +with-bzlib,
any.bzlib-conduit ==0.3.0.2,
any.c2hs ==0.28.8,
c2hs +base3 -regression,
any.cabal-plan ==0.7.2.0,
cabal-plan -_ -exe -license-report,
any.call-stack ==0.4.0,
any.case-insensitive ==1.2.1.0,
any.casing ==0.1.4.1,
any.cereal ==0.5.8.1,
cereal -bytestring-builder,
any.chs-cabal ==0.1.1.0,
any.chs-deps ==0.1.0.0,
chs-deps -cross,
any.clock ==0.8.2,
clock -llvm,
any.cmdargs ==0.10.21,
cmdargs +quotation -testprog,
any.colour ==2.3.6,
any.comonad ==5.0.8,
comonad +containers +distributive +indexed-traversable,
any.composition-prelude ==3.0.0.2,
composition-prelude -development,
any.concurrent-output ==1.10.12,
any.conduit ==1.3.4.1,
any.conduit-extra ==1.3.5,
any.conduit-zstd ==0.0.2.0,
any.config-ini ==0.2.4.0,
config-ini -enable-doctests,
any.containers ==0.6.4.1,
any.contravariant ==1.5.4,
any.containers ==0.6.5.1,
any.contravariant ==1.5.5,
contravariant +semigroups +statevar +tagged,
any.cpphs ==1.20.9.1,
cpphs -old-locale,
@@ -74,44 +69,32 @@ constraints: any.Cabal ==3.2.1.0,
any.cryptohash-sha256 ==0.11.102.0,
cryptohash-sha256 -exe +use-cbits,
any.data-clist ==0.1.2.3,
any.data-default-class ==0.1.2.0,
any.data-fix ==0.3.1,
any.data-fix ==0.3.2,
any.deepseq ==1.4.4.0,
any.digest ==0.0.1.3,
digest -bytestring-in-base,
any.directory ==1.3.6.0,
any.disk-free-space ==0.1.0.1,
any.distributive ==0.6.2.1,
distributive +semigroups +tagged,
any.dlist ==1.0,
dlist -werror,
any.easy-file ==0.2.2,
any.errors ==2.3.0,
any.exceptions ==0.10.4,
any.extra ==1.7.9,
any.fast-logger ==3.0.5,
any.filepath ==1.4.2.1,
any.free ==5.1.7,
any.generic-arbitrary ==0.1.0,
any.generics-sop ==0.5.1.1,
any.ghc-boot-th ==8.10.5,
any.ghc-boot-th ==8.10.7,
any.ghc-byteorder ==4.11.0.0.10,
any.ghc-prim ==0.6.1,
any.happy ==1.20.0,
any.hashable ==1.3.2.0,
any.hashable ==1.3.3.0,
hashable +integer-gmp -random-initial-seed,
any.haskell-src-exts ==1.23.1,
any.haskell-src-meta ==0.8.7,
any.haskus-utils-data ==1.4,
any.haskus-utils-types ==1.5.1,
any.haskus-utils-variant ==3.1,
any.hpath-filepath ==0.10.4,
any.hpath-posix ==0.13.3,
any.hsc2hs ==0.68.7,
hsc2hs -in-ghc-tree,
any.hspec ==2.7.10,
any.hspec-core ==2.7.10,
any.hspec-discover ==2.7.10 || ==2.8.2,
any.hspec-discover ==2.7.10 || ==2.8.3,
any.hspec-expectations ==0.8.2,
any.hspec-golden-aeson ==0.9.0.0,
any.http-io-streams ==0.1.6.0,
@@ -128,34 +111,22 @@ constraints: any.Cabal ==3.2.1.0,
language-c -allwarnings +iecfpextension +usebytestrings,
any.libarchive ==3.0.2.2,
libarchive -cross -low-memory -system-libarchive,
any.libyaml ==0.1.2,
libyaml -no-unicode -system-libyaml,
any.lifted-base ==0.2.3.12,
any.lzma-static ==5.2.5.4,
any.megaparsec ==9.0.1,
megaparsec -dev,
any.microlens ==0.4.12.0,
any.microlens-mtl ==0.2.0.1,
any.microlens-th ==0.4.3.10,
any.monad-control ==1.0.3,
any.monad-logger ==0.3.36,
monad-logger +template_haskell,
any.monad-loops ==0.4.3,
monad-loops +base4,
any.mono-traversable ==1.0.15.1,
any.mtl ==2.2.2,
any.network ==3.1.2.2,
network -devel,
any.network-uri ==2.6.4.1,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.openssl-streams ==1.2.3.0,
any.optics ==0.4,
any.optics-core ==0.4,
optics-core -explicit-generic-labels,
any.optics-extra ==0.4,
any.optics-th ==0.4,
any.optics-vl ==0.2.1,
any.optparse-applicative ==0.16.1.0,
optparse-applicative +process,
any.os-release ==1.0.2,
@@ -167,8 +138,8 @@ constraints: any.Cabal ==3.2.1.0,
any.polyparse ==1.13,
any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0,
any.primitive ==0.7.1.0,
any.process ==1.6.9.0,
any.primitive ==0.7.2.0,
any.process ==1.6.13.2,
any.profunctors ==5.6.2,
any.quickcheck-arbitrary-adt ==0.3.1.0,
any.quickcheck-io ==0.2.0,
@@ -178,7 +149,7 @@ constraints: any.Cabal ==3.2.1.0,
any.regex-base ==0.94.0.1,
any.regex-posix ==0.96.0.1,
regex-posix -_regex-posix-clib,
any.resourcet ==1.2.4.2,
any.resourcet ==1.2.4.3,
any.rts ==1.0.1,
any.safe ==0.3.19,
any.safe-exceptions ==0.1.7.2,
@@ -187,55 +158,41 @@ constraints: any.Cabal ==3.2.1.0,
any.semigroupoids ==5.3.5,
semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
any.setenv ==0.1.1.3,
any.sop-core ==0.5.0.1,
any.split ==0.2.3.4,
any.splitmix ==0.1.0.3,
splitmix -optimised-mixer,
any.stm ==2.5.0.1,
any.stm-chans ==3.0.0.4,
any.streaming-commons ==0.2.2.1,
streaming-commons -use-bytestring-builder,
any.strict ==0.4.0.1,
strict +assoc,
any.strict-base ==0.4.0.0,
any.string-interpolate ==0.3.1.1,
string-interpolate -bytestring-builder -extended-benchmarks -text-builder,
any.syb ==0.7.2.1,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tar ==0.6.0.0,
any.template-haskell ==2.16.0.0,
any.temporary ==1.3,
any.terminal-progress-bar ==0.4.1,
any.terminal-size ==0.3.2.1,
any.terminfo ==0.4.1.4,
any.text ==1.2.4.1,
any.text-conversions ==0.3.1,
any.text-zipper ==0.11,
any.tf-random ==0.5,
any.th-abstraction ==0.4.2.0,
any.th-compat ==0.1.2,
any.th-expand-syns ==0.4.8.0,
any.th-lift ==0.8.2,
any.th-lift-instances ==0.1.18,
any.th-orphans ==0.13.11,
any.th-reify-many ==0.1.9,
any.these ==1.1.1.1,
these +assoc,
any.time ==1.9.3,
any.time-compat ==1.9.6,
time-compat -old-locale,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.5.2,
any.transformers-base ==0.4.6,
transformers-base +orphaninstances,
any.transformers-compat ==0.7,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.typed-process ==0.2.6.0,
any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.3,
any.unix-compat ==0.5.3,
unix-compat -old-time,
any.unix-time ==0.4.7,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.14.0,
unordered-containers -debug,
@@ -245,20 +202,12 @@ constraints: any.Cabal ==3.2.1.0,
any.uuid-types ==1.0.5,
any.vector ==0.12.3.0,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.vector-algorithms ==0.8.0.4,
vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
any.versions ==5.0.0,
any.vty ==5.33,
any.word-wrap ==0.4.1,
any.word8 ==0.1.3,
any.xor ==0.0.1.0,
any.yaml ==0.11.5.0,
yaml +no-examples +no-exe,
any.zip ==1.7.1,
zip -dev -disable-bzip2 -disable-zstd,
any.zlib ==0.6.2.3,
zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5,
any.zstd ==0.1.2.0,
zstd +standalone
index-state: hackage.haskell.org 2021-07-27T07:59:57Z
any.zlib-bindings ==0.1.1.5
index-state: hackage.haskell.org 2021-08-29T16:24:29Z

View File

@@ -8,26 +8,27 @@ package ghcup
tests: True
flags: +tui
source-repository-package
type: git
location: https://github.com/jtdaugherty/brick.git
tag: b3b96cfe66dfd398d338e3feb2b6855e66a35190
source-repository-package
type: git
location: https://github.com/Bodigrim/tar
tag: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
source-repository-package
type: git
location: https://github.com/bgamari/terminal-size
tag: 34ea816bd63f75f800eedac12c6908c6f3736036
source-repository-package
type: git
location: https://github.com/hasufell/libarchive
tag: 8587aab78dd515928024ecd82c8f215e06db85cd
constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
package aeson-pretty
flags: +lib-only
package cabal-plan
flags: -exe
allow-newer: base, ghc-prim, template-haskell, language-c
with-compiler: ghc-9.0.1

View File

@@ -1,15 +1,18 @@
active-repositories: hackage.haskell.org:merge
constraints: any.Cabal ==3.4.0.0,
any.HUnit ==1.6.2.0,
any.HsOpenSSL ==0.11.7,
any.HsOpenSSL ==0.11.7.1,
HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
any.HsYAML ==0.2.1.0,
HsYAML -exe,
any.HsYAML-aeson ==0.2.0.0,
any.QuickCheck ==2.14.2,
QuickCheck -old-random +templatehaskell,
any.StateVar ==1.2.2,
any.aeson ==1.5.6.0,
aeson -bytestring-builder -cffi -developer -fast,
any.aeson-pretty ==0.8.8,
aeson-pretty -lib-only,
aeson-pretty +lib-only,
any.alex ==3.2.6,
alex +small_base,
any.ansi-terminal ==0.11,
@@ -22,7 +25,6 @@ constraints: any.Cabal ==3.4.0.0,
async -bench,
any.attoparsec ==0.13.2.5,
attoparsec -developer,
any.auto-update ==0.1.6,
any.base ==4.15.0.0,
any.base-compat ==0.11.2,
any.base-compat-batteries ==0.11.2,
@@ -32,41 +34,34 @@ constraints: any.Cabal ==3.4.0.0,
any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged,
any.binary ==0.8.8.0,
any.bindings-DSL ==1.0.25,
any.blaze-builder ==0.4.2.1,
any.brick ==0.63,
any.brick ==0.64,
brick -demos,
any.bytestring ==0.10.12.1,
any.bz2 ==1.0.1.0,
bz2 -cross +with-bzlib,
any.bzlib-conduit ==0.3.0.2,
any.c2hs ==0.28.8,
c2hs +base3 -regression,
any.cabal-plan ==0.7.2.0,
cabal-plan -_ -exe -license-report,
any.call-stack ==0.4.0,
any.case-insensitive ==1.2.1.0,
any.casing ==0.1.4.1,
any.cereal ==0.5.8.1,
cereal -bytestring-builder,
any.chs-cabal ==0.1.1.0,
any.chs-deps ==0.1.0.0,
chs-deps -cross,
any.clock ==0.8.2,
clock -llvm,
any.cmdargs ==0.10.21,
cmdargs +quotation -testprog,
any.colour ==2.3.6,
any.comonad ==5.0.8,
comonad +containers +distributive +indexed-traversable,
any.composition-prelude ==3.0.0.2,
composition-prelude -development,
any.concurrent-output ==1.10.12,
any.conduit ==1.3.4.1,
any.conduit-extra ==1.3.5,
any.conduit-zstd ==0.0.2.0,
any.config-ini ==0.2.4.0,
config-ini -enable-doctests,
any.containers ==0.6.4.1,
any.contravariant ==1.5.4,
any.contravariant ==1.5.5,
contravariant +semigroups +statevar +tagged,
any.cpphs ==1.20.9.1,
cpphs -old-locale,
@@ -74,45 +69,33 @@ constraints: any.Cabal ==3.4.0.0,
any.cryptohash-sha256 ==0.11.102.0,
cryptohash-sha256 -exe +use-cbits,
any.data-clist ==0.1.2.3,
any.data-default-class ==0.1.2.0,
any.data-fix ==0.3.1,
any.data-fix ==0.3.2,
any.deepseq ==1.4.5.0,
any.digest ==0.0.1.3,
digest -bytestring-in-base,
any.directory ==1.3.6.1,
any.disk-free-space ==0.1.0.1,
any.distributive ==0.6.2.1,
distributive +semigroups +tagged,
any.dlist ==1.0,
dlist -werror,
any.easy-file ==0.2.2,
any.errors ==2.3.0,
any.exceptions ==0.10.4,
any.extra ==1.7.9,
any.fast-logger ==3.0.5,
any.filepath ==1.4.2.1,
any.free ==5.1.7,
any.generic-arbitrary ==0.1.0,
any.generics-sop ==0.5.1.1,
any.ghc-bignum ==1.0,
any.ghc-boot-th ==9.0.1,
any.ghc-byteorder ==4.11.0.0.10,
any.ghc-prim ==0.7.0,
any.happy ==1.20.0,
any.hashable ==1.3.2.0,
any.hashable ==1.3.3.0,
hashable +integer-gmp -random-initial-seed,
any.haskell-src-exts ==1.23.1,
any.haskell-src-meta ==0.8.7,
any.haskus-utils-data ==1.4,
any.haskus-utils-types ==1.5.1,
any.haskus-utils-variant ==3.1,
any.hpath-filepath ==0.10.4,
any.hpath-posix ==0.13.3,
any.hsc2hs ==0.68.7,
hsc2hs -in-ghc-tree,
any.hspec ==2.7.10,
any.hspec-core ==2.7.10,
any.hspec-discover ==2.7.10 || ==2.8.2,
any.hspec-discover ==2.7.10 || ==2.8.3,
any.hspec-expectations ==0.8.2,
any.hspec-golden-aeson ==0.9.0.0,
any.http-io-streams ==0.1.6.0,
@@ -128,34 +111,22 @@ constraints: any.Cabal ==3.4.0.0,
language-c -allwarnings +iecfpextension +usebytestrings,
any.libarchive ==3.0.2.2,
libarchive -cross -low-memory -system-libarchive,
any.libyaml ==0.1.2,
libyaml -no-unicode -system-libyaml,
any.lifted-base ==0.2.3.12,
any.lzma-static ==5.2.5.4,
any.megaparsec ==9.0.1,
megaparsec -dev,
any.microlens ==0.4.12.0,
any.microlens-mtl ==0.2.0.1,
any.microlens-th ==0.4.3.10,
any.monad-control ==1.0.3,
any.monad-logger ==0.3.36,
monad-logger +template_haskell,
any.monad-loops ==0.4.3,
monad-loops +base4,
any.mono-traversable ==1.0.15.1,
any.mtl ==2.2.2,
any.network ==3.1.2.2,
network -devel,
any.network-uri ==2.6.4.1,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.openssl-streams ==1.2.3.0,
any.optics ==0.4,
any.optics-core ==0.4,
optics-core -explicit-generic-labels,
any.optics-extra ==0.4,
any.optics-th ==0.4,
any.optics-vl ==0.2.1,
any.optparse-applicative ==0.16.1.0,
optparse-applicative +process,
any.os-release ==1.0.2,
@@ -167,7 +138,7 @@ constraints: any.Cabal ==3.4.0.0,
any.polyparse ==1.13,
any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0,
any.primitive ==0.7.1.0,
any.primitive ==0.7.2.0,
any.process ==1.6.11.0,
any.profunctors ==5.6.2,
any.quickcheck-arbitrary-adt ==0.3.1.0,
@@ -178,7 +149,7 @@ constraints: any.Cabal ==3.4.0.0,
any.regex-base ==0.94.0.1,
any.regex-posix ==0.96.0.1,
regex-posix -_regex-posix-clib,
any.resourcet ==1.2.4.2,
any.resourcet ==1.2.4.3,
any.rts ==1.0,
any.safe ==0.3.19,
any.safe-exceptions ==0.1.7.2,
@@ -187,55 +158,41 @@ constraints: any.Cabal ==3.4.0.0,
any.semigroupoids ==5.3.5,
semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
any.setenv ==0.1.1.3,
any.sop-core ==0.5.0.1,
any.split ==0.2.3.4,
any.splitmix ==0.1.0.3,
splitmix -optimised-mixer,
any.stm ==2.5.0.0,
any.stm-chans ==3.0.0.4,
any.streaming-commons ==0.2.2.1,
streaming-commons -use-bytestring-builder,
any.strict ==0.4.0.1,
strict +assoc,
any.strict-base ==0.4.0.0,
any.string-interpolate ==0.3.1.1,
string-interpolate -bytestring-builder -extended-benchmarks -text-builder,
any.syb ==0.7.2.1,
any.tagged ==0.8.6.1,
tagged +deepseq +transformers,
any.tar ==0.6.0.0,
any.template-haskell ==2.17.0.0,
any.temporary ==1.3,
any.terminal-progress-bar ==0.4.1,
any.terminal-size ==0.3.2.1,
any.terminfo ==0.4.1.4,
any.text ==1.2.4.1,
any.text-conversions ==0.3.1,
any.text-zipper ==0.11,
any.tf-random ==0.5,
any.th-abstraction ==0.4.2.0,
any.th-compat ==0.1.2,
any.th-expand-syns ==0.4.8.0,
any.th-lift ==0.8.2,
any.th-lift-instances ==0.1.18,
any.th-orphans ==0.13.11,
any.th-reify-many ==0.1.9,
any.these ==1.1.1.1,
these +assoc,
any.time ==1.9.3,
any.time-compat ==1.9.6,
time-compat -old-locale,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.5.2,
any.transformers-base ==0.4.6,
transformers-base +orphaninstances,
any.transformers-compat ==0.7,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.typed-process ==0.2.6.0,
any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.3,
any.unix-compat ==0.5.3,
unix-compat -old-time,
any.unix-time ==0.4.7,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.14.0,
unordered-containers -debug,
@@ -245,20 +202,12 @@ constraints: any.Cabal ==3.4.0.0,
any.uuid-types ==1.0.5,
any.vector ==0.12.3.0,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.vector-algorithms ==0.8.0.4,
vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
any.versions ==5.0.0,
any.vty ==5.33,
any.word-wrap ==0.4.1,
any.word8 ==0.1.3,
any.xor ==0.0.1.0,
any.yaml ==0.11.5.0,
yaml +no-examples +no-exe,
any.zip ==1.7.1,
zip -dev -disable-bzip2 -disable-zstd,
any.zlib ==0.6.2.3,
zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5,
any.zstd ==0.1.2.0,
zstd +standalone
index-state: hackage.haskell.org 2021-07-27T07:59:57Z
any.zlib-bindings ==0.1.1.5
index-state: hackage.haskell.org 2021-08-29T16:24:29Z

View File

@@ -16,11 +16,17 @@ source-repository-package
source-repository-package
type: git
location: https://github.com/hasufell/libarchive
tag: 024a7e8ab7b4d3848dc64dca1e70a04831eedc99
tag: 8587aab78dd515928024ecd82c8f215e06db85cd
constraints: http-io-streams -brotli
package libarchive
flags: -system-libarchive
package aeson-pretty
flags: +lib-only
package cabal-plan
flags: -exe
allow-newer: base, ghc-prim, template-haskell, language-c

View File

@@ -1690,7 +1690,6 @@ ghcupDownloads:
dlHash: 56170d1a8450e18b7eb9c23c94723da352815b27ec250bb23742a62f16dcab6c
8.10.6:
viTags:
- Recommended
- base-4.14.3.0
viChangeLog: https://downloads.haskell.org/~ghc/8.10.6/docs/html/users_guide/8.10.6-notes.html
viSourceDL:
@@ -1789,6 +1788,107 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.10.6/ghc-8.10.6-armv7-deb10-linux.tar.xz
dlSubdir: ghc-8.10.6
dlHash: d54de8306aa8b33afabf2ac94408e1f82c8e982a2a3346168c071b92bdb464c0
8.10.7:
viTags:
- Recommended
- base-4.14.3.0
viChangeLog: https://downloads.haskell.org/~ghc/8.10.7/docs/html/users_guide/8.10.7-notes.html
viSourceDL:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-src.tar.xz
dlSubdir: ghc-8.10.7
dlHash: e3eef6229ce9908dfe1ea41436befb0455fefb1932559e860ad4c606b0d03c9d
viPostRemove: *ghc-post-remove
viPreCompile: *ghc-pre-compile
viArch:
A_64:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-8107-64-deb9
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-deb9-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: ced9870ea351af64fb48274b81a664cdb6a9266775f1598a79cbb6fdd5770a23
'( >= 10 && < 11 )': &ghc-8107-64-deb10
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-deb10-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: a13719bca87a0d3ac0c7d4157a4e60887009a7f1a8dbe95c4759ec413e086d30
unknown_versioning: *ghc-8107-64-deb9
Linux_Ubuntu:
unknown_versioning: &ghc-8107-64-fedora
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-fedora27-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: b6ed67049a23054a8042e65c9976d5e196e5ee4e83b29b2ee35c8a22ab1e5b73
'( >= 16 && < 19 )': *ghc-8107-64-deb9
Linux_Mint:
unknown_versioning: *ghc-8107-64-deb10
Linux_Fedora:
'( >= 27 && < 28 )': *ghc-8107-64-fedora
unknown_versioning: *ghc-8107-64-fedora
Linux_CentOS:
'( >= 7 && < 8 )': &ghc-8107-64-centos
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-centos7-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: 262a50bfb5b7c8770e0d99f54d42e5876968da7bf93e2e4d6cfe397891a36d05
unknown_versioning: *ghc-8107-64-centos
Linux_RedHat:
unknown_versioning: *ghc-8107-64-centos
Linux_Alpine:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-alpine3.10-linux-integer-simple.tar.xz
dlSubdir: ghc-8.10.7-x86_64-unknown-linux
dlHash: 16903df850ef73d5246f2ff169cbf57ecab76c2ac5acfa9928934282cfad575c
Linux_AmazonLinux:
unknown_versioning: *ghc-8107-64-centos
Linux_UnknownLinux:
unknown_versioning: *ghc-8107-64-fedora
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-apple-darwin.tar.xz
dlSubdir: ghc-8.10.7
dlHash: 287db0f9c338c9f53123bfa8731b0996803ee50f6ee847fe388092e5e5132047
FreeBSD:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-unknown-freebsd.tar.xz
dlSubdir: ghc-8.10.7
dlHash: 45e35d24bc700e1093efa39189e9fa01498069881aed2fa8779c011941a80da1
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.10.7
dlHash: b6515b0ea3f7a6e34d92e7fcd0c1fef50d6030fe8f46883000185289a4b8ea9a
A_32:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-8107-32-deb9
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-i386-deb9-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: fbfc1ef194f4e7a4c0da8c11cc69b17458a4b928b609b3622c97acc4acd5c5ab
unknown_versioning: *ghc-8107-32-deb9
Linux_Ubuntu:
unknown_versioning: *ghc-8107-32-deb9
Linux_Mint:
unknown_versioning: *ghc-8107-32-deb9
Linux_UnknownLinux:
unknown_versioning: *ghc-8107-32-deb9
Linux_Alpine:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/unofficial-bindists/ghc/8.10.7/ghc-8.10.7-i386-alpine-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: 3110e6ee029d9d8062158b54b06f71a21b0fac87bf0e085f9be5bbcf73f99e6d
A_ARM64:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-aarch64-deb10-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: fad2417f9b295233bf8ade79c0e6140896359e87be46cb61cd1d35863d9d0e55
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-aarch64-apple-darwin.tar.xz
dlSubdir: ghc-8.10.7
dlHash: dc469fc3c35fd2a33a5a575ffce87f13de7b98c2d349a41002e200a56d9bba1c
A_ARM:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-armv7-deb10-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: 3949c31bdf7d3b4afb765ea8246bca4ca9707c5d988d9961a244f0da100956a2
9.0.1:
viTags:
- Latest

View File

@@ -1746,7 +1746,6 @@ ghcupDownloads:
dlHash: 56170d1a8450e18b7eb9c23c94723da352815b27ec250bb23742a62f16dcab6c
8.10.6:
viTags:
- Recommended
- base-4.14.3.0
viChangeLog: https://downloads.haskell.org/~ghc/8.10.6/docs/html/users_guide/8.10.6-notes.html
viSourceDL:
@@ -1847,6 +1846,107 @@ ghcupDownloads:
dlUri: https://downloads.haskell.org/~ghc/8.10.6/ghc-8.10.6-armv7-deb10-linux.tar.xz
dlSubdir: ghc-8.10.6
dlHash: d54de8306aa8b33afabf2ac94408e1f82c8e982a2a3346168c071b92bdb464c0
8.10.7:
viTags:
- Recommended
- base-4.14.3.0
viChangeLog: https://downloads.haskell.org/~ghc/8.10.7/docs/html/users_guide/8.10.7-notes.html
viSourceDL:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-src.tar.xz
dlSubdir: ghc-8.10.7
dlHash: e3eef6229ce9908dfe1ea41436befb0455fefb1932559e860ad4c606b0d03c9d
viPostRemove: *ghc-post-remove
viPreCompile: *ghc-pre-compile
viArch:
A_64:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-8107-64-deb9
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-deb9-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: ced9870ea351af64fb48274b81a664cdb6a9266775f1598a79cbb6fdd5770a23
'( >= 10 && < 11 )': &ghc-8107-64-deb10
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-deb10-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: a13719bca87a0d3ac0c7d4157a4e60887009a7f1a8dbe95c4759ec413e086d30
unknown_versioning: *ghc-8107-64-deb9
Linux_Ubuntu:
unknown_versioning: &ghc-8107-64-fedora
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-fedora27-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: b6ed67049a23054a8042e65c9976d5e196e5ee4e83b29b2ee35c8a22ab1e5b73
'( >= 16 && < 19 )': *ghc-8107-64-deb9
Linux_Mint:
unknown_versioning: *ghc-8107-64-deb10
Linux_Fedora:
'( >= 27 && < 28 )': *ghc-8107-64-fedora
unknown_versioning: *ghc-8107-64-fedora
Linux_CentOS:
'( >= 7 && < 8 )': &ghc-8107-64-centos
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-centos7-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: 262a50bfb5b7c8770e0d99f54d42e5876968da7bf93e2e4d6cfe397891a36d05
unknown_versioning: *ghc-8107-64-centos
Linux_RedHat:
unknown_versioning: *ghc-8107-64-centos
Linux_Alpine:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-alpine3.10-linux-integer-simple.tar.xz
dlSubdir: ghc-8.10.7-x86_64-unknown-linux
dlHash: 16903df850ef73d5246f2ff169cbf57ecab76c2ac5acfa9928934282cfad575c
Linux_AmazonLinux:
unknown_versioning: *ghc-8107-64-centos
Linux_UnknownLinux:
unknown_versioning: *ghc-8107-64-fedora
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-apple-darwin.tar.xz
dlSubdir: ghc-8.10.7
dlHash: 287db0f9c338c9f53123bfa8731b0996803ee50f6ee847fe388092e5e5132047
FreeBSD:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-unknown-freebsd.tar.xz
dlSubdir: ghc-8.10.7
dlHash: 45e35d24bc700e1093efa39189e9fa01498069881aed2fa8779c011941a80da1
Windows:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-x86_64-unknown-mingw32.tar.xz
dlSubdir: ghc-8.10.7
dlHash: b6515b0ea3f7a6e34d92e7fcd0c1fef50d6030fe8f46883000185289a4b8ea9a
A_32:
Linux_Debian:
'( >= 9 && < 10 )': &ghc-8107-32-deb9
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-i386-deb9-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: fbfc1ef194f4e7a4c0da8c11cc69b17458a4b928b609b3622c97acc4acd5c5ab
unknown_versioning: *ghc-8107-32-deb9
Linux_Ubuntu:
unknown_versioning: *ghc-8107-32-deb9
Linux_Mint:
unknown_versioning: *ghc-8107-32-deb9
Linux_UnknownLinux:
unknown_versioning: *ghc-8107-32-deb9
Linux_Alpine:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/unofficial-bindists/ghc/8.10.7/ghc-8.10.7-i386-alpine-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: 3110e6ee029d9d8062158b54b06f71a21b0fac87bf0e085f9be5bbcf73f99e6d
A_ARM64:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-aarch64-deb10-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: fad2417f9b295233bf8ade79c0e6140896359e87be46cb61cd1d35863d9d0e55
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-aarch64-apple-darwin.tar.xz
dlSubdir: ghc-8.10.7
dlHash: dc469fc3c35fd2a33a5a575ffce87f13de7b98c2d349a41002e200a56d9bba1c
A_ARM:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.7/ghc-8.10.7-armv7-deb10-linux.tar.xz
dlSubdir: ghc-8.10.7
dlHash: 3949c31bdf7d3b4afb765ea8246bca4ca9707c5d988d9961a244f0da100956a2
9.0.1:
viTags:
- Latest

View File

@@ -104,14 +104,12 @@ library
, deepseq ^>=1.4.4.0
, directory ^>=1.3.6.0
, disk-free-space ^>=0.1.0.1
, extra ^>=1.7.9
, filepath ^>=1.4.2.1
, haskus-utils-types ^>=1.5
, haskus-utils-variant >=3.0 && <3.2
, libarchive ^>=3.0.0.0
, lzma-static ^>=5.2.5.3
, megaparsec >=8.0.0 && <9.1
, monad-logger ^>=0.3.31
, mtl ^>=2.2
, optics ^>=0.4
, os-release ^>=1.0.0
@@ -134,8 +132,7 @@ library
, vector ^>=0.12
, versions >=4.0.1 && <5.1
, word8 ^>=0.1.3
, yaml ^>=0.11.4.0
, zip ^>=1.7.1
, HsYAML-aeson ^>=0.2.0.0
, zlib ^>=0.6.2.2
if (flag(internal-downloader) && !os(windows))
@@ -186,9 +183,12 @@ executable ghcup
-fwarn-incomplete-record-updates -threaded
build-depends:
, aeson >=1.4 && <1.6
, aeson-pretty ^>=0.8.8
, async ^>=2.2.3
, base >=4.13 && <5
, bytestring ^>=0.10
, cabal-plan ^>=0.7.2
, containers ^>=0.6
, deepseq ^>=1.4
, filepath ^>=1.4.2.1
@@ -196,7 +196,6 @@ executable ghcup
, haskus-utils-variant >=3.0 && <3.2
, libarchive ^>=3.0.0.0
, megaparsec >=8.0.0 && <9.1
, monad-logger ^>=0.3.31
, mtl ^>=2.2
, optparse-applicative >=0.15.1.0 && <0.17
, pretty ^>=1.1.3.1
@@ -209,7 +208,7 @@ executable ghcup
, uri-bytestring ^>=0.3.2.2
, utf8-string ^>=1.0
, versions >=4.0.1 && <5.1
, yaml ^>=0.11.4.0
, HsYAML-aeson ^>=0.2.0.0
if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER
@@ -258,7 +257,6 @@ executable ghcup-gen
, ghcup
, haskus-utils-variant >=3.0 && <3.2
, libarchive ^>=3.0.0.0
, monad-logger ^>=0.3.31
, mtl ^>=2.2
, optics ^>=0.4
, optparse-applicative >=0.15.1.0 && <0.17
@@ -270,7 +268,7 @@ executable ghcup-gen
, text ^>=1.2.4.0
, transformers ^>=0.5
, versions >=4.0.1 && <5.1
, yaml ^>=0.11.4.0
, HsYAML-aeson ^>=0.2.0.0
test-suite ghcup-test
type: exitcode-stdio-1.0

View File

@@ -48,7 +48,6 @@ import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
@@ -58,7 +57,6 @@ import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
import Data.ByteString ( ByteString )
import Data.Either
import Data.List
import Data.List.Extra
import Data.Maybe
import Data.String ( fromString )
import Data.Text ( Text )
@@ -112,7 +110,7 @@ fetchToolBindist :: ( MonadFail m
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -140,7 +138,7 @@ fetchGHCSrc :: ( MonadFail m
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -177,7 +175,7 @@ installGHCBindist :: ( MonadFail m
, HasDirs env
, HasSettings env
, HasPlatformReq env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -202,7 +200,7 @@ installGHCBindist :: ( MonadFail m
installGHCBindist dlinfo ver isoFilepath = do
let tver = mkTVer ver
lift $ $(logDebug) $ "Requested to install GHC with " <> prettyVer ver
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
case isoFilepath of
-- we only care for already installed errors in regular (non-isolated) installs
@@ -219,7 +217,7 @@ installGHCBindist dlinfo ver isoFilepath = do
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) $ "isolated installing GHC to " <> T.pack isoDir
lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver
Nothing -> do -- regular install
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
@@ -233,9 +231,9 @@ installGHCBindist dlinfo ver isoFilepath = do
case catMaybes r of
[] -> pure ()
_ -> do
lift $ $(logWarn) "CC/LD environment variable is set. This will change the compiler/linker"
lift $ $(logWarn) "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda"
lift $ $(logWarn) "environments). If you encounter problems, unset CC and LD and reinstall."
lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker"
<> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda"
<> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall."
-- | Install a packed GHC distribution. This only deals with unpacking and the GHC
@@ -247,7 +245,7 @@ installPackedGHC :: ( MonadMask m
, HasPlatformReq env
, HasSettings env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadUnliftIO m
)
@@ -305,7 +303,7 @@ installUnpackedGHC :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadUnliftIO m
, MonadMask m
@@ -316,7 +314,7 @@ installUnpackedGHC :: ( MonadReader env m
-> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver = do
#if defined(IS_WINDOWS)
lift $ $(logInfo) "Installing GHC (this may take a while)"
lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need
-- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg.
@@ -333,7 +331,7 @@ installUnpackedGHC path inst ver = do
| otherwise
= []
lift $ $(logInfo) "Installing GHC (this may take a while)"
lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst)
: alpineArgs
@@ -359,7 +357,7 @@ installGHCBin :: ( MonadFail m
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -393,7 +391,7 @@ installCabalBindist :: ( MonadMask m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -417,7 +415,7 @@ installCabalBindist :: ( MonadMask m
m
()
installCabalBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) $ "Requested to install cabal version " <> prettyVer ver
lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
@@ -448,7 +446,7 @@ installCabalBindist dlinfo ver isoFilepath = do
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) $ "isolated installing Cabal to " <> T.pack isoDir
lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir
liftE $ installCabalUnpacked workdir isoDir Nothing
Nothing -> do -- regular install
@@ -460,19 +458,22 @@ installCabalBindist dlinfo ver isoFilepath = do
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
-- | Install an unpacked cabal distribution.
installCabalUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
installCabalUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installCabalUnpacked path inst mver' = do
lift $ $(logInfo) "Installing cabal"
lift $ logInfo "Installing cabal"
let cabalFile = "cabal"
liftIO $ createDirRecursive' inst
let destFileName = cabalFile
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
<> exeExt
let destPath = inst </> destFileName
liftE $ throwIfFileAlreadyExists destPath
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile <> exeExt)
destPath
@@ -488,7 +489,7 @@ installCabalBin :: ( MonadMask m
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -523,7 +524,7 @@ installHLSBindist :: ( MonadMask m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -542,11 +543,12 @@ installHLSBindist :: ( MonadMask m
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
]
m
()
installHLSBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) $ "Requested to install hls version " <> prettyVer ver
lift $ logDebug $ "Requested to install hls version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
@@ -572,7 +574,7 @@ installHLSBindist dlinfo ver isoFilepath = do
case isoFilepath of
Just isoDir -> do
lift $ $(logInfo) $ "isolated installing HLS to " <> T.pack isoDir
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpacked workdir isoDir Nothing
Nothing -> do
@@ -585,13 +587,13 @@ installHLSBindist dlinfo ver isoFilepath = do
-- | Install an unpacked hls distribution.
installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
installHLSUnpacked :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install
-> Excepts '[CopyError] m ()
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpacked path inst mver' = do
lift $ $(logInfo) "Installing HLS"
lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst
-- install haskell-language-server-<ghcver>
@@ -605,20 +607,32 @@ installHLSUnpacked path inst mver' = do
let toF = dropSuffix exeExt f
<> maybe "" (("~" <>) . T.unpack . prettyVer) mver'
<> exeExt
let srcPath = path </> f
let destPath = inst </> toF
liftE $ throwIfFileAlreadyExists destPath
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> f)
(inst </> toF)
lift $ chmod_755 (inst </> toF)
srcPath
destPath
lift $ chmod_755 destPath
-- install haskell-language-server-wrapper
let wrapper = "haskell-language-server-wrapper"
toF = wrapper
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
<> exeExt
srcWrapperPath = path </> wrapper <> exeExt
destWrapperPath = inst </> toF
liftE $ throwIfFileAlreadyExists destWrapperPath
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> wrapper <> exeExt)
(inst </> toF)
lift $ chmod_755 (inst </> toF)
srcWrapperPath
destWrapperPath
lift $ chmod_755 destWrapperPath
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
@@ -629,7 +643,7 @@ installHLSBin :: ( MonadMask m
, HasGHCupInfo env
, HasDirs env
, HasSettings env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -647,6 +661,7 @@ installHLSBin :: ( MonadMask m
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
]
m
()
@@ -665,7 +680,7 @@ installStackBin :: ( MonadMask m
, HasSettings env
, HasPlatformReq env
, HasGHCupInfo env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -683,6 +698,7 @@ installStackBin :: ( MonadMask m
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
]
m
()
@@ -699,7 +715,7 @@ installStackBindist :: ( MonadMask m
, HasPlatformReq env
, HasDirs env
, HasSettings env
, MonadLogger m
, HasLog env
, MonadResource m
, MonadIO m
, MonadUnliftIO m
@@ -718,11 +734,12 @@ installStackBindist :: ( MonadMask m
, UnknownArchive
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
]
m
()
installStackBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) $ "Requested to install stack version " <> prettyVer ver
lift $ logDebug $ "Requested to install stack version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs
@@ -747,7 +764,7 @@ installStackBindist dlinfo ver isoFilepath = do
case isoFilepath of
Just isoDir -> do -- isolated install
lift $ $(logInfo) $ "isolated installing Stack to " <> T.pack isoDir
lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir
liftE $ installStackUnpacked workdir isoDir Nothing
Nothing -> do -- regular install
liftE $ installStackUnpacked workdir binDir (Just ver)
@@ -759,19 +776,22 @@ installStackBindist dlinfo ver isoFilepath = do
-- | Install an unpacked stack distribution.
installStackUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated installs
-> Excepts '[CopyError] m ()
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
installStackUnpacked path inst mver' = do
lift $ $(logInfo) "Installing stack"
lift $ logInfo "Installing stack"
let stackFile = "stack"
liftIO $ createDirRecursive' inst
let destFileName = stackFile
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
<> exeExt
let destPath = inst </> destFileName
destPath = inst </> destFileName
liftE $ throwIfFileAlreadyExists destPath
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> stackFile <> exeExt)
destPath
@@ -795,7 +815,7 @@ installStackUnpacked path inst mver' = do
-- for 'SetGHCOnly' constructor.
setGHC :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -829,7 +849,7 @@ setGHC ver sghc = do
SetGHCOnly -> pure $ Just file
SetGHC_XY -> do
handle
(\(e :: ParseError) -> lift $ $(logWarn) (T.pack $ displayException e) >> pure Nothing)
(\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
$ do
(mj, mi) <- getMajorMinorV (_tvVersion ver)
let major' = intToText mj <> "." <> intToText mi
@@ -854,7 +874,7 @@ setGHC ver sghc = do
symlinkShareDir :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, HasLog env
, MonadCatch m
, MonadMask m
)
@@ -871,9 +891,9 @@ setGHC ver sghc = do
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
let fullF = destdir </> sharedir
let targetF = "." </> "ghc" </> ver' </> sharedir
$(logDebug) $ "rm -f " <> T.pack fullF
logDebug $ "rm -f " <> T.pack fullF
hideError doesNotExistErrorType $ rmDirectoryLink fullF
$(logDebug) $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF
logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF
liftIO
#if defined(IS_WINDOWS)
-- On windows we need to be more permissive
@@ -891,7 +911,7 @@ setGHC ver sghc = do
setCabal :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -923,7 +943,7 @@ setCabal ver = do
setHLS :: ( MonadCatch m
, MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -939,7 +959,7 @@ setHLS ver = do
-- selected version, so we could end up with stray or incorrect symlinks.
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ $(logDebug) $ "rm " <> T.pack (binDir </> f)
lift $ logDebug $ "rm " <> T.pack (binDir </> f)
lift $ rmLink (binDir </> f)
-- set haskell-language-server-<ghcver> symlinks
@@ -964,7 +984,7 @@ setHLS ver = do
setStack :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -1027,9 +1047,9 @@ availableToolVersions av tool = view
-- | List all versions from the download info, as well as stray
-- versions.
listVersions :: ( MonadCatch m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
@@ -1085,7 +1105,7 @@ listVersions lt' criteria = do
, MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
@@ -1125,7 +1145,7 @@ listVersions lt' criteria = do
, ..
}
Left e -> do
$(logWarn)
logWarn
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
@@ -1133,7 +1153,7 @@ listVersions lt' criteria = do
, HasDirs env
, MonadCatch m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
@@ -1160,7 +1180,7 @@ listVersions lt' criteria = do
, ..
}
Left e -> do
$(logWarn)
logWarn
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
@@ -1168,7 +1188,7 @@ listVersions lt' criteria = do
, HasDirs env
, MonadCatch m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m)
=> Map.Map Version VersionInfo
-> Maybe Version
@@ -1194,7 +1214,7 @@ listVersions lt' criteria = do
, ..
}
Left e -> do
$(logWarn)
logWarn
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
@@ -1202,7 +1222,7 @@ listVersions lt' criteria = do
, HasDirs env
, MonadCatch m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
)
=> Map.Map Version VersionInfo
@@ -1229,7 +1249,7 @@ listVersions lt' criteria = do
, ..
}
Left e -> do
$(logWarn)
logWarn
$ "Could not parse version of stray directory" <> T.pack e
pure Nothing
@@ -1254,7 +1274,7 @@ listVersions lt' criteria = do
}
-- NOTE: this are not cross ones, because no bindists
toListResult :: ( MonadLogger m
toListResult :: ( HasLog env
, MonadReader env m
, HasDirs env
, HasGHCupInfo env
@@ -1356,7 +1376,7 @@ listVersions lt' criteria = do
rmGHCVer :: ( MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
@@ -1373,23 +1393,23 @@ rmGHCVer ver = do
-- this isn't atomic, order matters
when isSetGHC $ do
lift $ $(logInfo) "Removing ghc symlinks"
lift $ logInfo "Removing ghc symlinks"
liftE $ rmPlain (_tvTarget ver)
lift $ $(logInfo) "Removing ghc-x.y.z symlinks"
lift $ logInfo "Removing ghc-x.y.z symlinks"
liftE $ rmMinorSymlinks ver
lift $ $(logInfo) "Removing/rewiring ghc-x.y symlinks"
lift $ logInfo "Removing/rewiring ghc-x.y symlinks"
-- first remove
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version)
lift $ $(logInfo) $ "Removing directory recursively: " <> T.pack dir
lift $ logInfo $ "Removing directory recursively: " <> T.pack dir
lift $ recyclePathForcibly dir
v' <-
handle
(\(e :: ParseError) -> lift $ $(logWarn) (T.pack $ displayException e) >> pure Nothing)
(\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
$ fmap Just
$ getMajorMinorV (_tvVersion ver)
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
@@ -1406,7 +1426,7 @@ rmCabalVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
@@ -1437,7 +1457,7 @@ rmHLSVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
@@ -1460,7 +1480,7 @@ rmHLSVer ver = do
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
let fullF = binDir </> f
lift $ $(logDebug) $ "rm " <> T.pack fullF
lift $ logDebug $ "rm " <> T.pack fullF
lift $ rmLink fullF
-- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs
@@ -1475,7 +1495,7 @@ rmStackVer :: ( MonadMask m
, MonadReader env m
, HasDirs env
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
, MonadCatch m
@@ -1505,7 +1525,7 @@ rmGhcup :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadMask m
, MonadUnliftIO m
)
@@ -1530,7 +1550,7 @@ rmGhcup = do
let areEqualPaths = equalFilePath p1 p2
unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
#if defined(IS_WINDOWS)
-- since it doesn't seem possible to delete a running exe on windows
@@ -1546,7 +1566,7 @@ rmGhcup = do
where
handlePathNotPresent fp _err = do
$logDebug $ "Error: The path does not exist, " <> T.pack fp
logDebug $ "Error: The path does not exist, " <> T.pack fp
pure fp
nonStandardInstallLocationMsg path = T.pack $
@@ -1556,7 +1576,7 @@ rmGhcup = do
rmTool :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadFail m
, MonadMask m
, MonadUnliftIO m)
@@ -1576,7 +1596,7 @@ rmTool ListResult {lVer, lTool, lCross} = do
rmGhcupDirs :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, HasLog env
, MonadCatch m
, MonadMask m )
=> m [FilePath]
@@ -1603,7 +1623,7 @@ rmGhcupDirs = do
handleRm $ rmBinDir binDir
handleRm $ rmDir recycleDir
#if defined(IS_WINDOWS)
$logInfo $ "removing " <> T.pack (baseDir </> "msys64")
logInfo $ "removing " <> T.pack (baseDir </> "msys64")
handleRm $ rmPathForcibly (baseDir </> "msys64")
#endif
@@ -1614,27 +1634,27 @@ rmGhcupDirs = do
hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir
where
handleRm :: (MonadCatch m, MonadLogger m) => m () -> m ()
handleRm = handleIO (\e -> $logDebug $ "Part of the cleanup action failed with error: " <> T.pack (displayException e) <> "\n"
handleRm :: (MonadReader env m, MonadCatch m, HasLog env, MonadIO m) => m () -> m ()
handleRm = handleIO (\e -> logDebug $ "Part of the cleanup action failed with error: " <> T.pack (displayException e) <> "\n"
<> "continuing regardless...")
rmEnvFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmEnvFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmEnvFile enFilePath = do
$logInfo "Removing Ghcup Environment File"
logInfo "Removing Ghcup Environment File"
hideErrorDef [permissionErrorType] () $ deleteFile enFilePath
rmConfFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmConfFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmConfFile confFilePath = do
$logInfo "removing Ghcup Config File"
logInfo "removing Ghcup Config File"
hideErrorDef [permissionErrorType] () $ deleteFile confFilePath
rmDir :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmDir :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmDir dir =
-- 'getDirectoryContentsRecursive' is lazy IO. In case
-- an error leaks through, we catch it here as well,
-- althought 'deleteFile' should already handle it.
hideErrorDef [doesNotExistErrorType] () $ do
$logInfo $ "removing " <> T.pack dir
logInfo $ "removing " <> T.pack dir
contents <- liftIO $ getDirectoryContentsRecursive dir
forM_ contents (deleteFile . (dir </>))
@@ -1707,7 +1727,7 @@ getDebugInfo :: ( Alternative m
, MonadFail m
, MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadCatch m
, MonadIO m
)
@@ -1743,7 +1763,7 @@ compileGHC :: ( MonadMask m
, HasSettings env
, MonadThrow m
, MonadResource m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadUnliftIO m
, MonadFail m
@@ -1783,7 +1803,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
(workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball
Left tver -> do
lift $ $(logDebug) $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap
lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap
-- download source tarball
dlInfo <-
@@ -1808,7 +1828,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
lift $ $(logInfo) $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack 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 [ "remote"
, "add"
@@ -1835,7 +1855,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))
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
lift $ $(logInfo) $ "Git version " <> T.pack 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)
-- the version that's installed may differ from the
@@ -1847,10 +1867,10 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
when alreadyInstalled $ do
case isolateDir of
Just isoDir ->
lift $ $(logWarn) $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Isolate installing to " <> T.pack isoDir
lift $ logWarn $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Isolate installing to " <> T.pack isoDir
Nothing ->
lift $ $(logWarn) $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Will overwrite existing version."
lift $ $(logWarn)
lift $ logWarn $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Will overwrite existing version."
lift $ logWarn
"...waiting for 10 seconds before continuing, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
@@ -1877,7 +1897,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
Nothing ->
-- only remove old ghc in regular installs
when alreadyInstalled $ do
lift $ $(logInfo) "Deleting existing installation"
lift $ logInfo "Deleting existing installation"
liftE $ rmGHCVer tver
_ -> pure ()
@@ -1929,7 +1949,7 @@ endif|]
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
)
@@ -1952,7 +1972,7 @@ endif|]
liftE $ configureBindist bghc tver workdir ghcdir
lift $ $(logInfo) "Building (this may take a while)..."
lift $ logInfo "Building (this may take a while)..."
hadrian_build <- liftE $ findHadrianFile workdir
lEM $ execLogged hadrian_build
( maybe [] (\j -> ["-j" <> show j] ) jobs
@@ -1991,7 +2011,7 @@ endif|]
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
)
@@ -2022,15 +2042,15 @@ endif|]
liftE $ checkBuildConfig (build_mk workdir)
lift $ $(logInfo) "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)
if | isCross tver -> do
lift $ $(logInfo) "Installing cross toolchain..."
lift $ logInfo "Installing cross toolchain..."
lEM $ make ["install"] (Just workdir)
pure Nothing
| otherwise -> do
lift $ $(logInfo) "Creating bindist..."
lift $ logInfo "Creating bindist..."
lEM $ make ["binary-dist"] (Just workdir)
[tar] <- liftIO $ findFiles
workdir
@@ -2049,7 +2069,7 @@ endif|]
, MonadIO m
, MonadThrow m
, MonadCatch m
, MonadLogger m
, HasLog env
)
=> GHCTargetVersion
-> FilePath -- ^ tar file
@@ -2084,10 +2104,10 @@ endif|]
let tarPath = cacheDir </> tarName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
tarPath
lift $ $(logInfo) $ "Copied bindist to " <> T.pack tarPath
lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
pure tarPath
checkBuildConfig :: (MonadCatch m, MonadIO m, MonadLogger m)
checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env)
=> FilePath
-> Excepts
'[FileDoesNotExistError, InvalidBuildConfig]
@@ -2110,7 +2130,7 @@ endif|]
forM_ buildFlavour $ \bf ->
when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do
lift $ $(logWarn) $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..."
lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..."
liftIO $ threadDelay 5000000
addBuildFlavourToConf bc = case buildFlavour of
@@ -2127,7 +2147,7 @@ endif|]
, HasPlatformReq env
, MonadThrow m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadFail m
)
@@ -2146,7 +2166,7 @@ endif|]
m
()
configureBindist bghc tver workdir ghcdir = do
lift $ $(logInfo) [s|configuring build|]
lift $ logInfo [s|configuring build|]
forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)
@@ -2210,7 +2230,7 @@ upgradeGHCup :: ( MonadMask m
, HasGHCupInfo env
, HasSettings env
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadResource m
, MonadIO m
@@ -2232,7 +2252,7 @@ upgradeGHCup mtarget force' = do
Dirs {..} <- lift getDirs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
lift $ $(logInfo) "Upgrading GHCup..."
lift $ logInfo "Upgrading GHCup..."
let latestVer = fromJust $ fst <$> getLatest dls GHCup
when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
dli <- liftE $ getDownloadInfo GHCup latestVer
@@ -2241,20 +2261,20 @@ upgradeGHCup mtarget force' = do
p <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp (Just fn) False
let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn) mtarget
lift $ $(logDebug) $ "mkdir -p " <> T.pack destDir
lift $ logDebug $ "mkdir -p " <> T.pack destDir
liftIO $ createDirRecursive' destDir
lift $ $(logDebug) $ "rm -f " <> T.pack destFile
lift $ logDebug $ "rm -f " <> T.pack destFile
lift $ hideError NoSuchThing $ recycleFile destFile
lift $ $(logDebug) $ "cp " <> T.pack p <> " " <> T.pack destFile
lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
destFile
lift $ chmod_755 destFile
liftIO (isInPath destFile) >>= \b -> unless b $
lift $ $(logWarn) $ T.pack (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
Nothing -> pure ()
Just pa -> lift $ $(logWarn) $ "ghcup is shadowed by "
Just pa -> lift $ logWarn $ "ghcup is shadowed by "
<> T.pack pa
<> ". The upgrade will not be in effect, unless you remove "
<> T.pack pa
@@ -2278,7 +2298,7 @@ upgradeGHCup mtarget force' = do
-- both installing from source and bindist.
postGHCInstall :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -2294,7 +2314,7 @@ postGHCInstall ver@GHCTargetVersion {..} = do
-- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless.
v' <-
handle (\(e :: ParseError) -> lift $ $(logWarn) (T.pack $ displayException e) >> pure Nothing)
handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
$ fmap Just
$ getMajorMinorV _tvVersion
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget)
@@ -2310,7 +2330,7 @@ postGHCInstall ver@GHCTargetVersion {..} = do
-- * for ghcup, this reports the location of the currently running executable
whereIsTool :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -2348,3 +2368,10 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
liftIO $ canonicalizePath currentRunningExecPath
throwIfFileAlreadyExists :: ( MonadIO m ) =>
FilePath ->
Excepts '[FileAlreadyExistsError] m ()
throwIfFileAlreadyExists fp = whenM (checkFileAlreadyExists fp)
(throwE $ FileAlreadyExistsError fp)

View File

@@ -1,10 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
@@ -34,8 +31,8 @@ import GHCup.Download.Utils
#endif
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Prelude
@@ -47,7 +44,6 @@ import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
@@ -57,8 +53,8 @@ import Data.ByteString ( ByteString )
#if defined(INTERNAL_DOWNLOADER)
import Data.CaseInsensitive ( mk )
#endif
import Data.List.Extra
import Data.Maybe
import Data.List
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Versions
@@ -72,6 +68,7 @@ import Prelude hiding ( abs
, readFile
, writeFile
)
import Safe
import System.Directory
import System.Environment
import System.Exit
@@ -89,7 +86,7 @@ import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified Data.YAML.Aeson as Y
@@ -111,7 +108,7 @@ getDownloadsF :: ( FromJSONKey Tool
, HasDirs env
, MonadIO m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
@@ -164,7 +161,7 @@ getBase :: ( MonadReader env m
, MonadFail m
, MonadIO m
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadMask m
)
=> URI
@@ -186,28 +183,27 @@ getBase uri = do
-- if we didn't get a filepath from the download, use the cached yaml
actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
lift $ $(logDebug) $ "Decoding yaml at: " <> T.pack actualYaml
yamlContents <- liftIO $ L.readFile actualYaml
lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
liftE
. onE_ (onError actualYaml)
. lEM' @_ @_ @'[JSONError] JSONDecodeError
. fmap (first (\e -> unlines [displayException e
,"Consider removing " <> actualYaml <> " manually."]))
. liftIO
. Y.decodeFileEither
$ actualYaml
. lE' @_ @_ @'[JSONError] JSONDecodeError
. first (\(_, e) -> unlines [e, "Consider removing " <> actualYaml <> " manually."])
. Y.decode1
$ yamlContents
where
-- On error, remove the etags file and set access time to 0. This should ensure the next invocation
-- may re-download and succeed.
onError :: (MonadLogger m, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
onError fp = do
let efp = etagsFile fp
handleIO (\e -> $(logWarn) $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
handleIO (\e -> logWarn $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
(hideError doesNotExistErrorType $ rmFile efp)
liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
warnCache s = do
lift $ $(logWarn) "Could not get download info, trying cached version (this may not be recent!)"
lift $ $(logDebug) $ "Error was: " <> T.pack s
lift $ logWarn "Could not get download info, trying cached version (this may not be recent!)"
lift $ logDebug $ "Error was: " <> T.pack s
-- 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
@@ -221,7 +217,7 @@ getBase uri = do
, MonadCatch m1
, MonadIO m1
, MonadFail m1
, MonadLogger m1
, HasLog env1
, MonadMask m1
)
=> URI
@@ -312,7 +308,7 @@ download :: ( MonadReader env m
, HasDirs env
, MonadMask m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
)
=> URI
@@ -326,7 +322,7 @@ download uri eDigest dest mfn etags
| scheme == "http" = dl
| scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ path
lift $ $(logDebug) $ "using local file: " <> T.pack destFile'
lift $ logDebug $ "using local file: " <> T.pack destFile'
forM_ eDigest (liftE . flip checkDigest destFile')
pure destFile'
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
@@ -335,7 +331,7 @@ download uri eDigest dest mfn etags
scheme = view (uriSchemeL' % schemeBSL') uri
dl = do
destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
lift $ $(logInfo) $ "downloading: " <> uri' <> " as file " <> T.pack destFile
lift $ logInfo $ "downloading: " <> uri' <> " as file " <> T.pack destFile
-- destination dir must exist
liftIO $ createDirRecursive' dest
@@ -358,7 +354,7 @@ download uri eDigest dest mfn etags
dh <- liftIO $ emptySystemTempFile "curl-header"
flip finally (try @_ @SomeException $ rmFile dh) $
flip finally (try @_ @SomeException $ rmFile (destFile <.> "tmp")) $ do
metag <- readETag destFile
metag <- lift $ readETag destFile
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ (if etags then ["--dump-header", dh] else [])
++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
@@ -370,14 +366,14 @@ download uri eDigest dest mfn etags
case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of
Just (http':sc:_)
| sc == "304"
, T.pack "HTTP" `T.isPrefixOf` http' -> $logDebug "Status code was 304, not overwriting"
, T.pack "HTTP" `T.isPrefixOf` http' -> lift $ logDebug "Status code was 304, not overwriting"
| T.pack "HTTP" `T.isPrefixOf` http' -> do
$logDebug $ "Status code was " <> sc <> ", overwriting"
lift $ logDebug $ "Status code was " <> sc <> ", overwriting"
liftIO $ copyFile (destFile <.> "tmp") destFile
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
:: V '[MalformedHeaders]))
writeEtags destFile (parseEtags headers)
lift $ writeEtags destFile (parseEtags headers)
else
liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
@@ -387,20 +383,20 @@ download uri eDigest dest mfn etags
o' <- liftIO getWgetOpts
if etags
then do
metag <- readETag destFile
metag <- lift $ readETag destFile
let opts = o' ++ maybe [] (\t -> ["--header", "If-None-Match: " <> T.unpack t]) metag
++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
case _exitCode of
ExitSuccess -> do
liftIO $ copyFile destFileTemp destFile
writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
ExitFailure i'
| i' == 8
, Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
-> do
$logDebug "Not modified, skipping download"
writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
lift $ logDebug "Not modified, skipping download"
lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
| otherwise -> throwE (NonZeroExit i' "wget" opts)
else do
let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
@@ -411,14 +407,14 @@ download uri eDigest dest mfn etags
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri
if etags
then do
metag <- readETag destFile
metag <- lift $ readETag destFile
let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
, E.encodeUtf8 etag)]) metag
liftE
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
$ do
r <- downloadToFile https host fullPath port destFile addHeaders
writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
else void $ liftE $ catchE @HTTPNotModified
@'[DownloadFailed]
(\e@(HTTPNotModified _) ->
@@ -444,33 +440,33 @@ download uri eDigest dest mfn etags
path = view pathL' uri
uri' = decUTF8Safe (serializeURIRef' uri)
parseEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
parseEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
parseEtags stderr = do
let mEtag = find (\line -> T.pack "etag:" `T.isPrefixOf` T.toLower line) . fmap T.strip . T.lines . getLastHeader $ stderr
case T.words <$> mEtag of
(Just []) -> do
$logDebug "Couldn't parse etags, no input: "
logDebug "Couldn't parse etags, no input: "
pure Nothing
(Just [_, etag']) -> do
$logDebug $ "Parsed etag: " <> etag'
logDebug $ "Parsed etag: " <> etag'
pure (Just etag')
(Just xs) -> do
$logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
pure Nothing
Nothing -> do
$logDebug "No etags header found"
logDebug "No etags header found"
pure Nothing
writeEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
writeEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
writeEtags destFile getTags = do
getTags >>= \case
Just t -> do
$logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile)
logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile)
liftIO $ T.writeFile (etagsFile destFile) t
Nothing ->
$logDebug "No etags files written"
logDebug "No etags files written"
readETag :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
readETag :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
readETag fp = do
e <- liftIO $ doesFileExist fp
if e
@@ -478,13 +474,13 @@ download uri eDigest dest mfn etags
rE <- try @_ @SomeException $ liftIO $ fmap stripNewline' $ T.readFile (etagsFile fp)
case rE of
(Right et) -> do
$logDebug $ "Read etag: " <> et
logDebug $ "Read etag: " <> et
pure (Just et)
(Left _) -> do
$logDebug "Etag file doesn't exist (yet)"
logDebug "Etag file doesn't exist (yet)"
pure Nothing
else do
$logDebug $ "Skipping and deleting etags file because destination file " <> T.pack 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)
pure Nothing
@@ -497,7 +493,7 @@ downloadCached :: ( MonadReader env m
, MonadMask m
, MonadResource m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadUnliftIO m
)
@@ -518,7 +514,7 @@ downloadCached' :: ( MonadReader env m
, HasSettings env
, MonadMask m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadUnliftIO m
)
@@ -552,7 +548,7 @@ checkDigest :: ( MonadReader env m
, HasSettings env
, MonadIO m
, MonadThrow m
, MonadLogger m
, HasLog env
)
=> T.Text -- ^ the hash
-> FilePath
@@ -562,7 +558,7 @@ checkDigest eDigest file = do
let verify = not noVerify
when verify $ do
let p' = takeFileName file
lift $ $(logInfo) $ "verifying digest of: " <> T.pack p'
lift $ logInfo $ "verifying digest of: " <> T.pack p'
c <- liftIO $ L.readFile file
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)

View File

@@ -50,7 +50,7 @@ instance Pretty NoCompatiblePlatform where
pPrint (NoCompatiblePlatform str') =
text ("Could not find a compatible platform. Got: " ++ str')
-- | Unable to find a download for the requested versio/distro.
-- | Unable to find a download for the requested version/distro.
data NoDownload = NoDownload
deriving Show

View File

@@ -20,6 +20,7 @@ module GHCup.Platform where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.File
import GHCup.Utils.Prelude
@@ -28,7 +29,6 @@ import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.Foldable
@@ -57,7 +57,7 @@ import qualified Data.Text.IO as T
-- | Get the full platform request, consisting of architecture, distro, ...
platformRequest :: (Alternative m, MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
platformRequest :: (MonadReader env m, Alternative m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> Excepts
'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
m
@@ -82,7 +82,7 @@ getArchitecture = case arch of
what -> Left (NoCompatibleArch what)
getPlatform :: (Alternative m, MonadLogger m, MonadCatch m, MonadIO m, MonadFail m)
getPlatform :: (Alternative m, MonadReader env m, HasLog env, MonadCatch m, MonadIO m, MonadFail m)
=> Excepts
'[NoCompatiblePlatform, DistroNotFound]
m
@@ -107,7 +107,7 @@ getPlatform = do
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
"mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
what -> throwE $ NoCompatiblePlatform what
lift $ $(logDebug) $ "Identified Platform as: " <> T.pack (prettyShow pfr)
lift $ logDebug $ "Identified Platform as: " <> T.pack (prettyShow pfr)
pure pfr
where
getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
@@ -138,12 +138,11 @@ getLinuxDistro = do
| hasWord name ["exherbo"] -> Exherbo
| hasWord name ["gentoo"] -> Gentoo
| hasWord name ["amazonlinux", "Amazon Linux"] -> AmazonLinux
| hasWord name ["solus"] -> Solus
| otherwise -> UnknownLinux
pure (distro, parsedVer)
where
hasWord t matches = foldr (\x y -> match (regex x) (T.unpack t) || y)
False
matches
hasWord t = any (\x -> match (regex x) (T.unpack t))
where
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])

View File

@@ -25,21 +25,17 @@ module GHCup.Types
)
where
import Control.Applicative
import Control.DeepSeq ( NFData, rnf )
import Control.Monad.Logger
import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
import URI.ByteString
#if defined(BRICK)
import Graphics.Vty ( Key(..) )
#endif
import qualified Control.Monad.Trans.Class as Trans
import qualified Data.Text as T
import qualified GHC.Generics as GHC
@@ -152,7 +148,7 @@ data Tag = Latest
| Recommended
| Prerelease
| Base PVP
| Old -- ^ old version are hidden by default in TUI
| Old -- ^ old versions are hidden by default in TUI
| UnknownTag String -- ^ used for upwardscompat
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
@@ -241,7 +237,7 @@ instance NFData LinuxDistro
distroToString :: LinuxDistro -> String
distroToString Debian = "debian"
distroToString Ubuntu = "ubuntu"
distroToString Mint= "mint"
distroToString Mint = "mint"
distroToString Fedora = "fedora"
distroToString CentOS = "centos"
distroToString RedHat = "redhat"
@@ -396,6 +392,7 @@ data AppState = AppState
, keyBindings :: KeyBindings
, ghcupInfo :: GHCupInfo
, pfreq :: PlatformRequest
, loggerConfig :: LoggerConfig
} deriving (Show, GHC.Generic)
instance NFData AppState
@@ -404,6 +401,7 @@ data LeanAppState = LeanAppState
{ settings :: Settings
, dirs :: Dirs
, keyBindings :: KeyBindings
, loggerConfig :: LoggerConfig
} deriving (Show, GHC.Generic)
instance NFData LeanAppState
@@ -555,14 +553,25 @@ instance Pretty Versioning where
instance Pretty Version where
pPrint = text . T.unpack . prettyVer
instance Show (a -> b) where
show _ = "<function>"
instance (Monad m, Alternative m) => Alternative (LoggingT m) where
empty = Trans.lift empty
{-# INLINE empty #-}
m <|> n = LoggingT $ \ r -> runLoggingT m r <|> runLoggingT n r
{-# INLINE (<|>) #-}
instance Show (IO ()) where
show _ = "<io>"
instance MonadLogger m => MonadLogger (Excepts e m) where
monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d
data LogLevel = Warn
| Info
| Debug
| Error
deriving (Eq, Ord, Show)
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: T.Text -> IO () -- ^ how to write the color output
, rawOutter :: T.Text -> IO () -- ^ how to write the full raw output
}
deriving Show
instance NFData LoggerConfig where
rnf (LoggerConfig !lcPrintDebug !_ !_) = rnf lcPrintDebug

View File

@@ -42,7 +42,7 @@ import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit

View File

@@ -6,6 +6,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Types.Optics
@@ -21,9 +22,13 @@ module GHCup.Types.Optics where
import GHCup.Types
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.ByteString ( ByteString )
import Data.Text ( Text )
import Optics
import URI.ByteString
import System.Console.Pretty
import qualified Data.Text as T
makePrisms ''Tool
makePrisms ''Architecture
@@ -87,13 +92,15 @@ getLeanAppState :: ( MonadReader env m
, LabelOptic' "settings" A_Lens env Settings
, LabelOptic' "dirs" A_Lens env Dirs
, LabelOptic' "keyBindings" A_Lens env KeyBindings
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
)
=> m LeanAppState
getLeanAppState = do
s <- gets @"settings"
d <- gets @"dirs"
k <- gets @"keyBindings"
pure (LeanAppState s d k)
l <- gets @"loggerConfig"
pure (LeanAppState s d k l)
getSettings :: ( MonadReader env m
@@ -110,6 +117,87 @@ getDirs :: ( MonadReader env m
getDirs = gets @"dirs"
logInfo :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logInfo = logInternal Info
logWarn :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logWarn = logInternal Warn
logDebug :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logDebug = logInternal Debug
logError :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logError = logInternal Error
logInternal :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
) => LogLevel
-> Text
-> m ()
logInternal logLevel msg = do
LoggerConfig {..} <- gets @"loggerConfig"
let style' = case logLevel of
Debug -> style Bold . color Blue
Info -> style Bold . color Green
Warn -> style Bold . color Yellow
Error -> style Bold . color Red
let l = case logLevel of
Debug -> style' "[ Debug ]"
Info -> style' "[ Info ]"
Warn -> style' "[ Warn ]"
Error -> style' "[ Error ]"
let strs = T.split (== '\n') msg
let out = case strs of
[] -> T.empty
(x:xs) ->
foldr (\a b -> a <> "\n" <> b) mempty
. ((l <> " " <> x) :)
. fmap (\line' -> style' "[ ... ] " <> line' )
$ xs
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
$ liftIO $ colorOutter out
-- raw output
let lr = case logLevel of
Debug -> "Debug:"
Info -> "Info:"
Warn -> "Warn:"
Error -> "Error:"
let outr = lr <> " " <> msg <> "\n"
liftIO $ rawOutter outr
getLogCleanup :: ( MonadReader env m
, LabelOptic' "logCleanup" A_Lens env (IO ())
)
=> m (IO ())
getLogCleanup = gets @"logCleanup"
getKeyBindings :: ( MonadReader env m
, LabelOptic' "keyBindings" A_Lens env KeyBindings
)
@@ -136,6 +224,7 @@ type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs)
type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings)
type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo)
type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest)
type HasLog env = (LabelOptic' "loggerConfig" A_Lens env LoggerConfig)
getCache :: (MonadReader env m, HasSettings env) => m Bool

View File

@@ -40,14 +40,12 @@ import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Codec.Archive hiding ( Directory )
import Codec.Archive.Zip
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
@@ -59,7 +57,6 @@ import Data.ByteString ( ByteString )
import Data.Either
import Data.Foldable
import Data.List
import Data.List.Extra
import Data.List.NonEmpty ( NonEmpty( (:|) ))
import Data.Maybe
import Data.Text ( Text )
@@ -115,7 +112,7 @@ ghcLinkDestination tool ver = do
rmMinorSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
@@ -129,14 +126,14 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
forM_ files $ \f -> do
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
let fullF = binDir </> f_xyz
lift $ $(logDebug) ("rm -f " <> T.pack fullF)
lift $ logDebug ("rm -f " <> T.pack fullF)
lift $ hideError doesNotExistErrorType $ rmLink fullF
-- | Removes the set ghc version for the given target, if any.
rmPlain :: ( MonadReader env m
, HasDirs env
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadIO m
@@ -151,11 +148,11 @@ rmPlain target = do
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do
let fullF = binDir </> f <> exeExt
lift $ $(logDebug) ("rm -f " <> T.pack fullF)
lift $ logDebug ("rm -f " <> T.pack fullF)
lift $ hideError doesNotExistErrorType $ rmLink fullF
-- old ghcup
let hdc_file = binDir </> "haddock-ghc" <> exeExt
lift $ $(logDebug) ("rm -f " <> T.pack hdc_file)
lift $ logDebug ("rm -f " <> T.pack hdc_file)
lift $ hideError doesNotExistErrorType $ rmLink hdc_file
@@ -163,7 +160,7 @@ rmPlain target = do
rmMajorSymlinks :: ( MonadReader env m
, HasDirs env
, MonadIO m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadMask m
@@ -179,7 +176,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
forM_ files $ \f -> do
let f_xy = f <> "-" <> T.unpack v' <> exeExt
let fullF = binDir </> f_xy
lift $ $(logDebug) "rm -f #{fullF}"
lift $ logDebug "rm -f #{fullF}"
lift $ hideError doesNotExistErrorType $ rmLink fullF
@@ -251,9 +248,9 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: ( MonadLogger m
, MonadReader env m
getInstalledCabals :: ( MonadReader env m
, HasDirs env
, HasLog env
, MonadIO m
, MonadCatch m
)
@@ -271,14 +268,14 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed.
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled :: (HasLog env, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled ver = do
vers <- fmap rights getInstalledCabals
pure $ elem ver vers
-- Return the currently set cabal version, if any.
cabalSet :: (MonadLogger m, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet = do
Dirs {..} <- getDirs
let cabalbin = binDir </> "cabal" <> exeExt
@@ -295,7 +292,7 @@ cabalSet = do
case linkVersion =<< link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) $ "Failed to parse cabal symlink target with: "
logWarn $ "Failed to parse cabal symlink target with: "
<> T.pack (displayException err)
<> ". The symlink "
<> T.pack cabalbin
@@ -366,7 +363,7 @@ getInstalledStacks = do
-- Return the currently set stack version, if any.
-- TODO: there's a lot of code duplication here :>
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version)
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, HasLog env) => m (Maybe Version)
stackSet = do
Dirs {..} <- getDirs
let stackBin = binDir </> "stack" <> exeExt
@@ -383,7 +380,7 @@ stackSet = do
case linkVersion =<< link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) $ "Failed to parse stack symlink target with: "
logWarn $ "Failed to parse stack symlink target with: "
<> T.pack (displayException err)
<> ". The symlink "
<> T.pack stackBin
@@ -601,7 +598,7 @@ getLatestGHCFor major' minor' dls =
-- | Unpack an archive to a temporary directory and return that path.
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
unpackToDir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
=> FilePath -- ^ destination dir
-> FilePath -- ^ archive path
-> Excepts '[UnknownArchive
@@ -609,7 +606,7 @@ unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
] m ()
unpackToDir dfp av = do
let fn = takeFileName av
lift $ $(logInfo) $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp
lift $ logInfo $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp
@@ -628,12 +625,11 @@ unpackToDir dfp av = do
| ".tar.bz2" `isSuffixOf` fn ->
liftE (untar . BZip.decompress =<< rf av)
| ".tar" `isSuffixOf` fn -> liftE (untar =<< rf av)
| ".zip" `isSuffixOf` fn ->
withArchive av (unpackInto dfp)
| ".zip" `isSuffixOf` fn -> liftE (untar =<< rf av)
| otherwise -> throwE $ UnknownArchive fn
getArchiveFiles :: (MonadLogger m, MonadIO m, MonadThrow m)
getArchiveFiles :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
=> FilePath -- ^ archive path
-> Excepts '[UnknownArchive
, ArchiveResult
@@ -658,14 +654,11 @@ getArchiveFiles av = do
| ".tar.bz2" `isSuffixOf` fn ->
liftE (entries . BZip.decompress =<< rf av)
| ".tar" `isSuffixOf` fn -> liftE (entries =<< rf av)
| ".zip" `isSuffixOf` fn ->
withArchive av $ do
entries' <- getEntries
pure $ fmap unEntrySelector $ Map.keys entries'
| ".zip" `isSuffixOf` fn -> liftE (entries =<< rf av)
| otherwise -> throwE $ UnknownArchive fn
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
=> FilePath -- ^ unpacked tar dir
-> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m FilePath
@@ -793,14 +786,14 @@ makeOut args workdir = do
-- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure.
applyPatches :: (MonadReader env m, HasDirs env, MonadLogger m, MonadIO m)
applyPatches :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
=> FilePath -- ^ dir containing patches
-> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m ()
applyPatches pdir ddir = do
patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) $ "Applying patch " <> T.pack patch'
lift $ logInfo $ "Applying patch " <> T.pack patch'
fmap (either (const Nothing) Just)
(exec
"patch"
@@ -841,7 +834,7 @@ runBuildAction :: ( Pretty (V e)
, HasSettings env
, MonadIO m
, MonadMask m
, MonadLogger m
, HasLog env
, MonadUnliftIO m
)
=> FilePath -- ^ build directory (cleaned up depending on Settings)
@@ -869,9 +862,9 @@ runBuildAction bdir instdir action = do
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- printing other errors without crashing.
rmBDir :: (MonadLogger m, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
rmBDir dir = withRunInIO (\run -> run $
liftIO $ handleIO (\e -> run $ $(logWarn) $
liftIO $ handleIO (\e -> run $ logWarn $
"Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e))
$ hideError doesNotExistErrorType
$ rmPathForcibly dir)
@@ -984,7 +977,7 @@ rmLink = hideError doesNotExistErrorType . recycleFile
-- On windows, this requires that 'ensureGlobalTools' was run beforehand.
createLink :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
@@ -1006,24 +999,24 @@ createLink link exe = do
fullLink = takeDirectory exe </> link
shimContents = "path = " <> fullLink
$(logDebug) $ "rm -f " <> T.pack exe
logDebug $ "rm -f " <> T.pack exe
rmLink exe
$(logDebug) $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents
#else
$(logDebug) $ "rm -f " <> T.pack exe
logDebug $ "rm -f " <> T.pack exe
hideError doesNotExistErrorType $ recycleFile exe
$(logDebug) $ "ln -s " <> T.pack link <> " " <> T.pack exe
logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
liftIO $ createFileLink link exe
#endif
ensureGlobalTools :: ( MonadMask m
, MonadThrow m
, MonadLogger m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
@@ -1041,8 +1034,8 @@ ensureGlobalTools = do
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\(DigestError _ _) -> do
lift $ $(logWarn) "Digest doesn't match, redownloading gs.exe..."
lift $ $(logDebug) "rm -f #{shimDownload}"
lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
lift $ logDebug "rm -f #{shimDownload}"
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)

View File

@@ -2,9 +2,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.Dirs
@@ -45,7 +43,6 @@ import GHCup.Utils.Prelude
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.Bifunctor
@@ -61,7 +58,7 @@ import System.IO.Temp
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Data.Yaml as Y
import qualified Data.YAML.Aeson as Y
import qualified Text.Megaparsec as MP
import Control.Concurrent (threadDelay)
@@ -224,7 +221,7 @@ ghcupConfigFile = do
contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath
case contents of
Nothing -> pure defaultUserSettings
Just contents' -> lE' JSONDecodeError . first show . Y.decodeEither' $ contents'
Just contents' -> lE' JSONDecodeError . first snd . Y.decode1Strict $ contents'
-------------------------
@@ -261,7 +258,7 @@ parseGHCupGHCDir (T.pack -> fp) =
mkGhcupTmpDir :: ( MonadReader env m
, HasDirs env
, MonadUnliftIO m
, MonadLogger m
, HasLog env
, MonadCatch m
, MonadThrow m
, MonadMask m
@@ -273,14 +270,14 @@ mkGhcupTmpDir = do
let minSpace = 5000 -- a rough guess, aight?
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
when (maybe False (toBytes minSpace >) space) $ do
$(logWarn) ("Possibly insufficient disk space on "
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..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
@@ -295,8 +292,9 @@ mkGhcupTmpDir = do
withGHCupTmpDir :: ( MonadReader env m
, HasDirs env
, HasLog env
, HasSettings env
, MonadUnliftIO m
, MonadLogger m
, MonadCatch m
, MonadResource m
, MonadThrow m
@@ -309,7 +307,7 @@ withGHCupTmpDir = snd <$> withRunInIO (\run ->
(run mkGhcupTmpDir)
(\fp ->
handleIO (\e -> run
$ $(logDebug) ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
$ logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
. rmPathForcibly
$ fp))
@@ -341,9 +339,10 @@ relativeSymlink p1 p2 =
cleanupTrash :: ( MonadIO m
, MonadMask m
, MonadLogger m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
)
=> m ()
cleanupTrash = do
@@ -352,8 +351,8 @@ cleanupTrash = do
if null contents
then pure ()
else do
$(logWarn) ("Removing leftover files in " <> T.pack recycleDir)
logWarn ("Removing leftover files in " <> T.pack recycleDir)
forM_ contents (\fp -> handleIO (\e ->
$(logDebug) ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
) $ liftIO $ removePathForcibly (recycleDir </> fp))

View File

@@ -7,7 +7,6 @@ module GHCup.Utils.File.Common where
import GHCup.Utils.Prelude
import Control.Monad.Extra
import Control.Monad.Reader
import Data.Maybe
import GHC.IO.Exception
@@ -102,3 +101,6 @@ findFiles path regex = do
contents <- listDirectory path
pure $ filter (match regex) contents
checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
checkFileAlreadyExists fp = liftIO $ doesFileExist fp

View File

@@ -1,8 +1,5 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils.File.Posix
@@ -28,7 +25,6 @@ import Control.Concurrent.Async
import Control.Exception ( evaluate )
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.State.Strict
import Data.ByteString ( ByteString )
@@ -131,7 +127,7 @@ execLogged exe args chdir lfile env = do
pure e
tee :: Fd -> Fd -> IO ()
tee fileFd fdIn = readTilEOF lineAction fdIn
tee fileFd = readTilEOF lineAction
where
lineAction :: ByteString -> IO ()
@@ -350,7 +346,7 @@ toProcessError exe args mps = case mps of
chmod_755 :: (MonadLogger m, MonadIO m) => FilePath -> m ()
chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m ()
chmod_755 fp = do
let exe_mode =
nullFileMode
@@ -361,7 +357,7 @@ chmod_755 fp = do
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode
$(logDebug) ("chmod 755 " <> T.pack fp)
logDebug ("chmod 755 " <> T.pack fp)
liftIO $ setFileMode fp exe_mode

View File

@@ -22,11 +22,8 @@ import GHCup.Utils.String.QQ
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Data.Char ( ord )
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
@@ -35,53 +32,6 @@ import qualified Data.ByteString as B
import GHCup.Utils.Prelude
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: B.ByteString -> IO () -- ^ how to write the color output
, rawOutter :: B.ByteString -> IO () -- ^ how to write the full raw output
}
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger _ _ level str' = do
-- color output
let style' = case level of
LevelDebug -> style Bold . color Blue
LevelInfo -> style Bold . color Green
LevelWarn -> style Bold . color Yellow
LevelError -> style Bold . color Red
LevelOther _ -> id
let l = case level of
LevelDebug -> toLogStr (style' "[ Debug ]")
LevelInfo -> toLogStr (style' "[ Info ]")
LevelWarn -> toLogStr (style' "[ Warn ]")
LevelError -> toLogStr (style' "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let strs = fmap toLogStr . B.split (fromIntegral $ ord '\n') . fromLogStr $ str'
let out = case strs of
[] -> B.empty
(x:xs) -> fromLogStr
. foldr (\a b -> a <> toLogStr "\n" <> b) mempty
. ((l <> toLogStr " " <> x) :)
. fmap (\line' -> toLogStr (style' "[ ... ] ") <> line' )
$ xs
when (lcPrintDebug || (not lcPrintDebug && (level /= LevelDebug)))
$ colorOutter out
-- raw output
let lr = case level of
LevelDebug -> toLogStr "Debug:"
LevelInfo -> toLogStr "Info:"
LevelWarn -> toLogStr "Warn:"
LevelError -> toLogStr "Error:"
LevelOther t -> toLogStr t <> toLogStr ":"
let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
rawOutter outr
initGHCupFileLogging :: ( MonadReader env m
, HasDirs env

View File

@@ -5,7 +5,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup.Utils.Prelude
@@ -30,10 +29,10 @@ import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Logger
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.List ( nub, intercalate )
import Data.List ( nub, intercalate, stripPrefix, isPrefixOf )
import Data.Maybe
import Data.Foldable
import Data.String
import Data.Text ( Text )
@@ -75,8 +74,9 @@ import qualified System.Win32.File as Win32
-- >>> import Data.ByteString.Internal (c2w, w2c)
-- >>> import Test.QuickCheck
-- >>> import Data.Word8
-- >>> import Data.Word8
-- >>> import qualified Data.Text as T
-- >>> import qualified Data.Char as C
-- >>> import Data.List
-- >>> instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary
@@ -174,8 +174,12 @@ lEM' :: forall e' e es a m
lEM' f em = lift em >>= lE . first f
-- for some obscure reason... this won't type-check if we move it to a different module
catchWarn :: forall es m . (Pretty (V es), MonadLogger m, Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ $(logWarn) (T.pack . prettyShow $ v))
catchWarn :: forall es m env . ( Pretty (V es)
, MonadReader env m
, HasLog env
, MonadIO m
, Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight
@@ -520,7 +524,7 @@ forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forFold = \t -> (`traverseFold` t)
-- | Strip @\\r@ and @\\n@ from 'ByteString's
-- | Strip @\\r@ and @\\n@ from 'String's
--
-- >>> stripNewline "foo\n\n\n"
-- "foo"
@@ -532,13 +536,10 @@ forFold = \t -> (`traverseFold` t)
-- prop> \t -> stripNewline (t <> "\n") === stripNewline t
-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewline t == t
stripNewline :: String -> String
stripNewline s
| null s = []
| head s `elem` "\n\r" = stripNewline (tail s)
| otherwise = head s : stripNewline (tail s)
stripNewline = filter (`notElem` "\n\r")
-- | Strip @\\r@ and @\\n@ from 'ByteString's
-- | Strip @\\r@ and @\\n@ from 'Text's
--
-- >>> stripNewline' "foo\n\n\n"
-- "foo"
@@ -550,10 +551,7 @@ stripNewline s
-- prop> \t -> stripNewline' (t <> "\n") === stripNewline' t
-- prop> \t -> not (T.any (isNewLine . c2w) t) ==> stripNewline' t == t
stripNewline' :: T.Text -> T.Text
stripNewline' s
| T.null s = mempty
| T.head s `elem` "\n\r" = stripNewline' (T.tail s)
| otherwise = T.singleton (T.head s) <> stripNewline' (T.tail s)
stripNewline' = T.filter (`notElem` "\n\r")
-- | Is the word8 a newline?
@@ -587,3 +585,117 @@ splitOnPVP c s = case Split.splitOn c s of
| otherwise -> def
where
def = (s, "")
-- | Like 'find', but where the test can be monadic.
--
-- >>> findM (Just . C.isUpper) "teST"
-- Just (Just 'S')
-- >>> findM (Just . C.isUpper) "test"
-- Just Nothing
-- >>> findM (Just . const True) ["x",undefined]
-- Just (Just "x")
findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)
-- | Drops the given suffix from a list.
-- It returns the original sequence if the sequence doesn't end with the given suffix.
--
-- >>> dropSuffix "!" "Hello World!"
-- "Hello World"
-- >>> dropSuffix "!" "Hello World!!"
-- "Hello World!"
-- >>> dropSuffix "!" "Hello World."
-- "Hello World."
dropSuffix :: Eq a => [a] -> [a] -> [a]
dropSuffix a b = fromMaybe b $ stripSuffix a b
-- | Return the prefix of the second list if its suffix
-- matches the entire first list.
--
-- >>> stripSuffix "bar" "foobar"
-- Just "foo"
-- >>> stripSuffix "" "baz"
-- Just "baz"
-- >>> stripSuffix "foo" "quux"
-- Nothing
stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
stripSuffix a b = reverse <$> stripPrefix (reverse a) (reverse b)
-- | Drops the given prefix from a list.
-- It returns the original sequence if the sequence doesn't start with the given prefix.
--
-- >>> dropPrefix "Mr. " "Mr. Men"
-- "Men"
-- >>> dropPrefix "Mr. " "Dr. Men"
-- "Dr. Men"
dropPrefix :: Eq a => [a] -> [a] -> [a]
dropPrefix a b = fromMaybe b $ stripPrefix a b
-- | Break a list into pieces separated by the first
-- list argument, consuming the delimiter. An empty delimiter is
-- invalid, and will cause an error to be raised.
--
-- >>> splitOn "\r\n" "a\r\nb\r\nd\r\ne"
-- ["a","b","d","e"]
-- >>> splitOn "aaa" "aaaXaaaXaaaXaaa"
-- ["","X","X","X",""]
-- >>> splitOn "x" "x"
-- ["",""]
-- >>> splitOn "x" ""
-- [""]
--
-- prop> \s x -> s /= "" ==> intercalate s (splitOn s x) == x
-- prop> \c x -> splitOn [c] x == split (==c) x
splitOn :: Eq a => [a] -> [a] -> [[a]]
splitOn [] _ = error "splitOn, needle may not be empty"
splitOn _ [] = [[]]
splitOn needle haystack = a : if null b then [] else splitOn needle $ drop (length needle) b
where (a,b) = breakOn needle haystack
-- | Splits a list into components delimited by separators,
-- where the predicate returns True for a separator element. The
-- resulting components do not contain the separators. Two adjacent
-- separators result in an empty component in the output.
--
-- >>> split (== 'a') "aabbaca"
-- ["","","bb","c",""]
-- >>> split (== 'a') ""
-- [""]
-- >>> split (== ':') "::xyz:abc::123::"
-- ["","","xyz","abc","","123","",""]
-- >>> split (== ',') "my,list,here"
-- ["my","list","here"]
split :: (a -> Bool) -> [a] -> [[a]]
split _ [] = [[]]
split f (x:xs)
| f x = [] : split f xs
| y:ys <- split f xs = (x:y) : ys
| otherwise = [[]]
-- | Find the first instance of @needle@ in @haystack@.
-- The first element of the returned tuple
-- is the prefix of @haystack@ before @needle@ is matched. The second
-- is the remainder of @haystack@, starting with the match.
-- If you want the remainder /without/ the match, use 'stripInfix'.
--
-- >>> breakOn "::" "a::b::c"
-- ("a","::b::c")
-- >>> breakOn "/" "foobar"
-- ("foobar","")
--
-- prop> \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack
breakOn :: Eq a => [a] -> [a] -> ([a], [a])
breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack)
breakOn _ [] = ([], [])
breakOn needle (x:xs) = first (x:) $ breakOn needle xs

View File

@@ -44,15 +44,14 @@ import Language.Haskell.TH.Quote
-- The pattern portion is undefined.
s :: QuasiQuoter
s = QuasiQuoter
(\s' -> case and $ fmap isAscii s' of
(\s' -> case all isAscii s' of
True -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'
False -> fail "Not ascii"
)
(error "Cannot use q as a pattern")
(error "Cannot use q as a type")
(error "Cannot use q as a dec")
(error "Cannot use s as a pattern")
(error "Cannot use s as a type")
(error "Cannot use s as a dec")
where
removeCRs = filter (/= '\r')
trimLeadingNewline ('\n' : xs) = xs
trimLeadingNewline xs = xs

View File

@@ -1,4 +1,4 @@
resolver: lts-18.7
resolver: lts-18.2
packages:
- .
@@ -6,8 +6,9 @@ packages:
extra-deps:
- git: https://github.com/bgamari/terminal-size
commit: 34ea816bd63f75f800eedac12c6908c6f3736036
- git: https://github.com/hasufell/libarchive
commit: 024a7e8ab7b4d3848dc64dca1e70a04831eedc99
commit: 8587aab78dd515928024ecd82c8f215e06db85cd
- brick-0.64@sha256:f03fa14607c22cf48af99e24c44f79a0fb073f7ec229f15e969fed9ff73c93f6,16530
- IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2,445
@@ -41,7 +42,6 @@ extra-deps:
- streamly-posix-0.1.0.1@sha256:5d89b806281035d34020387ed99dde1ddab282c7ed66df3b7cd010b38fd3517b,2138
- strict-base-0.4.0.0@sha256:2ff4e43cb95eedf2995558d7fc34d19362846413dd39e6aa6a5b3ea8228fef9f,1248
- xor-0.0.1.0@sha256:f8362b4a68562b9afbcd727ff64c1a303970df3a032e0033d2f4c094c3501df3,2243
- zip-1.7.1@sha256:0ce03d0fbffba47c1ab6fbb9166f8ba5373d828d78587df21b7e9d7bb150f929,3918
flags:
http-io-streams:
@@ -53,6 +53,12 @@ flags:
regex-posix:
_regex-posix-clib: true
aeson-pretty:
lib-only: true
cabal-plan:
exe: false
ghc-options:
"$locals": -O2
streamly: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16

View File

@@ -66,7 +66,7 @@ instance Arbitrary ByteString where
---------------------
instance Arbitrary Scheme where
arbitrary = oneof [ pure (Scheme "http"), pure (Scheme "https") ]
arbitrary = elements [ Scheme "http", Scheme "https" ]
instance Arbitrary Host where
arbitrary = genericArbitrary