Compare commits

...

58 Commits

Author SHA1 Message Date
9d7914e69a Bump ghcupURL 2020-09-22 23:41:19 +02:00
6c62884b24 Update Changelog 2020-09-22 21:31:01 +02:00
965d2a3ba8 Drop 'ghcup compile cabal'
Upstream has discontinued the old bootstrap shell script.
The new python shell script doesn't work like the old one
and is only useful for bootstrapping to a new architecture.

If you miss this feature, consider running:
  cabal install cabal-install

with the appropriate GHC version set (this might need some
experimenting).

This also fixes #64
2020-09-22 21:26:10 +02:00
40a1cc98c6 Drop use of table-layout, thanks to Simon 2020-09-22 21:05:59 +02:00
4c2d4ee6bd Update hls tarballs 2020-09-22 19:23:24 +02:00
9276664465 Merge branch 'hls' into master 2020-09-22 15:23:10 +02:00
a94bcdb92d Remove 9.0.1-alpha1
Ben requested removal, since this wasn't an announced
release.
2020-09-21 14:13:45 +02:00
5da5fabfef Use alpine:3.12 instead of edge 2020-09-21 12:23:14 +02:00
05cc55c52d Improve brick UI 2020-09-21 10:40:06 +02:00
571df1349c Update hie.yaml 2020-09-20 23:09:09 +02:00
cbbb75062c Bump version to 0.1.11 2020-09-20 23:09:09 +02:00
bb7c4205db Allow to install haskell-language-server wrt #65 2020-09-20 23:09:09 +02:00
b2027f1625 Simplify installing GHC from custom bindist wrt #60 2020-09-19 11:52:12 +02:00
65945c87df Update CHANGELOG 2020-09-19 11:51:48 +02:00
081582d3e1 Merge branch 'compile-overwrite' into master 2020-09-18 09:31:14 +02:00
bf240af518 Fix build
https://github.com/cjdev/text-conversions/pull/10
2020-09-17 22:18:03 +02:00
a269131e2d Allow to compile over existing version, fixes #59 2020-09-17 21:21:16 +02:00
59ece98fdc Fix bug in compileGHC cleanup logic 2020-09-17 21:20:38 +02:00
563924ff26 Fix gitlab CI 2020-09-15 22:22:15 +02:00
8ee3f55428 Fix test on i386 2020-09-15 21:59:56 +02:00
93c17607b5 Fix haddock build, fixes #62 2020-09-15 17:44:30 +02:00
8b4c239444 Add changelog entry for cabal-3.4.0.0-rc3 2020-09-15 15:43:07 +02:00
8bef17bf59 Add cabal-3.4.0.0-rc3 2020-09-15 15:38:10 +02:00
a649146a39 Add hspec tests to gitlab CI 2020-09-13 21:13:42 +02:00
9d6a5313ab Add JSON roundtrip specs 2020-09-13 21:10:13 +02:00
de09c950d5 Improve requirements wording, fixes #56 2020-09-13 15:38:51 +02:00
47838b1bd9 Merge branch 'compile-bindist' into master 2020-09-13 13:30:28 +02:00
02b360e2a9 Create bindists when compiling GHC wrt #51 2020-09-12 23:47:12 +02:00
c10ab15e0c Update cabal pre-release ot 3.4.0.0-rc2 2020-09-04 10:16:28 +02:00
46f3da1a94 Merge branch 'fix-symlink-support' into master 2020-09-01 21:07:42 +02:00
7ec9d90aab Fix build with libarchive-3.0.0.0 2020-09-01 19:55:48 +02:00
326bf510c9 Fix Error when ~/.ghcup is a valid symlink
Fixes #49
2020-08-31 13:03:12 +02:00
ce3d1f4309 Add GHC-9.0.1-alpha1 2020-08-27 23:41:07 +02:00
b31ba883e4 Add vim integration section to README 2020-08-23 14:07:49 +02:00
e5d1c04616 Fix bootstrap-haskell for fish shell, fixes #48 2020-08-20 15:51:37 +02:00
34ff0ed9cf Fix dlSubDir for GHC-8.10.2 on alpine wrt #47 2020-08-20 15:49:28 +02:00
85bd87d5f3 Clarify 2020-08-19 19:40:59 +02:00
8b274214af Fix typo 2020-08-19 19:38:36 +02:00
069e3102f4 Fix anchor 2020-08-19 19:36:13 +02:00
8623b32721 Add "Install custom bindists" to README 2020-08-19 19:34:04 +02:00
6342e8edf0 Use 8.10.2 in gitlab CI 2020-08-15 23:54:50 +02:00
bbd8f0c84c Add GHC-8.10.2 for alpine 32big 2020-08-15 23:34:05 +02:00
873c951d6e Refactor chmod +x 2020-08-14 22:27:05 +02:00
d9c864d3c5 Make sure cabal is executable wrt #46 2020-08-14 22:07:39 +02:00
4280d7109a Fix 3.4.0.0-rc1 urls wrt #46 2020-08-14 21:49:01 +02:00
c8855c068f Update version in bootstrap-haskell 2020-08-14 20:36:14 +02:00
90503061e9 Add ghcup-0.1.10 2020-08-14 20:22:27 +02:00
672ebf6426 Bump version 2020-08-14 16:57:15 +02:00
fd76fde23a Add cabal-3.4.0.0-rc1 2020-08-14 16:54:27 +02:00
e24c9a3ffe Show stray cabals, fixes #45 2020-08-14 16:53:32 +02:00
2641d50c21 Update ghcup binaries 2020-08-14 09:42:41 +02:00
202f3ea3ba Fix bug where setting non-installed GHC unsets current one 2020-08-13 20:40:09 +02:00
4f09e3ff7e Update CHANGELOG 2020-08-13 17:01:09 +02:00
1148219130 Fix README 2020-08-12 10:13:18 +02:00
4b47800dfb CHANGELOG fix 2020-08-11 22:38:22 +02:00
e2c4db9132 Rm unneeded note 2020-08-11 22:04:08 +02:00
90af68b211 Pre-release 0.1.9 2020-08-11 21:55:15 +02:00
80603662b4 Merge branch 'cabal-install-3.4.0.0-rc1' 2020-08-11 21:34:45 +02:00
28 changed files with 12286 additions and 468 deletions

View File

@@ -17,7 +17,7 @@ variables:
BIT: "64"
.alpine:64bit:
image: "alpine:edge"
image: "alpine:3.12"
tags:
- x86_64-linux
variables:
@@ -25,7 +25,7 @@ variables:
BIT: "64"
.alpine:32bit:
image: "i386/alpine:edge"
image: "i386/alpine:3.12"
tags:
- x86_64-linux
variables:
@@ -113,7 +113,7 @@ test:linux:recommended:
test:linux:latest:
extends: .test_ghcup_version:linux
variables:
GHC_VERSION: "8.10.1"
GHC_VERSION: "8.10.2"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
@@ -136,7 +136,7 @@ test:mac:recommended:
test:mac:latest:
extends: .test_ghcup_version:darwin
variables:
GHC_VERSION: "8.10.1"
GHC_VERSION: "8.10.2"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
@@ -152,7 +152,7 @@ test:freebsd:recommended:
test:freebsd:latest:
extends: .test_ghcup_version:freebsd
variables:
GHC_VERSION: "8.10.1"
GHC_VERSION: "8.10.2"
CABAL_VERSION: "3.2.0.0"
allow_failure: true

View File

@@ -20,22 +20,28 @@ git describe --always
ecabal update
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui
ecabal test -w ghc-${GHC_VERSION} -ftui ghcup-test
elif [ "${OS}" = "LINUX" ] ; then
if [ "${BIT}" = "32" ] ; then
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui -ftar ghcup-test
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
fi
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
fi
ecabal haddock -w ghc-${GHC_VERSION} -ftar
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
cp ./ghcup "$CI_PROJECT_DIR"/.local/bin/ghcup
cp ./ghcup-gen "$CI_PROJECT_DIR"/.local/bin/ghcup-gen
@@ -87,6 +93,18 @@ eghcup set ${GHC_VERSION}
eghcup rm 8.4.4
[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
# install hls
if [ "${OS}" = "DARWIN" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
elif [ "${OS}" = "LINUX" ] ; then
if [ "${BIT}" = "64" ] ; then
eghcup install hls
haskell-language-server-wrapper --version
fi
fi
eghcup rm $(ghc --numeric-version)
eghcup upgrade

View File

@@ -1,5 +1,32 @@
# Revision history for ghcup
## 0.1.11 -- ????-??-??
* Add support for installing haskell-language-server, wrt #65
* When compiling GHC from source create a bindist first, store that bindist in `~/.ghcup/cache` and install it, wrt #51
* Allow to compile over existing version (`ghcup compile ghc -v 8.6.5 -b 8.6.5`) and replace it wrt #59
* simplify installing from custom bindist wrt #60
- `ghcup install ghc -u <url> <version>`
* fix bug when cabal isn't marked executable in bindist
* fix bug when `~/.ghcup` is a valid symlink wrt #49
* Drop support for compiling cabal from source (the old bootstrap script is discontinued)
## 0.1.10 -- 2020-08-14
* Show stray Cabals (useful for pre-releases or compiled ones)
## 0.1.9 -- 2020-08-14
* Fix bug when uninstalling all cabal versions
* Fix bug when setting a non-installed ghc version as current default
* Use yaml instead of generated json for download info for ease of adding new GHC versions #44
* Allow pre-release versions of GHC/cabal
* Add XDG dirs support (set `GHCUP_USE_XDG_DIRS`) wrt #39
* Allow to specify regex for tarball subdir (e.g. `ghc-.*`)
* Allow installing arbitrary bindists more seamlessly:
- e.g. installing GHC HEAD: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27" }' head`
* Avoid duplicate edits to .bashrc/.zshrc wrt #43
## 0.1.8 -- 2020-07-21
* Fix bug in logging thread dying on newlines

View File

@@ -9,11 +9,15 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
## Table of Contents
* [Installation](#installation)
* [Simple bootstrap](#simple-bootstrap)
* [Manual install](#manual-install)
* [Vim integration](#vim-integration)
* [Usage](#usage)
* [Manpages](#manpages)
* [Shell-completion](#shell-completion)
* [Cross support](#cross-support)
* [XDG support](#xdg-support)
* [Installing custom bindists](#installing-custom-bindists)
* [Design goals](#design-goals)
* [How](#how)
* [Known users](#known-users)
@@ -37,6 +41,10 @@ Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) lik
export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
```
### Vim integration
See [ghcup.vim](https://github.com/hasufell/ghcup.vim).
## Usage
See `ghcup --help`.
@@ -97,7 +105,7 @@ For distributions with non-standard locations of cross toolchain and
libraries, this may need some tweaking of `build.mk` or configure args.
See `ghcup compile ghc --help` for further information.
### Cross support
### XDG support
To enable XDG style directories, set the environment variable `GHCUP_USE_XDG_DIRS` to anything.
@@ -107,6 +115,22 @@ Then you can control the locations via XDG environment variables as such:
* `XDG_CACHE_HOME`: logs and download files will be stored in `ghcup` subdir
* `XDG_BIN_HOME`: binaries end up here (default: `~/.local/bin`)
### Installing custom bindists
There are a couple of good use cases to install custom bindists:
1. manually built bindists (e.g. with patches)
- example: `ghcup install ghc -u 'file:///home/mearwald/tmp/ghc-eff-patches/ghc-8.10.2-x86_64-deb10-linux.tar.xz' 8.10.2-eff`
2. GHC head CI bindists
- example: `ghcup install ghc -u 'https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27' head`
3. DWARF bindists
- example: `ghcup install ghc -u 'https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-deb10-linux-dwarf.tar.xz' 8.10.2-dwarf`
Since the version parser is pretty lax, `8.10.2-eff` and `head` are both valid versions
and produce the binaries `ghc-8.10.2-eff` and `ghc-head` respectively.
GHCup always needs to know which version the bindist corresponds to (this is not automatically
detected).
## Design goals
1. simplicity

View File

@@ -55,7 +55,7 @@ validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
validate dls = do
ref <- liftIO $ newIORef 0
-- * verify binary downloads * --
-- verify binary downloads --
flip runReaderT ref $ do
-- unique tags
forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t

View File

@@ -71,19 +71,26 @@ ui AppState {..} =
( padBottom Max
$ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
$ (center $ renderList renderItem True lr)
$ (center $ (header <=> hBorder <=> renderList renderItem True lr))
)
)
<=> ( withAttr "help"
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. (++ ["↑↓:Navigation"])
$ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
)
<=> footer
where
renderItem b ListResult {..} =
footer =
withAttr "help"
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. (++ ["↑↓:Navigation"])
$ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
header =
(minHSize 2 $ emptyWidget)
<+> (padLeft (Pad 2) $ minHSize 6 $ str "Tool")
<+> (minHSize 15 $ str "Version")
<+> (padLeft (Pad 1) $ minHSize 25 $ str "Tags")
<+> (padLeft (Pad 5) $ str "Notes")
renderItem b listResult@(ListResult {..}) =
let marks = if
| lSet -> (withAttr "set" $ str "✔✔")
| lInstalled -> (withAttr "installed" $ str "")
@@ -94,20 +101,28 @@ ui AppState {..} =
dim = if lNoBindist
then updateAttrMap (const dimAttributes) . withAttr "no-bindist"
else id
active = if b then withAttr "active" else id
in dim
( marks
<+> ( padLeft (Pad 2)
$ minHSize 20
$ ((if b then withAttr "active" else id)
(str $ (fmap toLower . show $ lTool) <> " " <> ver)
)
<+> (( padLeft (Pad 2)
$ active
$ minHSize 6
$ (str (fmap toLower . show $ lTool))
)
)
<+> (padLeft (Pad 1) $ if null lTag
<+> (minHSize 15 $ active $ (str ver))
<+> (padLeft (Pad 1) $ minHSize 25 $ if null lTag
then emptyWidget
else
foldr1 (\x y -> x <+> str "," <+> y)
$ (fmap printTag $ sort lTag)
)
<+> ( padLeft (Pad 5)
$ let notes = printNotes listResult
in if null notes
then emptyWidget
else foldr1 (\x y -> x <+> str "," <+> y) $ notes
)
)
printTag Recommended = withAttr "recommended" $ str "recommended"
@@ -116,6 +131,13 @@ ui AppState {..} =
printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag (UnknownTag t ) = str t
printNotes ListResult {..} =
(if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty
)
++ (if fromSrc then [withAttr "compiled" $ str "compiled"] else mempty)
++ (if lStray then [withAttr "stray" $ str "stray"] else mempty)
minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
@@ -137,8 +159,11 @@ defaultAttributes = attrMap
, ("set" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("hls-powered" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow)
, ("prerelease" , Vty.defAttr `Vty.withForeColor` Vty.red)
, ("compiled" , Vty.defAttr `Vty.withForeColor` Vty.blue)
, ("stray" , Vty.defAttr `Vty.withForeColor` Vty.blue)
, ("help" , Vty.defAttr `Vty.withStyle` Vty.italic)
]
@@ -223,6 +248,7 @@ install' AppState {..} (_, ListResult {..}) = do
GHC -> liftE $ installGHCBin dls lVer pfreq
Cabal -> liftE $ installCabalBin dls lVer pfreq
GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> ()
HLS -> liftE $ installHLSBin dls lVer pfreq $> ()
)
>>= \case
VRight _ -> pure $ Right ()
@@ -251,6 +277,7 @@ set' _ (_, ListResult {..}) = do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
HLS -> liftE $ setHLS lVer $> ()
GHCup -> pure ()
)
>>= \case
@@ -270,6 +297,7 @@ del' _ (_, ListResult {..}) = do
case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> ()
Cabal -> liftE $ rmCabalVer lVer $> ()
HLS -> liftE $ rmHLSVer lVer $> ()
GHCup -> pure ()
)
>>= \case

View File

@@ -39,7 +39,6 @@ import Control.Monad.Fail ( MonadFail )
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Aeson ( eitherDecode )
import Data.Bifunctor
import Data.Char
import Data.Either
@@ -65,16 +64,15 @@ import System.Environment
import System.Exit
import System.IO hiding ( appendFile )
import Text.Read hiding ( lift )
import Text.Layout.Table
import URI.ByteString
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy.UTF8 as BLU
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
@@ -118,15 +116,17 @@ prettyToolVer (ToolTag t) = show t
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
| InstallHLS InstallOptions
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe DownloadInfo
, instBindist :: Maybe URI
}
data SetCommand = SetGHC SetOptions
| SetCabal SetOptions
| SetHLS SetOptions
data SetOptions = SetOptions
{ sToolVer :: Maybe ToolVersion
@@ -140,6 +140,7 @@ data ListOptions = ListOptions
data RmCommand = RmGHC RmOptions
| RmCabal Version
| RmHLS Version
data RmOptions = RmOptions
{ ghcVer :: GHCTargetVersion
@@ -147,7 +148,6 @@ data RmOptions = RmOptions
data CompileCommand = CompileGHC GHCCompileOptions
| CompileCabal CabalCompileOptions
data GHCCompileOptions = GHCCompileOptions
@@ -207,8 +207,8 @@ opts =
( long "keep"
<> metavar "<always|errors|never>"
<> help
"Keep build directories? (default: never)"
<> value Never
"Keep build directories? (default: errors)"
<> value Errors
<> hidden
)
<*> option
@@ -396,10 +396,29 @@ installParser =
)
)
)
<> command
"hls"
( InstallHLS
<$> (info
(installOpts <**> helper)
( progDesc "Install haskell-languge-server"
<> footerDoc (Just $ text installHLSFooter)
)
)
)
)
)
<|> (Right <$> installOpts)
where
installHLSFooter :: String
installHLSFooter = [s|Discussion:
Installs haskell-language-server binaries and wrapper
into "~/.ghcup/bin"
Examples:
# install recommended GHC
ghcup install hls|]
installGHCFooter :: String
installGHCFooter = [s|Discussion:
Installs the specified GHC version (or a recommended default one) into
@@ -407,13 +426,22 @@ installParser =
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
Examples:
# install GHC head
ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27" }' head|]
# install recommended GHC
ghcup install ghc
# install latest GHC
ghcup install ghc latest
# install GHC 8.10.2
ghcup install ghc 8.10.2
# install GHC head fedora bindist
ghcup install ghc -u https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27 head|]
installOpts :: Parser InstallOptions
installOpts =
(\p u v -> InstallOptions v p u)
(\p (u, v) -> InstallOptions v p u)
<$> (optional
(option
(eitherReader platformParser)
@@ -425,18 +453,19 @@ installOpts =
)
)
)
<*> (optional
(option
(eitherReader bindistParser)
( short 'u'
<> long "url"
<> metavar "BINDIST_URL"
<> help
"Provide DownloadInfo as json string, e.g.: '{ \"dlHash\": \"<sha256 hash>\", \"dlSubdir\": { \"RegexDir\": \"ghc-.*\"}, \"dlUri\": \"<uri>\" }'"
<*> ( ( (,)
<$> (optional
(option
(eitherReader bindistParser)
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
"Install the specified version from this bindist"
)
)
)
<*> (Just <$> toolVersionArgument)
)
)
<|> ((,) <$> pure Nothing <*> optional toolVersionArgument)
)
<*> optional toolVersionArgument
setParser :: Parser (Either SetCommand SetOptions)
@@ -462,6 +491,16 @@ setParser =
)
)
)
<> command
"hls"
( SetHLS
<$> (info
(setOpts <**> helper)
( progDesc "Set haskell-language-server version"
<> footerDoc (Just $ text setHLSFooter)
)
)
)
)
)
<|> (Right <$> setOpts)
@@ -476,6 +515,10 @@ setParser =
setCabalFooter = [s|Discussion:
Sets the the current Cabal version.|]
setHLSFooter :: String
setHLSFooter = [s|Discussion:
Sets the the current haskell-language-server version.|]
setOpts :: Parser SetOptions
setOpts = SetOptions <$> optional toolVersionArgument
@@ -518,6 +561,13 @@ rmParser =
(progDesc "Remove Cabal version")
)
)
<> command
"hls"
( RmHLS
<$> (info (versionParser' <**> helper)
(progDesc "Remove haskell-language-server version")
)
)
)
)
<|> (Right <$> rmOpts)
@@ -561,16 +611,6 @@ compileP = subparser
)
)
)
<> command
"cabal"
( CompileCabal
<$> (info
(cabalCompileOpts <**> helper)
( progDesc "Compile Cabal from source"
<> footerDoc (Just $ text compileCabalFooter)
)
)
)
)
where
compileFooter = [s|Discussion:
@@ -591,13 +631,6 @@ Examples:
ghcup compile ghc -j 4 -v 8.4.2 -b /usr/bin/ghc-8.2.2
# build cross compiler
ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 -x armv7-unknown-linux-gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|]
compileCabalFooter = [i|Discussion:
Compiles and installs the specified Cabal version
into "~/.ghcup/bin".
Examples:
ghcup compile cabal -j 4 -v 3.2.0.0 -b 8.6.5
ghcup compile cabal -j 4 -v 3.2.0.0 -b /usr/bin/ghc-8.6.5|]
ghcCompileOpts :: Parser GHCCompileOptions
@@ -819,8 +852,8 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
pure v
bindistParser :: String -> Either String DownloadInfo
bindistParser = eitherDecode . BLU.fromString
bindistParser :: String -> Either String URI
bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString
toSettings :: Options -> IO Settings
@@ -910,7 +943,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
settings@Settings{dirs = Dirs{..}, ..} <- toSettings opt
-- create ~/.ghcup dir
createDirRecursive newDirPerms baseDir
createDirRecursive' baseDir
-- logger interpreter
logfile <- flip runReaderT settings $ initGHCupFileLogging [rel|ghcup.log|]
@@ -926,9 +959,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- Effect interpreters --
-------------------------
let runInstTool =
let runInstTool' settings' =
runLogger
. flip runReaderT settings
. flip runReaderT settings'
. runResourceT
. runE
@'[ AlreadyInstalled
@@ -947,6 +980,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TarDirDoesNotExist
]
let runInstTool = runInstTool' settings
let
runSetGHC =
runLogger
@@ -966,6 +1001,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TagNotFound
]
let
runSetHLS =
runLogger
. flip runReaderT settings
. runE
@'[ NotInstalled
, TagNotFound
]
let runListGHC = runLogger . flip runReaderT settings
let runRm =
@@ -992,26 +1036,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
let runCompileCabal =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
, BuildFailed
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@@ -1070,11 +1095,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-----------------------
let installGHC InstallOptions{..} =
(runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC
case instBindist of
Nothing -> liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> liftE $ installGHCBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
(case instBindist of
Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> runInstTool' settings{noVerify = True} $ do
v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
)
>>= \case
VRight _ -> do
@@ -1082,7 +1112,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
[i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|]
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
@@ -1106,11 +1136,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installCabal InstallOptions{..} =
(runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal
case instBindist of
Nothing -> liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> liftE $ installCabalBindist uri (_tvVersion v) (fromMaybe pfreq instPlatform)
(case instBindist of
Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> runInstTool' settings{noVerify = True} $ do
v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
)
>>= \case
VRight _ -> do
@@ -1118,7 +1153,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|Cabal ver #{prettyVer v} already installed|]
[i|Cabal ver #{prettyVer v} already installed, you may want to run 'ghcup rm cabal #{prettyVer v}' first|]
pure ExitSuccess
VLeft (V NoDownload) -> do
@@ -1133,6 +1168,40 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
$(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 4
let installHLS InstallOptions{..} =
(case instBindist of
Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
Just uri -> runInstTool' settings{noVerify = True} $ do
v <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBindist
(DownloadInfo uri Nothing "")
(_tvVersion v)
(fromMaybe pfreq instPlatform)
)
>>= \case
VRight _ -> do
runLogger $ $(logInfo) ("HLS installation successful")
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|HLS ver #{prettyVer v} already installed, you may want to run 'ghcup rm hls #{prettyVer v}' first|]
pure ExitSuccess
VLeft (V NoDownload) -> do
runLogger $ do
case instVer of
Just iver -> $(logError) [i|No available HLS version for #{prettyToolVer iver}|]
Nothing -> $(logError) [i|No available recommended HLS version|]
pure $ ExitFailure 4
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in #{logsDir}|]
pure $ ExitFailure 4
let setGHC' SetOptions{..} =
(runSetGHC $ do
v <- liftE $ fromVersion dls sToolVer GHC
@@ -1159,6 +1228,17 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 14
let setHLS' SetOptions{..} =
(runSetHLS $ do
v <- liftE $ fromVersion dls sToolVer HLS
liftE $ setHLS (_tvVersion v)
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
(runRm $ do
liftE $ rmGHCVer ghcVer
@@ -1179,6 +1259,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 15
let rmHLS' tv =
(runRm $ do
liftE $ rmHLSVer tv
)
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 15
res <- case optCommand of
@@ -1190,6 +1279,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
installGHC iopts
Install (Left (InstallGHC iopts)) -> installGHC iopts
Install (Left (InstallCabal iopts)) -> installCabal iopts
Install (Left (InstallHLS iopts)) -> installHLS iopts
InstallCabalLegacy iopts -> do
runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
installCabal iopts
@@ -1199,6 +1289,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
setGHC' sopts
Set (Left (SetGHC sopts)) -> setGHC' sopts
Set (Left (SetCabal sopts)) -> setCabal' sopts
Set (Left (SetHLS sopts)) -> setHLS' sopts
List (ListOptions {..}) ->
(runListGHC $ do
@@ -1212,6 +1303,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
rmGHC' rmopts
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
Rm (Left (RmHLS rmopts)) -> rmHLS' rmopts
DInfo ->
do
@@ -1241,7 +1333,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
[i|GHC ver #{prettyVer v} already installed, you may want to run 'ghcup rm ghc #{prettyVer v}' first|]
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
@@ -1255,28 +1347,6 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 9
Compile (CompileCabal CabalCompileOptions {..}) ->
(runCompileCabal $ do
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir pfreq
)
>>= \case
VRight _ -> do
runLogger
($(logInfo)
"Cabal successfully compiled and installed"
)
pure ExitSuccess
VLeft (V (BuildFailed tmpdir e)) -> do
case keepDirs of
Never -> runLogger ($(logError) [i|Build failed with #{e}|])
_ -> runLogger ($(logError) [i|Build failed with #{e}
Check the logs at #{logsDir} and the build directory #{tmpdir} for more clues.
Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 10
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 10
Upgrade (uOpts) force -> do
target <- case uOpts of
UpgradeInplace -> do
@@ -1393,49 +1463,144 @@ printListResult raw lr = do
setLocaleEncoding utf8
let
formatted =
gridString
( (if raw then [] else [column expand left def def])
++ [ column expand left def def
, column expand left def def
, column expand left def def
, column expand left def def
]
)
. (\x -> if raw
then x
else [color Green "", "Tool", "Version", "Tags", "Notes"] : x
)
$ fmap
rows =
(\x -> if raw
then x
else [color Green "", "Tool", "Version", "Tags", "Notes"] : x
)
. fmap
(\ListResult {..} ->
let marks = if
| lSet -> (color Green "✔✔")
| lInstalled -> (color Green "")
| otherwise -> (color Red "")
in (if raw then [] else [marks])
++ [ fmap toLower . show $ lTool
, case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
, intercalate "," $ (fmap printTag $ sort lTag)
, intercalate ","
$ (if fromSrc then [color' Blue "compiled"] else mempty)
++ (if lStray then [color' Yellow "stray"] else mempty)
++ (if lNoBindist then [color' Red "no-bindist"] else mempty)
]
| lInstalled -> (color Green " ")
| otherwise -> (color Red " ")
in
(if raw then [] else [marks])
++ [ fmap toLower . show $ lTool
, case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
, intercalate "," $ (fmap printTag $ sort lTag)
, intercalate ","
$ (if hlsPowered
then [color' Green "hls-powered"]
else mempty
)
++ (if fromSrc then [color' Blue "compiled"] else mempty)
++ (if lStray then [color' Yellow "stray"] else mempty)
++ (if lNoBindist
then [color' Red "no-bindist"]
else mempty
)
]
)
lr
putStrLn $ formatted
$ lr
let cols =
foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows
lengths = fmap maximum . (fmap . fmap) strWidth $ cols
padded = fmap (\xs -> zipWith padTo xs lengths) rows
forM_ padded $ \row -> putStrLn $ intercalate " " row
where
printTag Recommended = color' Green "recommended"
printTag Latest = color' Yellow "latest"
printTag Prerelease = color' Red "prerelease"
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (UnknownTag t ) = t
color' = case raw of
True -> flip const
False -> color
padTo str' x =
let lstr = strWidth str'
add' = x - lstr
in if add' < 0 then str' else str' ++ replicate add' ' '
-- | Calculate the render width of a string, considering
-- wide characters (counted as double width), ANSI escape codes
-- (not counted), and line breaks (in a multi-line string, the longest
-- line determines the width).
strWidth :: String -> Int
strWidth =
maximum
. (0 :)
. map (foldr (\a b -> charWidth a + b) 0)
. lines
. stripAnsi
-- | Strip ANSI escape sequences from a string.
--
-- >>> stripAnsi "\ESC[31m-1\ESC[m"
-- "-1"
stripAnsi :: String -> String
stripAnsi s' =
case
MP.parseMaybe (many $ "" <$ MP.try ansi <|> pure <$> MP.anySingle) s'
of
Nothing -> error "Bad ansi escape" -- PARTIAL: should not happen
Just xs -> concat xs
where
-- This parses lots of invalid ANSI escape codes, but that should be fine
ansi =
MPC.string "\ESC[" *> digitSemicolons *> suffix MP.<?> "ansi" :: MP.Parsec
Void
String
Char
digitSemicolons = MP.takeWhileP Nothing (\c -> isDigit c || c == ';')
suffix = MP.oneOf ['A', 'B', 'C', 'D', 'H', 'J', 'K', 'f', 'm', 's', 'u']
-- | Get the designated render width of a character: 0 for a combining
-- character, 1 for a regular character, 2 for a wide character.
-- (Wide characters are rendered as exactly double width in apps and
-- fonts that support it.) (From Pandoc.)
charWidth :: Char -> Int
charWidth c = case c of
_ | c < '\x0300' -> 1
| c >= '\x0300' && c <= '\x036F' -> 0
| -- combining
c >= '\x0370' && c <= '\x10FC' -> 1
| c >= '\x1100' && c <= '\x115F' -> 2
| c >= '\x1160' && c <= '\x11A2' -> 1
| c >= '\x11A3' && c <= '\x11A7' -> 2
| c >= '\x11A8' && c <= '\x11F9' -> 1
| c >= '\x11FA' && c <= '\x11FF' -> 2
| c >= '\x1200' && c <= '\x2328' -> 1
| c >= '\x2329' && c <= '\x232A' -> 2
| c >= '\x232B' && c <= '\x2E31' -> 1
| c >= '\x2E80' && c <= '\x303E' -> 2
| c == '\x303F' -> 1
| c >= '\x3041' && c <= '\x3247' -> 2
| c >= '\x3248' && c <= '\x324F' -> 1
| -- ambiguous
c >= '\x3250' && c <= '\x4DBF' -> 2
| c >= '\x4DC0' && c <= '\x4DFF' -> 1
| c >= '\x4E00' && c <= '\xA4C6' -> 2
| c >= '\xA4D0' && c <= '\xA95F' -> 1
| c >= '\xA960' && c <= '\xA97C' -> 2
| c >= '\xA980' && c <= '\xABF9' -> 1
| c >= '\xAC00' && c <= '\xD7FB' -> 2
| c >= '\xD800' && c <= '\xDFFF' -> 1
| c >= '\xE000' && c <= '\xF8FF' -> 1
| -- ambiguous
c >= '\xF900' && c <= '\xFAFF' -> 2
| c >= '\xFB00' && c <= '\xFDFD' -> 1
| c >= '\xFE00' && c <= '\xFE0F' -> 1
| -- ambiguous
c >= '\xFE10' && c <= '\xFE19' -> 2
| c >= '\xFE20' && c <= '\xFE26' -> 1
| c >= '\xFE30' && c <= '\xFE6B' -> 2
| c >= '\xFE70' && c <= '\xFEFF' -> 1
| c >= '\xFF01' && c <= '\xFF60' -> 2
| c >= '\xFF61' && c <= '\x16A38' -> 1
| c >= '\x1B000' && c <= '\x1B001' -> 2
| c >= '\x1D000' && c <= '\x1F1FF' -> 1
| c >= '\x1F200' && c <= '\x1F251' -> 2
| c >= '\x1F300' && c <= '\x1F773' -> 1
| c >= '\x20000' && c <= '\x3FFFD' -> 2
| otherwise -> 1
checkForUpdates :: (MonadReader Settings m, MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
=> GHCupDownloads
-> PlatformRequest
@@ -1461,6 +1626,13 @@ checkForUpdates dls pfreq = do
$ $(logWarn)
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
forM_ (getLatest dls HLS) $ \l -> do
mcabal_ver <- latestInstalled HLS
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
$ $(logWarn)
[i|New HLS version available: #{prettyVer l}. To upgrade, run 'ghcup install hls #{prettyVer l}'|]
where
latestInstalled tool = (fmap lVer . lastMay)
<$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
@@ -1476,20 +1648,4 @@ GHCup cache directory: #{toFilePath diCacheDir}
Architecture: #{prettyArch diArch}
Platform: #{prettyPlatform diPlatform}
Version: #{describe_result}|]
where
prettyArch :: Architecture -> String
prettyArch A_64 = "amd64"
prettyArch A_32 = "i386"
prettyArch A_PowerPC = "PowerPC"
prettyArch A_PowerPC64 = "PowerPC64"
prettyArch A_Sparc = "Sparc"
prettyArch A_Sparc64 = "Sparc64"
prettyArch A_ARM = "ARM"
prettyArch A_ARM64 = "ARM64"
prettyPlatform :: PlatformResult -> String
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
= show plat <> ", " <> show v'
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing }
= show plat

View File

@@ -59,7 +59,7 @@ _done() {
download_ghcup() {
_plat="$(uname -s)"
_arch=$(uname -m)
_ghver="0.1.8"
_ghver="0.1.10"
_base_url="https://downloads.haskell.org/~ghcup"
case "${_plat}" in
@@ -235,7 +235,7 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
if ! grep -q "ghcup-env" "${GHCUP_PROFILE_FILE}" ; then
echo "# ghcup-env" >> "${GHCUP_PROFILE_FILE}"
echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
echo "test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN/bin \$PATH" >> "${GHCUP_PROFILE_FILE}"
echo "test -f $GHCUP_DIR/env ; and set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN \$PATH" >> "${GHCUP_PROFILE_FILE}"
fi
break ;;
*)

View File

@@ -8,6 +8,24 @@ source-repository-package
tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42
subdir: haskus-utils-types
source-repository-package
type: git
location: https://github.com/hasufell/hpath.git
tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2
subdir: hpath-io
source-repository-package
type: git
location: https://github.com/hasufell/hpath.git
tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2
subdir: hpath-directory
-- https://github.com/cjdev/text-conversions/pull/10
source-repository-package
type: git
location: https://github.com/hasufell/text-conversions.git
tag: 9abf0e5e5664a3178367597c32db19880477a53c
optimization: 2
package streamly
@@ -19,6 +37,6 @@ package ghcup
constraints: http-io-streams -brotli
package libarchive
flags: +static
flags: -system-libarchive
allow-newer: base, ghc-prim, template-haskell

View File

@@ -1,4 +1,3 @@
# !!! if you use RegexDir, then the version must be bumped !!!
---
toolRequirements:
GHC:
@@ -1160,7 +1159,7 @@ ghcupDownloads:
Linux_Alpine:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-alpine3.10-linux-integer-simple.tar.xz
dlSubdir: ghc-8.10.2
dlSubdir: ghc-8.10.2-x86_64-unknown-linux
dlHash: 14d09a508f2a3a11875c140be8e6c5f6982ac5cd448f089ca10b7adc955fec76
Linux_AmazonLinux:
unknown_versioning: *ghc-8102-64-centos
@@ -1189,14 +1188,15 @@ ghcupDownloads:
unknown_versioning: *ghc-8102-32-deb9
Linux_UnknownLinux:
unknown_versioning: *ghc-8102-32-deb9
Linux_Alpine:
unknown_versioning:
dlUri: https://files.hasufell.de/ghc/ghc-8.10.2-i386-alpine-linux.tar.xz
dlSubdir: ghc-8.10.2
dlHash: 9ee1cf1e85e9536088b3c9e80e975074e525ea378cd4eb156071bbc4b7b38327
Cabal:
2.4.1.0:
viTags: []
viChangeLog: https://downloads.haskell.org/~cabal/cabal-install-2.4.1.0/changelog
viSourceDL:
dlUri: https://github.com/haskell/cabal/archive/cabal-install-v2.4.1.0.tar.gz
dlSubdir: cabal-cabal-install-v2.4.1.0/cabal-install
dlHash: 61eb64a5addafca026aff9277291f4643fe07e83886f76d059d42c734fed829c
viArch:
A_64:
Linux_Alpine:
@@ -1228,10 +1228,6 @@ ghcupDownloads:
3.0.0.0:
viTags: []
viChangeLog: https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/changelog
viSourceDL:
dlUri: https://github.com/haskell/cabal/archive/cabal-install-v3.0.0.0.tar.gz
dlSubdir: cabal-cabal-install-v3.0.0.0/cabal-install
dlHash: c0b26817a7b7c2907e45cb38235ce1157e732211880f62e92eaff4066202e674
viArch:
A_64:
Linux_Alpine:
@@ -1264,10 +1260,6 @@ ghcupDownloads:
- Recommended
- Latest
viChangeLog: https://downloads.haskell.org/~cabal/cabal-install-3.2.0.0/changelog
viSourceDL:
dlUri: https://github.com/haskell/cabal/archive/cabal-install-v3.2.0.0.tar.gz
dlSubdir: cabal-cabal-install-v3.2.0.0/cabal-install
dlHash: 77202358bdf0b481c09326268ce18880df14194c5aaa840f99510bdd1a124b75
viArch:
A_64:
Linux_Alpine:
@@ -1295,8 +1287,32 @@ ghcupDownloads:
unknown_versioning:
dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.2.0.0/cabal-install-3.2.0.0-i386-unknown-linux.tar.xz
dlHash: 2b3ac28549916de5f3379241797eaf60e84b6c001f2abbe73d9fadbbaf768e93
3.4.0.0-rc3:
viTags:
- Prerelease
viChangeLog: https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.4.0.0.md
viArch:
A_64:
Linux_Ubuntu:
unknown_versioning: &cabal-3400rc3-ubuntu
dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc3/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz
dlHash: a97f0362b8cdc78ba4a7891f8b288082dc11e20c64b1b3c8e6c2bd3766446d10
Linux_Alpine:
unknown_versioning:
dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc3/cabal-install-3.4.0.0-x86_64-alpine-3.11.6-static-noofd.tar.xz
dlHash: a82c7dc7e46da823f6a982465b9b29e0640a5ce2e5b573d3dd55a47e20740305
Linux_UnknownLinux:
unknown_versioning: *cabal-3400rc3-ubuntu
Darwin:
unknown_versioning:
dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc3/cabal-install-3.4.0.0-x86_64-darwin-sierra.tar.xz
dlHash: 4553eaea3031c09ab5156af8d4a62bf1ecbbea2c3b57a876f267cbf4b5a15658
FreeBSD:
unknown_versioning:
dlUri: https://oleg.fi/cabal-install-3.4.0.0-rc3/cabal-install-3.4.0.0-x86_64-freebsd-12.1-release.tar.xz
dlHash: 44e25e0b0d15361acb369f4bf2206a39d2432a08fb922cc40a9b8a045d0a3a6f
GHCup:
0.1.8:
0.1.10:
viTags:
- Recommended
- Latest
@@ -1306,22 +1322,39 @@ ghcupDownloads:
A_64:
Linux_UnknownLinux:
unknown_versioning: &ghcup-64
dlUri: https://downloads.haskell.org/~ghcup/0.1.8/x86_64-linux-ghcup-0.1.8
dlHash: 7ffcd4c3de156e895b648c75a36c762be2a4932883f3cd598f7a483c97d4a8a9
dlUri: https://downloads.haskell.org/~ghcup/0.1.10/x86_64-linux-ghcup-0.1.10
dlHash: 87661bd127f857b990174ac8d96ad4bd629865306b2058c8cc64d3b36ed317c9
Darwin:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.8/x86_64-apple-darwin-ghcup-0.1.8
dlHash: b6efc25013a20734e93ad7ae4ecf319f19eeee2129d515d568ccf0003f26615f
dlUri: https://downloads.haskell.org/~ghcup/0.1.10/x86_64-apple-darwin-ghcup-0.1.10
dlHash: e71666fde6a7700f307e1a55720859d3a042fe27c68ff32f3d1181f4436b7391
FreeBSD:
unknown_versioning:
dlUri: https://downloads.haskell.org/~ghcup/0.1.8/x86_64-portbld-freebsd-ghcup-0.1.8
dlHash: 442cdfe1b4525a327d9566e6270f909f7deba21c16dd4c7912537cf67e6cd521
dlUri: https://downloads.haskell.org/~ghcup/0.1.10/x86_64-portbld-freebsd-ghcup-0.1.10
dlHash: b5ef1b0454f1a9c5a62b378c1e9c48c2b794d64a22086adf482b064dfb34e68d
Linux_Alpine:
unknown_versioning: *ghcup-64
A_32:
Linux_UnknownLinux:
unknown_versioning: &ghcup-32
dlUri: https://downloads.haskell.org/~ghcup/0.1.8/i386-linux-ghcup-0.1.8
dlHash: 18ab162920cea662feae4b08f39d3879e9e416fde7b734afd8072c39d3c43cde
dlUri: https://downloads.haskell.org/~ghcup/0.1.10/i386-linux-ghcup-0.1.10
dlHash: 50ac43199b64bc0724400b0a3db674bef3ec53cf6d41acc04a2c4ca8557e534f
Linux_Alpine:
unknown_versioning: *ghcup-32
HLS:
0.4.0:
viTags:
- Recommended
- Latest
viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#040
viArch:
A_64:
Linux_UnknownLinux:
unknown_versioning:
dlUri: https://github.com/haskell/haskell-language-server/releases/download/0.4.0/haskell-language-server-Linux-0.4.0.tar.gz
dlHash: 325b21b38a5e570f00b983885e8ec1eadcb5504a29b28ea4cbe1b85b32058f6d
Darwin:
unknown_versioning:
dlUri: https://github.com/haskell/haskell-language-server/releases/download/0.4.0/haskell-language-server-macOS-0.4.0.tar.gz
dlHash: 06a23f1495086438e9676213f7aeddbbc382014ad8016ed7c8ad241a2a15fcfe

View File

@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.8
version: 0.1.11
synopsis: ghc toolchain installer as an exe/library
description:
A rewrite of the shell script ghcup, for providing
@@ -81,6 +81,9 @@ common containers
common cryptohash-sha256
build-depends: cryptohash-sha256 >= 0.11.101.0
common generic-arbitrary
build-depends: generic-arbitrary >=0.1.0
common generics-sop
build-depends: generics-sop >=0.5
@@ -94,13 +97,13 @@ common hpath
build-depends: hpath >=0.11
common hpath-directory
build-depends: hpath-directory >=0.14
build-depends: hpath-directory >=0.14.1
common hpath-filepath
build-depends: hpath-filepath >=0.10.3
common hpath-io
build-depends: hpath-io >=0.14
build-depends: hpath-io >=0.14.1
common hpath-posix
build-depends: hpath-posix >=0.13.2
@@ -108,11 +111,17 @@ common hpath-posix
common http-io-streams
build-depends: http-io-streams >=0.1.2.0
common hspec
build-depends: hspec >=2.7.4
common hspec-golden-aeson
build-depends: hspec-golden-aeson >=0.7
common io-streams
build-depends: io-streams >=1.5
common libarchive
build-depends: libarchive >= 2.2.5.0
build-depends: libarchive >= 3.0.0.0
common lzma
build-depends: lzma >=0.0.0.3
@@ -171,9 +180,6 @@ common strict-base
common string-interpolate
build-depends: string-interpolate >=0.2.0.0
common table-layout
build-depends: table-layout >=0.8
common template-haskell
build-depends: template-haskell >=2.7
@@ -195,6 +201,12 @@ common transformers
common os-release
build-depends: os-release >=1.0.0
common QuickCheck
build-depends: QuickCheck >=2.14.1
common quickcheck-arbitrary-adt
build-depends: quickcheck-arbitrary-adt >=0.3.1.0
common unix
build-depends: unix >=2.7
@@ -240,8 +252,6 @@ common config
PackageImports
RecordWildCards
ScopedTypeVariables
Strict
StrictData
TupleSections
library
@@ -321,6 +331,10 @@ library
GHCup.Utils.Version.QQ
GHCup.Version
default-extensions:
Strict
StrictData
-- other-modules:
-- other-extensions:
hs-source-dirs: lib
@@ -361,7 +375,6 @@ executable ghcup
, safe
, safe-exceptions
, string-interpolate
, table-layout
, template-haskell
, text
, uri-bytestring
@@ -377,6 +390,10 @@ executable ghcup
hs-source-dirs: app/ghcup
default-language: Haskell2010
default-extensions:
Strict
StrictData
if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER
@@ -412,7 +429,6 @@ executable ghcup-gen
, resourcet
, safe-exceptions
, string-interpolate
, table-layout
, text
, transformers
, uri-bytestring
@@ -431,8 +447,25 @@ executable ghcup-gen
default-language: Haskell2010
test-suite ghcup-test
default-language: Haskell2010
import:
config
, base
, bytestring
, containers
, QuickCheck
, generic-arbitrary
, hpath
, hspec
, hspec-golden-aeson
, quickcheck-arbitrary-adt
, text
, uri-bytestring
, versions
type: exitcode-stdio-1.0
build-depends: ghcup
hs-source-dirs: test
main-is: MyLibTest.hs
build-depends: base >=4.12.0.0
main-is: Main.hs
other-modules:
GHCup.ArbitraryTypes
GHCup.Types.JSONSpec
Spec

10767
golden/GHCupInfo.json Normal file

File diff suppressed because it is too large Load Diff

View File

@@ -2,3 +2,5 @@ cradle:
cabal:
- path: "."
component: "ghcup:lib:ghcup"
- path: "."
component: "ghcup:exe:ghcup"

View File

@@ -75,9 +75,12 @@ import Prelude hiding ( abs
import Safe hiding ( at )
import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment )
import System.Posix.FilePath ( getSearchPath )
import System.Posix.FilePath ( getSearchPath, takeExtension )
import System.Posix.Files.ByteString
import Text.Regex.Posix
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
@@ -119,7 +122,7 @@ installGHCBindist :: ( MonadFail m
]
m
()
installGHCBindist dlinfo ver (PlatformRequest {..}) = do
installGHCBindist dlinfo ver pfreq = do
let tver = (mkTVer ver)
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (lift $ ghcInstalled tver)
@@ -128,42 +131,79 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- prepare paths
ghcdir <- lift $ ghcupGHCDir tver
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ runBuildAction tmpUnpack (Just ghcdir) (installGHC' workdir ghcdir)
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver pfreq
liftE $ postGHCInstall tver
where
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
installGHC' :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m ()
installGHC' path inst = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ execLogged "./configure"
False
(["--prefix=" <> toFilePath inst] ++ alpineArgs)
[rel|ghc-configure|]
(Just path)
Nothing
lEM $ make ["install"] (Just path)
pure ()
-- | Install a packed GHC distribution. This only deals with unpacking and the GHC
-- build system and nothing else.
installPackedGHC :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> Path Abs -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive
-> Path Abs -- ^ Path to install to
-> Version -- ^ The GHC version
-> PlatformRequest
-> Excepts
'[ BuildFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
] m ()
installPackedGHC dl msubdir inst ver pfreq@(PlatformRequest {..}) = do
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
(msubdir)
liftE $ runBuildAction tmpUnpack
(Just inst)
(installUnpackedGHC workdir inst ver pfreq)
-- | Install an unpacked GHC distribution. This only deals with the GHC
-- build system and nothing else.
installUnpackedGHC :: ( MonadReader Settings m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> Path Abs -- ^ Path to install to
-> Version -- ^ The GHC version
-> PlatformRequest
-> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver (PlatformRequest {..}) = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ execLogged "./configure"
False
(["--prefix=" <> toFilePath inst] ++ alpineArgs)
[rel|ghc-configure|]
(Just path)
Nothing
lEM $ make ["install"] (Just path)
pure ()
where
alpineArgs
| ver >= [vver|8.2.2|]
, Linux Alpine <- _rPlatform = ["--disable-ld-override"]
| otherwise = []
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
= ["--disable-ld-override"]
| otherwise
= []
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@@ -273,12 +313,14 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
installCabal' path inst = do
lift $ $(logInfo) "Installing cabal"
let cabalFile = [rel|cabal|]
liftIO $ createDirRecursive newDirPerms inst
liftIO $ createDirRecursive' inst
destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile)
(inst </> destFileName)
(destPath)
Overwrite
lift $ chmod_777 destPath
-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and
@@ -315,6 +357,130 @@ installCabalBin bDls ver pfreq = do
installCabalBindist dlinfo ver pfreq
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installHLSBindist :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadFail m
)
=> DownloadInfo
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installHLSBindist dlinfo ver (PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
Settings {dirs = Dirs {..}} <- lift ask
whenM (lift (hlsInstalled ver))
$ (throwE $ AlreadyInstalled HLS ver)
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ installHLS' workdir binDir
-- create symlink if this is the latest version
hlsVers <- lift $ fmap rights $ getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
pure ()
where
-- | Install an unpacked hls distribution.
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked hls bindist (where the executable resides)
-> Path Abs -- ^ Path to install to
-> Excepts '[CopyError] m ()
installHLS' path inst = do
lift $ $(logInfo) "Installing HLS"
liftIO $ createDirRecursive' inst
-- install haskell-language-server-<ghcver>
bins@(_:_) <- liftIO $ findFiles
path
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
)
forM_ bins $ \f -> do
toF <- parseRel (toFilePath f <> "~" <> verToBS ver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> f)
(inst </> toF)
Overwrite
lift $ chmod_777 (inst </> toF)
-- install haskell-language-server-wrapper
let wrapper = [rel|haskell-language-server-wrapper|]
toF <- parseRel (toFilePath wrapper <> "-" <> verToBS ver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> wrapper)
(inst </> toF)
Overwrite
lift $ chmod_777 (inst </> toF)
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
installHLSBin :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadFail m
)
=> GHCupDownloads
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installHLSBin bDls ver pfreq = do
dlinfo <- lE $ getDownloadInfo HLS ver pfreq bDls
installHLSBindist dlinfo ver pfreq
---------------------
@@ -346,9 +512,11 @@ setGHC ver sghc = do
let verBS = verToBS (_tvVersion ver)
ghcdir <- lift $ ghcupGHCDir ver
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer)))
-- symlink destination
Settings { dirs = Dirs {..} } <- lift ask
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
liftIO $ createDirRecursive' binDir
-- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup)
@@ -420,7 +588,7 @@ setCabal ver = do
-- symlink destination
Settings {dirs = Dirs {..}} <- lift ask
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
liftIO $ createDirRecursive' binDir
whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile))
$ throwE
@@ -443,6 +611,55 @@ setCabal ver = do
-- | Set the haskell-language-server symlinks.
setHLS :: ( MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
)
=> Version
-> Excepts '[NotInstalled] m ()
setHLS ver = do
Settings { dirs = Dirs {..} } <- lift ask
liftIO $ createDirRecursive' binDir
-- Delete old symlinks, since these might have different ghc versions than the
-- selected version, so we could end up with stray or incorrect symlinks.
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
liftIO $ deleteFile (binDir </> f)
-- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver
when (bins == []) $ throwE $ NotInstalled HLS (prettyVer ver)
forM_ bins $ \f -> do
let destL = toFilePath f
target <- parseRel . head . B.split _tilde . toFilePath $ f
lift $ $(logDebug) [i|rm -f #{toFilePath (binDir </> target)}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> target)
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath (binDir </> target)}|]
liftIO $ createSymlink (binDir </> target) destL
-- set haskell-language-server-wrapper symlink
let destL = "haskell-language-server-wrapper-" <> verToBS ver
let wrapper = binDir </> [rel|haskell-language-server-wrapper|]
lift $ $(logDebug) [i|rm -f #{toFilePath wrapper}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile wrapper
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath wrapper}|]
liftIO $ createSymlink wrapper destL
pure ()
------------------
@@ -467,6 +684,7 @@ data ListResult = ListResult
, fromSrc :: Bool -- ^ compiled from source
, lStray :: Bool -- ^ not in download info
, lNoBindist :: Bool -- ^ whether the version is available for this platform/arch
, hlsPowered :: Bool
}
deriving (Eq, Ord, Show)
@@ -500,19 +718,25 @@ listVersions av lt criteria pfreq = do
lr <- filter' <$> forM (Map.toList avTools) (toListResult t)
case t of
-- append stray GHCs
GHC -> do
slr <- strayGHCs avTools
pure $ (sort (slr ++ lr))
_ -> pure lr
Cabal -> do
slr <- strayCabals avTools
pure $ (sort (slr ++ lr))
HLS -> do
slr <- strayHLS avTools
pure $ (sort (slr ++ lr))
GHCup -> pure lr
Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria pfreq
cabalvers <- listVersions av (Just Cabal) criteria pfreq
hlsvers <- listVersions av (Just HLS) criteria pfreq
ghcupvers <- listVersions av (Just GHCup) criteria pfreq
pure (ghcvers <> cabalvers <> ghcupvers)
pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers)
where
strayGHCs :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
strayGHCs :: (MonadCatch m, MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
strayGHCs avTools = do
@@ -524,6 +748,7 @@ listVersions av lt criteria pfreq = do
Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) $ hlsGHCVersions
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
@@ -537,6 +762,7 @@ listVersions av lt criteria pfreq = do
Right tver@GHCTargetVersion{ .. } -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) $ hlsGHCVersions
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
@@ -552,6 +778,62 @@ listVersions av lt criteria pfreq = do
[i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing
strayCabals :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
strayCabals avTools = do
cabals <- getInstalledCabals
fmap catMaybes $ forM cabals $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
lSet <- fmap (maybe False (== ver)) $ cabalSet
pure $ Just $ ListResult
{ lTool = Cabal
, lVer = ver
, lCross = Nothing
, lTag = []
, lInstalled = True
, lStray = maybe True (const False) (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, ..
}
Left e -> do
$(logWarn)
[i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing
strayHLS :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
strayHLS avTools = do
hlss <- getInstalledHLSs
fmap catMaybes $ forM hlss $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
lSet <- fmap (maybe False (== ver)) $ hlsSet
pure $ Just $ ListResult
{ lTool = HLS
, lVer = ver
, lCross = Nothing
, lTag = []
, lInstalled = True
, lStray = maybe True (const False) (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, ..
}
Left e -> do
$(logWarn)
[i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing
-- NOTE: this are not cross ones, because no bindists
toListResult :: (MonadReader Settings m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult
toListResult t (v, tags) = case t of
@@ -561,6 +843,7 @@ listVersions av lt criteria pfreq = do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem v) $ hlsGHCVersions
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do
let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq av
@@ -572,6 +855,7 @@ listVersions av lt criteria pfreq = do
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
GHCup -> do
@@ -584,6 +868,20 @@ listVersions av lt criteria pfreq = do
, fromSrc = False
, lStray = False
, lNoBindist = False
, hlsPowered = False
, ..
}
HLS -> do
let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq av
lSet <- fmap (maybe False (== v)) $ hlsSet
lInstalled <- hlsInstalled v
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
@@ -617,43 +915,39 @@ rmGHCVer :: ( MonadReader Settings m
-> Excepts '[NotInstalled] m ()
rmGHCVer ver = do
isSetGHC <- lift $ fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver)
dir <- lift $ ghcupGHCDir ver
let d' = toFilePath dir
exists <- liftIO $ doesDirectoryExist dir
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer)))
dir <- lift $ ghcupGHCDir ver
if exists
then do
-- this isn't atomic, order matters
when isSetGHC $ do
lift $ $(logInfo) [i|Removing ghc symlinks|]
liftE $ rmPlain (_tvTarget ver)
-- this isn't atomic, order matters
when isSetGHC $ do
lift $ $(logInfo) [i|Removing ghc symlinks|]
liftE $ rmPlain (_tvTarget ver)
lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
liftIO $ deleteDirRecursive dir
lift $ $(logInfo) [i|Removing directory recursively: #{toFilePath dir}|]
liftIO $ deleteDirRecursive dir
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
lift $ rmMinorSymlinks ver
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
lift $ rmMinorSymlinks ver
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
-- first remove
handle (\(_ :: ParseError) -> pure ()) $ lift $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version)
v' <-
handle
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
$ fmap Just
$ getMajorMinorV (_tvVersion ver)
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
-- first remove
handle (\(_ :: ParseError) -> pure ()) $ lift $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version)
v' <-
handle
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
$ fmap Just
$ getMajorMinorV (_tvVersion ver)
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
Settings { dirs = Dirs {..} } <- lift ask
Settings { dirs = Dirs {..} } <- lift ask
liftIO
$ hideError doesNotExistErrorType
$ deleteFile
$ (baseDir </> [rel|share|])
else throwE (NotInstalled GHC (ver ^. tvVersion % to prettyVer))
liftIO
$ hideError doesNotExistErrorType
$ deleteFile
$ (baseDir </> [rel|share|])
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
@@ -679,6 +973,35 @@ rmCabalVer ver = do
(binDir </> [rel|cabal|])
-- | Delete a hls version. Will try to fix the hls symlinks
-- after removal (e.g. setting it to an older version).
rmHLSVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
=> Version
-> Excepts '[NotInstalled] m ()
rmHLSVer ver = do
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (prettyVer ver))
isHlsSet <- lift $ hlsSet
Settings {dirs = Dirs {..}} <- lift ask
bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f)
when (maybe False (== ver) isHlsSet) $ do
-- delete all set symlinks
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
liftIO $ deleteFile (binDir </> f)
-- set latest hls
hlsVers <- lift $ fmap rights $ getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
Just latestver -> setHLS latestver
Nothing -> pure ()
------------------
--[ Debug info ]--
@@ -737,51 +1060,74 @@ compileGHC :: ( MonadMask m
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
, NotInstalled
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
whenM (lift $ ghcInstalled tver)
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@(PlatformRequest {..})
= do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
-- download source tarball
dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
alreadyInstalled <- lift $ ghcInstalled tver
alreadySet <- fmap (maybe False (==tver)) $ lift $ ghcSet (_tvTarget tver)
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- download source tarball
dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo)
ghcdir <- lift $ ghcupGHCDir tver
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
liftE $ runBuildAction
tmpUnpack
(Just ghcdir)
(compile bghc ghcdir workdir >> markSrcBuilt ghcdir workdir)
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo)
ghcdir <- lift $ ghcupGHCDir tver
reThrowAll GHCupSetError $ postGHCInstall tver
pure ()
(bindist, bmk) <- liftE $ runBuildAction
tmpUnpack
Nothing
(do
b <- compileBindist bghc ghcdir workdir
bmk <- liftIO $ readFileStrict (build_mk workdir)
pure (b, bmk)
)
when alreadyInstalled $ do
lift $ $(logInfo) [i|Deleting existing installation|]
liftE $ rmGHCVer tver
liftE $ installPackedGHC bindist
(view dlSubdir dlInfo)
ghcdir
(tver ^. tvVersion)
pfreq
liftIO $ writeFile (ghcdir </> ghcUpSrcBuiltFile) (Just newFilePerms) bmk
reThrowAll GHCupSetError $ postGHCInstall tver
-- restore
when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
pure ()
where
defaultConf = case _tvTarget tver of
Nothing -> [s|
Nothing -> [s|
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES|]
Just _ -> [s|
Just _ -> [s|
V=0
BUILD_MAN = NO
BUILD_SPHINX_HTML = NO
@@ -789,23 +1135,26 @@ BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = NO
Stage1Only = YES|]
compile :: (MonadReader Settings m, MonadThrow m, MonadCatch m, MonadLogger m, MonadIO m)
=> Either (Path Rel) (Path Abs)
-> Path Abs
-> Path Abs
-> Excepts
'[ FileDoesNotExistError
, InvalidBuildConfig
, PatchFailed
, ProcessError
, NotFoundInPATH
]
m
()
compile bghc ghcdir workdir = do
compileBindist :: ( MonadReader Settings m
, MonadThrow m
, MonadCatch m
, MonadLogger m
, MonadIO m
, MonadFail m
)
=> Either (Path Rel) (Path Abs)
-> Path Abs
-> Path Abs
-> Excepts
'[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
m
(Path Abs) -- ^ output path of bindist
compileBindist bghc ghcdir workdir = do
lift $ $(logInfo) [i|configuring build|]
liftE $ checkBuildConfig
Settings { dirs = Dirs {..} } <- lift ask
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
cEnv <- liftIO $ getEnvironment
@@ -856,29 +1205,49 @@ Stage1Only = YES|]
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
lift $ $(logInfo) [i|Building (this may take a while)...|]
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
(Just workdir)
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
lift $ $(logInfo) [i|Installing...|]
lEM $ make ["install"] (Just workdir)
markSrcBuilt ghcdir workdir = do
let dest = (ghcdir </> ghcUpSrcBuiltFile)
liftIO $ copyFile (build_mk workdir) dest Overwrite
lift $ $(logInfo) [i|Creating bindist...|]
lEM $ make ["binary-dist"] (Just workdir)
[tar] <- liftIO $ findFiles
workdir
(makeRegexOpts compExtended
execBlank
([s|^ghc-.*\.tar\..*$|] :: ByteString)
)
c <- liftIO $ readFile (workdir </> tar)
cDigest <-
fmap (T.take 8)
. lift
. throwEither
. E.decodeUtf8'
. B16.encode
. SHA256.hashlazy
$ c
tarName <-
parseRel
[i|ghc-#{prettyTVer tver}-#{prettyPfReq pfreq}-#{cDigest}.tar#{takeExtension (toFilePath tar)}|]
let tarPath = cacheDir </> tarName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
tarPath
Strict
lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
pure tarPath
build_mk workdir = workdir </> [rel|mk/build.mk|]
checkBuildConfig :: (MonadCatch m, MonadIO m)
=> Excepts
'[FileDoesNotExistError , InvalidBuildConfig]
'[FileDoesNotExistError, InvalidBuildConfig]
m
()
checkBuildConfig = do
c <- case mbuildConfig of
Just bc -> do
BL.toStrict <$> liftIOException doesNotExistErrorType
(FileDoesNotExistError $ toFilePath bc)
(liftIO $ readFile bc)
BL.toStrict <$> liftIOException
doesNotExistErrorType
(FileDoesNotExistError $ toFilePath bc)
(liftIO $ readFile bc)
Nothing -> pure defaultConf
let lines' = fmap T.strip . T.lines $ decUTF8Safe c
@@ -892,122 +1261,6 @@ Stage1Only = YES|]
-- | Compile a cabal from source. This behaves wrt symlinks and installation
-- the same as 'installCabalBin'.
compileCabal :: ( MonadReader Settings m
, MonadResource m
, MonadMask m
, MonadLogger m
, MonadIO m
, MonadFail m
)
=> GHCupDownloads
-> Version -- ^ version to install
-> Either Version (Path Abs) -- ^ version to bootstrap with
-> Maybe Int
-> Maybe (Path Abs)
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
Settings {dirs = Dirs {..}} <- lift ask
whenM
(lift (cabalInstalled tver) >>= \a -> liftIO $
handleIO (\_ -> pure False)
$ fmap (\x -> a && isSymbolicLink x)
-- ignore when the installation is a legacy cabal (binary, not symlink)
$ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|]))
)
$ (throwE $ AlreadyInstalled Cabal tver)
-- download source tarball
dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo)
cbin <- liftE $ runBuildAction tmpUnpack Nothing (compile workdir)
destFileName <- lift $ parseRel ("cabal-" <> verToBS tver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
cbin
(binDir </> destFileName)
Overwrite
-- create symlink if this is the latest version
cVers <- lift $ fmap rights $ getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (tver >=) lInstCabal) $ liftE $ setCabal tver
pure ()
where
compile :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
=> Path Abs
-> Excepts '[ProcessError , PatchFailed] m (Path Abs)
compile workdir = do
lift $ $(logInfo) [i|Building (this may take a while)...|]
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
ghcEnv <- case bghc of
Right path -> do
-- recover the version from /foo/ghc-6.5.4
bn <- basename path
let dn = toFilePath $ dirname path
let ver = snd . B.break (== _hyphen) . toFilePath $ bn
pure
[ ("GHC" , toFilePath path)
, ("GHC_PKG", dn <> "/" <> "ghc-pkg" <> ver)
, ("HADDOCK", dn <> "/" <> "haddock" <> ver)
]
Left bver -> do
let v' = verToBS bver
pure
[ ("GHC" , "ghc-" <> v')
, ("GHC_PKG", "ghc-pkg-" <> v')
, ("HADDOCK", "haddock-" <> v')
]
tmp <- lift withGHCupTmpDir
liftIO $ createDirRecursive newDirPerms (tmp </> [rel|bin|])
newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv)
lift $ $(logDebug) [i|Environment: #{newEnv}|]
lEM $ execLogged "./bootstrap.sh"
False
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
[rel|cabal-bootstrap|]
(Just workdir)
(Just newEnv)
pure $ (tmp </> [rel|bin/cabal|])
---------------------
--[ Upgrade GHCup ]--
@@ -1047,17 +1300,12 @@ upgradeGHCup dls mtarget force pfreq = do
tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|]
p <- liftE $ download dli tmp (Just fn)
let fileMode' =
newFilePerms
`unionFileModes` ownerExecuteMode
`unionFileModes` groupExecuteMode
`unionFileModes` otherExecuteMode
let fullDest = fromMaybe (binDir </> fn) mtarget
liftIO $ hideError NoSuchThing $ deleteFile fullDest
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
fullDest
Overwrite
liftIO $ setFileMode (toFilePath fullDest) fileMode'
lift $ chmod_777 fullDest
pure latestVer

View File

@@ -226,7 +226,7 @@ getDownloads urlSource = do
else -- access in less than 5 minutes, re-use file
liftIO $ readFile json_file
else do
liftIO $ createDirRecursive newDirPerms cacheDir
liftIO $ createDirRecursive' cacheDir
getModTime >>= \case
Just modTime -> dlWithMod modTime json_file
Nothing -> do
@@ -330,7 +330,7 @@ download dli dest mfn
scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
cp = do
-- destination dir must exist
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
liftIO $ createDirRecursive' dest
destFile <- getDestFile
fromFile <- parseAbs path
liftIO $ copyFile fromFile destFile Strict
@@ -340,7 +340,7 @@ download dli dest mfn
lift $ $(logInfo) [i|downloading: #{uri'}|]
-- destination dir must exist
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
liftIO $ createDirRecursive' dest
destFile <- getDestFile
-- download

View File

@@ -152,3 +152,10 @@ data ParseError = ParseError String
deriving Show
instance Exception ParseError
data UnexpectedListLength = UnexpectedListLength String
deriving Show
instance Exception UnexpectedListLength

View File

@@ -48,7 +48,7 @@ prettyRequirements :: Requirements -> T.Text
prettyRequirements Requirements {..} =
let d = if not . null $ _distroPKGs
then
"\n Install the following distro packages: "
"\n Please install the following distro packages: "
<> T.intercalate " " _distroPKGs
else ""
n = if not . T.null $ _notes then "\n Note: " <> _notes else ""

View File

@@ -19,6 +19,7 @@ import Data.Versions
import HPath
import URI.ByteString
import qualified Data.Text as T
import qualified GHC.Generics as GHC
@@ -75,6 +76,7 @@ type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
data Tool = GHC
| Cabal
| GHCup
| HLS
deriving (Eq, GHC.Generic, Ord, Show)
@@ -86,7 +88,7 @@ data VersionInfo = VersionInfo
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
}
deriving (Eq, Show)
deriving (Eq, GHC.Generic, Show)
-- | A tag. These are currently attached to a version of a tool.
@@ -95,7 +97,7 @@ data Tag = Latest
| Prerelease
| Base PVP
| UnknownTag String -- ^ used for upwardscompat
deriving (Ord, Eq, Show) -- FIXME: manual JSON instance
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
data Architecture = A_64
@@ -108,6 +110,15 @@ data Architecture = A_64
| A_ARM64
deriving (Eq, GHC.Generic, Ord, Show)
prettyArch :: Architecture -> String
prettyArch A_64 = "x86_64"
prettyArch A_32 = "i386"
prettyArch A_PowerPC = "powerpc"
prettyArch A_PowerPC64 = "powerpc64"
prettyArch A_Sparc = "sparc"
prettyArch A_Sparc64 = "sparc64"
prettyArch A_ARM = "arm"
prettyArch A_ARM64 = "aarch64"
data Platform = Linux LinuxDistro
-- ^ must exit
@@ -116,6 +127,11 @@ data Platform = Linux LinuxDistro
| FreeBSD
deriving (Eq, GHC.Generic, Ord, Show)
prettyPlatfrom :: Platform -> String
prettyPlatfrom (Linux distro) = "linux-" ++ prettyDistro distro
prettyPlatfrom Darwin = "darwin"
prettyPlatfrom FreeBSD = "freebsd"
data LinuxDistro = Debian
| Ubuntu
| Mint
@@ -132,6 +148,19 @@ data LinuxDistro = Debian
-- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show)
prettyDistro :: LinuxDistro -> String
prettyDistro Debian = "debian"
prettyDistro Ubuntu = "ubuntu"
prettyDistro Mint= "mint"
prettyDistro Fedora = "fedora"
prettyDistro CentOS = "centos"
prettyDistro RedHat = "redhat"
prettyDistro Alpine = "alpine"
prettyDistro AmazonLinux = "amazon"
prettyDistro Gentoo = "gentoo"
prettyDistro Exherbo = "exherbo"
prettyDistro UnknownLinux = "unknown"
-- | An encapsulation of a download. This can be used
-- to download, extract and install a tool.
@@ -140,7 +169,7 @@ data DownloadInfo = DownloadInfo
, _dlSubdir :: Maybe TarDir
, _dlHash :: Text
}
deriving (Eq, Show)
deriving (Eq, GHC.Generic, Show)
@@ -153,14 +182,14 @@ data DownloadInfo = DownloadInfo
-- | How to descend into a tar archive.
data TarDir = RealDir (Path Rel)
| RegexDir String -- ^ will be compiled to regex, the first match will "win"
deriving (Eq, Show)
deriving (Eq, GHC.Generic, Show)
-- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL
| OwnSource URI
| OwnSpec GHCupInfo
deriving Show
deriving (GHC.Generic, Show)
data Settings = Settings
@@ -219,6 +248,12 @@ data PlatformResult = PlatformResult
}
deriving (Eq, Show)
prettyPlatform :: PlatformResult -> String
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
= show plat <> ", " <> show v'
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing }
= show plat
data PlatformRequest = PlatformRequest
{ _rArch :: Architecture
, _rPlatform :: Platform
@@ -226,6 +261,13 @@ data PlatformRequest = PlatformRequest
}
deriving (Eq, Show)
prettyPfReq :: PlatformRequest -> String
prettyPfReq (PlatformRequest arch plat ver) =
prettyArch arch ++ "-" ++ prettyPlatfrom plat ++ pver
where
pver = case ver of
Just v' -> "-" ++ (T.unpack $ prettyV v')
Nothing -> ""
-- | A GHC identified by the target platform triple
-- and the version.

View File

@@ -36,7 +36,7 @@ import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
#if !defined(TAR)
import Codec.Archive
import Codec.Archive hiding ( Directory )
#endif
import Control.Applicative
import Control.Exception.Safe
@@ -301,6 +301,150 @@ cabalSet = do
-- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
getInstalledHLSs :: (MonadReader Settings m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledHLSs = do
Settings { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
)
vs <- forM bins $ \f ->
case
fmap
version
(fmap decUTF8Safe . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f)
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
pure $ vs
-- | Whether the given HLS version is installed.
hlsInstalled :: (MonadIO m, MonadReader Settings m, MonadCatch m) => Version -> m Bool
hlsInstalled ver = do
vers <- fmap rights $ getInstalledHLSs
pure $ elem ver $ vers
-- Return the currently set hls version, if any.
hlsSet :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet = do
Settings {dirs = Dirs {..}} <- ask
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
broken <- isBrokenSymlink hlsBin
if broken
then pure Nothing
else do
link <- readSymbolicLink $ toFilePath hlsBin
Just <$> linkVersion link
where
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "haskell-language-server-wrapper-" *> version'
-- | Return the GHC versions the currently selected HLS supports.
hlsGHCVersions :: ( MonadReader Settings m
, MonadIO m
, MonadThrow m
, MonadCatch m
)
=> m [Version]
hlsGHCVersions = do
h <- hlsSet
vers <- forM h $ \h' -> do
bins <- hlsServerBinaries h'
pure $ fmap
(\bin ->
version
. decUTF8Safe
. fromJust
. B.stripPrefix "haskell-language-server-"
. head
. B.split _tilde
. toFilePath
$ bin
)
bins
pure . rights . concat . maybeToList $ vers
-- | Get all server binaries for an hls version, if any.
hlsServerBinaries :: (MonadReader Settings m, MonadIO m)
=> Version
-> m [Path Rel]
hlsServerBinaries ver = do
Settings { dirs = Dirs {..} } <- ask
liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> [s|$|] :: ByteString
)
)
-- | Get the wrapper binary for an hls version, if any.
hlsWrapperBinary :: (MonadReader Settings m, MonadThrow m, MonadIO m)
=> Version
-> m (Maybe (Path Rel))
hlsWrapperBinary ver = do
Settings { dirs = Dirs {..} } <- ask
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> [s|$|] :: ByteString
)
)
case wrapper of
[] -> pure $ Nothing
[x] -> pure $ Just x
_ -> throwM $ UnexpectedListLength
"There were multiple hls wrapper binaries for a single version"
-- | Get all binaries for an hls version, if any.
hlsAllBinaries :: (MonadReader Settings m, MonadIO m, MonadThrow m) => Version -> m [Path Rel]
hlsAllBinaries ver = do
hls <- hlsServerBinaries ver
wrapper <- hlsWrapperBinary ver
pure (maybeToList wrapper ++ hls)
-- | Get the active symlinks for hls.
hlsSymlinks :: (MonadReader Settings m, MonadIO m, MonadCatch m) => m [Path Rel]
hlsSymlinks = do
Settings { dirs = Dirs {..} } <- ask
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-.*$|] :: ByteString)
)
filterM
( fmap (== SymbolicLink)
. liftIO
. getFileType
. (binDir </>)
)
oldSyms
-----------------------------------------
@@ -596,8 +740,8 @@ getChangeLog dls tool (Right tag) =
-- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed
runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m)
=> Path Abs -- ^ build directory
-> Maybe (Path Abs) -- ^ install location (e.g. for GHC)
=> Path Abs -- ^ build directory (cleaned up depending on Settings)
-> Maybe (Path Abs) -- ^ dir to *always* clean up on exception
-> Excepts e m a
-> Excepts '[BuildFailed] m a
runBuildAction bdir instdir action = do
@@ -621,3 +765,25 @@ runBuildAction bdir instdir action = do
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
bdir
pure v
-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
createDirRecursive' :: Path b -> IO ()
createDirRecursive' p =
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
. createDirRecursive newDirPerms
$ p
where
isSymlinkDir e = do
ft <- getFileType p
case ft of
SymbolicLink -> do
rp <- canonicalizePath p
rft <- getFileType rp
case rft of
Directory -> pure ()
_ -> throwIO e
_ -> throwIO e

View File

@@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : GHCup.Utils.File
@@ -25,6 +26,7 @@ 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 )
@@ -33,6 +35,7 @@ import Data.Functor
import Data.IORef
import Data.Maybe
import Data.Sequence ( Seq, (|>) )
import Data.String.Interpolate
import Data.Text ( Text )
import Data.Void
import Data.Word8
@@ -46,6 +49,7 @@ import System.IO.Error
import System.Posix.Directory.ByteString
import System.Posix.FD as FD
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Files.ByteString
import System.Posix.Foreign ( oExcl )
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
@@ -375,7 +379,7 @@ toProcessError :: ByteString
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError exe args mps = case mps of
Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
Just (SPPB.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
Just (SPPB.Exited ExitSuccess ) -> Right ()
Just (Terminated _ _ ) -> Left $ PTerminated exe args
Just (Stopped _ ) -> Left $ PStopped exe args
@@ -434,3 +438,15 @@ isBrokenSymlink p =
$ do
_ <- canonicalizePath p
pure False
chmod_777 :: (MonadLogger m, MonadIO m) => Path a -> m ()
chmod_777 (toFilePath -> fp) = do
let exe_mode =
newFilePerms
`unionFileModes` ownerExecuteMode
`unionFileModes` groupExecuteMode
`unionFileModes` otherExecuteMode
$(logDebug) [i|chmod 777 #{fp}|]
liftIO $ setFileMode fp exe_mode

View File

@@ -15,6 +15,7 @@ Here we define our main logger.
module GHCup.Utils.Logger where
import GHCup.Types
import GHCup.Utils
import Control.Monad
import Control.Monad.IO.Class
@@ -69,7 +70,7 @@ initGHCupFileLogging context = do
Settings {dirs = Dirs {..}} <- ask
let logfile = logsDir </> context
liftIO $ do
createDirRecursive newDirPerms logsDir
createDirRecursive' logsDir
hideError doesNotExistErrorType $ deleteFile logfile
createRegularFile newFilePerms logfile
pure logfile

View File

@@ -31,11 +31,13 @@ import Data.ByteString ( ByteString )
import Data.String
import Data.Text ( Text )
import Data.Versions
import Data.Word8
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Strict.Maybe as S
import qualified Data.Text as T
@@ -275,3 +277,13 @@ decUTF8Safe = E.decodeUtf8With E.lenientDecode
decUTF8Safe' :: L.ByteString -> Text
decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode
-- | Escape a version for use in regex
escapeVerRex :: Version -> ByteString
escapeVerRex = B.pack . go . B.unpack . verToBS
where
go [] = []
go (x : xs) | x == _period = [_backslash, _period] ++ go xs
| otherwise = x : go xs

View File

@@ -22,11 +22,11 @@ import qualified Data.Text as T
-- | This reflects the API version of the YAML.
ghcupURL :: URI
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.yaml|]
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.3.yaml|]
-- | The current ghcup version.
ghcUpVer :: PVP
ghcUpVer = [pver|0.1.8|]
ghcUpVer = [pver|0.1.11|]
-- | ghcup version as numeric string.
numericVer :: String

View File

@@ -0,0 +1,193 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module GHCup.ArbitraryTypes where
import GHCup.Types
import Data.ByteString ( ByteString )
import Data.Versions
import Data.List.NonEmpty
import HPath
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.ADT ( ToADTArbitrary )
import Test.QuickCheck.Arbitrary.Generic
import URI.ByteString
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Lazy as T
( toStrict )
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
-----------------
--[ utilities ]--
-----------------
intToText :: Integral a => a -> T.Text
intToText = T.toStrict . B.toLazyText . B.decimal
genVer :: Gen (Int, Int, Int)
genVer =
(\x y z -> (getPositive x, getPositive y, getPositive z))
<$> arbitrary
<*> arbitrary
<*> arbitrary
instance ToADTArbitrary GHCupInfo
----------------------
--[ base arbitrary ]--
----------------------
instance Arbitrary T.Text where
arbitrary = fmap T.pack $ listOf $ elements ['a' .. 'z']
shrink xs = T.pack <$> shrink (T.unpack xs)
instance Arbitrary (NonEmpty Word) where
arbitrary = fmap fromList $ listOf1 $ arbitrary
-- utf8 encoded bytestring
instance Arbitrary ByteString where
arbitrary = fmap (E.encodeUtf8 . T.pack) $ listOf $ elements ['a' .. 'z']
---------------------
--[ uri arbitrary ]--
---------------------
instance Arbitrary Scheme where
arbitrary = oneof [ Scheme <$> pure "http", Scheme <$> pure "https" ]
instance Arbitrary Host where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Port where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary (URIRef Absolute) where
arbitrary =
URI <$> arbitrary <*> pure Nothing <*> arbitrary <*> (Query <$> pure []) <*> pure Nothing
-------------------------
--[ version arbitrary ]--
-------------------------
instance Arbitrary Mess where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ mess
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary Version where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ version
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary SemVer where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ semver
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary PVP where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ pvp
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary Versioning where
arbitrary = Ideal <$> arbitrary
-----------------------
--[ ghcup arbitrary ]--
-----------------------
instance Arbitrary Requirements where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary DownloadInfo where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary LinuxDistro where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Platform where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Tag where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Architecture where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary VersionInfo where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary (Path Rel) where
arbitrary =
(either (error . show) id . parseRel . E.encodeUtf8 . T.pack)
<$> (listOf1 $ elements ['a' .. 'z'])
instance Arbitrary TarDir where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Tool where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary GHCupInfo where
arbitrary = genericArbitrary
shrink = genericShrink
-- our maps are nested... the default size easily blows up most ppls ram
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map Tool v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map (Maybe Version) v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map Platform v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map (Maybe Versioning) v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary

View File

@@ -0,0 +1,17 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
module GHCup.Types.JSONSpec where
import GHCup.ArbitraryTypes ()
import GHCup.Types
import GHCup.Types.JSON ()
import Test.Aeson.GenericSpecs
import Test.Hspec
spec :: Spec
spec = do
roundtripAndGoldenSpecs (Proxy @GHCupInfo)

12
test/Main.hs Normal file
View File

@@ -0,0 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
import Test.Hspec.Runner
import Test.Hspec.Formatters
import qualified Spec
main :: IO ()
main =
hspecWith
defaultConfig { configFormatter = Just progress }
$ Spec.spec

View File

@@ -1,4 +0,0 @@
module Main (main) where
main :: IO ()
main = putStrLn "Test suite not yet implemented."

2
test/Spec.hs Normal file
View File

@@ -0,0 +1,2 @@
-- file test/Spec.hs
{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}