This commit is contained in:
Julian Ospald 2021-03-11 17:03:51 +01:00
parent 910d660732
commit d5b5f1fddd
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
30 changed files with 490 additions and 434 deletions

View File

@ -1,4 +1,5 @@
stages:
- hlint
- test
- release
@ -153,6 +154,7 @@ test:linux:stack:
- ./.gitlab/script/ghcup_stack.sh
extends:
- .debian
needs: []
######## bootstrap test ########
@ -167,6 +169,7 @@ test:linux:bootstrap_script:
CABAL_VERSION: "3.4.0.0"
extends:
- .debian
needs: []
######## linux test ########
@ -176,6 +179,7 @@ test:linux:recommended:
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
needs: []
test:linux:latest:
stage: test
@ -183,6 +187,7 @@ test:linux:latest:
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
needs: []
######## linux 32bit test ########
@ -192,22 +197,27 @@ test:linux:recommended:32bit:
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.2.0.0"
needs: []
######## arm tests ########
test:linux:recommended:armv7:
stage: test
extends: .test_ghcup_version:armv7
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
when: manual
needs: []
test:linux:recommended:aarch64:
stage: test
extends: .test_ghcup_version:aarch64
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
when: manual
needs: []
######## darwin test ########
@ -217,6 +227,7 @@ test:mac:recommended:
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
needs: []
test:mac:latest:
stage: test
@ -224,6 +235,7 @@ test:mac:latest:
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
needs: []
######## freebsd test ########
@ -234,6 +246,9 @@ test:freebsd:recommended:
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
allow_failure: true # freebsd runners are unreliable
when: manual
needs: []
test:freebsd:latest:
stage: test
@ -241,6 +256,9 @@ test:freebsd:latest:
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
allow_failure: true # freebsd runners are unreliable
when: manual
needs: []
######## linux release ########
@ -332,3 +350,24 @@ release:freebsd:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
######## hlint ########
hlint:
stage: hlint
extends:
- .alpine:64bit
before_script:
- ./.gitlab/before_script/linux/alpine/install_deps.sh
script:
- ./.gitlab/script/hlint.sh
variables:
GHC_VERSION: "8.10.4"
CABAL_VERSION: "3.4.0.0"
JSON_VERSION: "0.0.4"
allow_failure: true
artifacts:
expire_in: 2 week
paths:
- report.html
when: on_failure

View File

@ -20,7 +20,10 @@ git describe --always
ecabal update
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
(
cd /tmp
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

19
.gitlab/script/hlint.sh Executable file
View File

@ -0,0 +1,19 @@
#!/bin/sh
set -eux
. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
mkdir -p "$CI_PROJECT_DIR"/.local/bin
ecabal() {
cabal --store-dir="$(pwd)"/.store "$@"
}
git describe
ecabal update
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hlint
hlint -r lib/ test/

83
.hlint.yaml Normal file
View File

@ -0,0 +1,83 @@
# HLint configuration file
# https://github.com/ndmitchell/hlint
##########################
# This file contains a template configuration file, which is typically
# placed as .hlint.yaml in the root of your project
# Warnings currently triggered by your code
- ignore: {name: "Redundant bang pattern"}
- ignore: {name: "Use camelCase"}
- ignore: {name: "Use if"}
- ignore: {name: "Use newtype instead of data"}
- ignore: {name: "Use <$>"}
- ignore: {name: "Use mapMaybe"}
- ignore: {name: "Use const"}
- ignore: {name: "Use list comprehension"}
- ignore: {name: "Redundant multi-way if"}
- ignore: {name: "Redundant lambda"}
- ignore: {name: "Avoid lambda"}
- ignore: {name: "Use uncurry"}
- ignore: {name: "Use replicateM"}
- ignore: {name: "Redundant irrefutable pattern"}
# Specify additional command line arguments
#
# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
# Control which extensions/flags/modules/functions can be used
#
# - extensions:
# - default: false # all extension are banned by default
# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
#
# - flags:
# - {name: -w, within: []} # -w is allowed nowhere
#
# - modules:
# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
#
# - functions:
# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
# Add custom hints for this project
#
# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
# The hints are named by the string they display in warning messages.
# For example, if you see a warning starting like
#
# Main.hs:116:51: Warning: Redundant ==
#
# You can refer to that hint with `{name: Redundant ==}` (see below).
# Turn on hints that are off by default
#
# Ban "module X(module X) where", to require a real export list
# - warn: {name: Use explicit module export list}
#
# Replace a $ b $ c with a . b $ c
# - group: {name: dollar, enabled: true}
#
# Generalise map to fmap, ++ to <>
# - group: {name: generalise, enabled: true}
# Ignore some builtin hints
# - ignore: {name: Use let}
# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
# Define some custom infix operators
# - fixity: infixr 3 ~^#^~
# To generate a suitable file for HLint do:
# $ hlint --default > .hlint.yaml

View File

@ -44,11 +44,10 @@ data Input
fileInput :: Parser Input
fileInput =
FileInput
<$> (strOption
<$> strOption
(long "file" <> short 'f' <> metavar "FILENAME" <> help
"Input file to validate"
)
)
stdInput :: Parser Input
stdInput = flag'
@ -76,7 +75,7 @@ tarballFilterP = option readm $
case span (/= '-') s of
(_, []) -> fail "invalid format, missing '-' after the tool name"
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
TarballFilter <$> pure (Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
pure (TarballFilter $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
_ -> fail "invalid tool"
low = fmap toLower
@ -86,21 +85,18 @@ opts = Options <$> com
com :: Parser Command
com = subparser
( (command
( command
"check"
( ValidateYAML
<$> (info (validateYAMLOpts <**> helper)
(progDesc "Validate the YAML")
)
<$> info (validateYAMLOpts <**> helper)
(progDesc "Validate the YAML")
)
)
<> (command
<> command
"check-tarballs"
(info
((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
(progDesc "Validate all tarballs (download and checksum)")
)
)
)

View File

@ -85,26 +85,26 @@ validate dls = do
checkHasRequiredPlatforms t v tags arch pspecs = do
let v' = prettyVer v
arch' = prettyShow arch
when (not $ any (== Linux UnknownLinux) pspecs) $ do
when (notElem (Linux UnknownLinux) pspecs) $ do
lift $ $(logError)
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch'}|]
addError
when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do
when ((notElem Darwin pspecs) && arch == A_64) $ do
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch'}|]
addError
when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn)
[i|FreeBSD missing for #{t} #{v'} #{arch'}|]
-- alpine needs to be set explicitly, because
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
-- (although it could be static)
when (not $ any (== Linux Alpine) pspecs) $
when (notElem (Linux Alpine) pspecs) $
case t of
GHCup | arch `elem` [A_64, A_32] -> (lift $ $(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]) >> addError
GHCup | arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]) >> addError
Cabal | v > [vver|2.4.1.0|]
, arch `elem` [A_64, A_32] -> (lift $ $(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]) >> addError
, arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]) >> addError
GHC | Latest `elem` tags || Recommended `elem` tags
, arch `elem` [A_64, A_32] -> lift $ $(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]
, arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|])
_ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]
checkUniqueTags tool = do
@ -116,7 +116,7 @@ validate dls = do
(\case
[] -> throwM $ InternalError "empty inner list"
(t : ts) ->
pure $ (t, ) $ if isUniqueTag t then ts == [] else True
pure $ (t, ) (not (isUniqueTag t) || null ts)
)
. group
. sort
@ -190,7 +190,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do
%& indices (matchTest versionRegex . T.unpack . prettyVer)
% (viSourceDL % _Just `summing` viArch % each % each % each)
when (null dlis) $ $(logError) [i|no tarballs selected by filter|] *> addError
forM_ dlis $ downloadAll
forM_ dlis downloadAll
-- exit
e <- liftIO $ readIORef ref
@ -203,7 +203,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do
where
runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())
, rawOutter = \_ -> pure ()
}
downloadAll dli = do
dirs <- liftIO getDirs

View File

@ -98,16 +98,15 @@ keyHandlers KeyBindings {..} =
, (bSet, const "Set" , withIOAction set')
, (bChangelog, const "ChangeLog", withIOAction changelog')
, ( bShowAll
, (\BrickSettings {..} ->
if showAll then "Hide old versions" else "Show all versions"
)
, \BrickSettings {..} ->
if showAll then "Hide old versions" else "Show all versions"
, hideShowHandler
)
, (bUp, const "Up", \BrickState {..} -> continue (BrickState { appState = (moveCursor 1 appState Up), .. }))
, (bDown, const "Down", \BrickState {..} -> continue (BrickState { appState = (moveCursor 1 appState Down), .. }))
, (bUp, const "Up", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Up, .. })
, (bDown, const "Down", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Down, .. })
]
where
hideShowHandler (BrickState {..}) =
hideShowHandler BrickState{..} =
let newAppSettings = appSettings { showAll = not . showAll $ appSettings }
newInternalState = constructList appData newAppSettings (Just appState)
in continue (BrickState appData newAppSettings newInternalState appKeys)
@ -115,19 +114,18 @@ keyHandlers KeyBindings {..} =
showKey :: Vty.Key -> String
showKey (Vty.KChar c) = [c]
showKey (Vty.KUp) = ""
showKey (Vty.KDown) = ""
showKey Vty.KUp = ""
showKey Vty.KDown = ""
showKey key = tail (show key)
ui :: AttrMap -> BrickState -> Widget String
ui dimAttrs BrickState { appSettings = as@(BrickSettings {}), ..}
= ( padBottom Max
$ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
$ (center $ (header <=> hBorder <=> renderList' appState))
ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
= padBottom Max
( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
(center (header <=> hBorder <=> renderList' appState))
)
)
<=> footer
where
@ -136,15 +134,16 @@ ui dimAttrs BrickState { appSettings = as@(BrickSettings {}), ..}
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
$ (fmap (\(key, s, _) -> (showKey key <> ":" <> s as)) $ keyHandlers appKeys)
. fmap (\(key, s, _) -> showKey key <> ":" <> s as)
$ keyHandlers appKeys
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")
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")
renderList' = withDefAttr listAttr . drawListElements renderItem True
renderItem _ b listResult@(ListResult {..}) =
renderItem _ b listResult@ListResult{..} =
let marks = if
| lSet -> (withAttr "set" $ str "✔✔")
| lInstalled -> (withAttr "installed" $ str "")
@ -153,8 +152,8 @@ ui dimAttrs BrickState { appSettings = as@(BrickSettings {}), ..}
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
dim
| lNoBindist && (not lInstalled)
&& (not b) -- TODO: overloading dim and active ignores active
| lNoBindist && not lInstalled
&& not b -- TODO: overloading dim and active ignores active
-- so we hack around it here
= updateAttrMap (const dimAttrs) . withAttr "no-bindist"
| otherwise = id
@ -165,24 +164,23 @@ ui dimAttrs BrickState { appSettings = as@(BrickSettings {}), ..}
active = if b then forceAttr "active" else id
in hooray $ active $ dim
( marks
<+> (( padLeft (Pad 2)
$ minHSize 6
$ (printTool lTool)
<+> padLeft (Pad 2)
( minHSize 6
(printTool lTool)
)
)
<+> (minHSize 15 $ (str ver))
<+> minHSize 15 (str ver)
<+> (let l = catMaybes . fmap printTag $ sort lTag
in padLeft (Pad 1) $ minHSize 25 $ if null l
then emptyWidget
else foldr1 (\x y -> x <+> str "," <+> y) l
)
<+> ( padLeft (Pad 5)
$ let notes = printNotes listResult
<+> padLeft (Pad 5)
( let notes = printNotes listResult
in if null notes
then emptyWidget
else foldr1 (\x y -> x <+> str "," <+> y) $ notes
else foldr1 (\x y -> x <+> str "," <+> y) notes
)
<+> (vLimit 1 $ fill ' ')
<+> vLimit 1 (fill ' ')
)
printTag Recommended = Just $ withAttr "recommended" $ str "recommended"
@ -289,7 +287,7 @@ dimAttributes no_color = attrMap
| otherwise = Vty.withBackColor
eventHandler :: BrickState -> BrickEvent n e -> EventM n (Next BrickState)
eventHandler st@(BrickState {..}) ev = do
eventHandler st@BrickState{..} ev = do
AppState { keyBindings = kb } <- liftIO $ readIORef settings'
case ev of
(MouseDown _ Vty.BScrollUp _ _) ->
@ -298,9 +296,9 @@ eventHandler st@(BrickState {..}) ev = do
continue (BrickState { appState = moveCursor 1 appState Down, .. })
(VtyEvent (Vty.EvResize _ _)) -> continue st
(VtyEvent (Vty.EvKey Vty.KUp _)) ->
continue (BrickState { appState = (moveCursor 1 appState Up), .. })
continue BrickState{ appState = moveCursor 1 appState Up, .. }
(VtyEvent (Vty.EvKey Vty.KDown _)) ->
continue (BrickState { appState = (moveCursor 1 appState Down), .. })
continue BrickState{ appState = moveCursor 1 appState Down, .. }
(VtyEvent (Vty.EvKey key _)) ->
case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
Nothing -> continue st
@ -309,7 +307,7 @@ eventHandler st@(BrickState {..}) ev = do
moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
moveCursor steps ais@(BrickInternalState {..}) direction =
moveCursor steps ais@BrickInternalState{..} direction =
let newIx = if direction == Down then ix + steps else ix - steps
in case clr !? newIx of
Just _ -> BrickInternalState { ix = newIx, .. }
@ -325,7 +323,7 @@ withIOAction action as = case listSelectedElement' (appState as) of
Nothing -> continue as
Just (ix, e) -> suspendAndResume $ do
action as (ix, e) >>= \case
Left err -> putStrLn $ ("Error: " <> err)
Left err -> putStrLn ("Error: " <> err)
Right _ -> putStrLn "Success"
getAppData Nothing (pfreq . appData $ as) >>= \case
Right data' -> do
@ -339,7 +337,7 @@ withIOAction action as = case listSelectedElement' (appState as) of
-- This synchronises @BrickInternalState@ with @BrickData@
-- and @BrickSettings@.
updateList :: BrickData -> BrickState -> BrickState
updateList appD (BrickState {..}) =
updateList appD BrickState{..} =
let newInternalState = constructList appD appSettings (Just appState)
in BrickState { appState = newInternalState
, appData = appD
@ -352,11 +350,11 @@ constructList :: BrickData
-> BrickSettings
-> Maybe BrickInternalState
-> BrickInternalState
constructList appD appSettings mapp =
replaceLR (filterVisible (showAll appSettings)) (lr appD) mapp
constructList appD appSettings =
replaceLR (filterVisible (showAll appSettings)) (lr appD)
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
listSelectedElement' (BrickInternalState {..}) = fmap (ix, ) $ clr !? ix
listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
selectLatest :: Vector ListResult -> Int
@ -420,7 +418,7 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
, TarDirDoesNotExist
]
(run $ do
run (do
case lTool of
GHC -> do
let vi = getVersionInfo lVer GHC dls
@ -437,7 +435,7 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
)
>>= \case
VRight vi -> do
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
@ -457,7 +455,7 @@ set' _ (_, ListResult {..}) = do
. flip runReaderT settings
. runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
(run $ do
run (do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
@ -477,7 +475,7 @@ del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
(run $ do
run (do
let vi = getVersionInfo lVer lTool dls
case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
@ -602,6 +600,6 @@ getAppData mg pfreq' = do
case r of
Right dls -> do
lV <- listVersions dls Nothing Nothing pfreq'
pure $ Right $ (BrickData (reverse lV) dls pfreq')
pure $ Right $ BrickData (reverse lV) dls pfreq'
Left e -> pure $ Left [i|#{e}|]

View File

@ -276,7 +276,7 @@ opts =
<*> com
where
parseUri s' =
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
first show $ parseURI strictURIParserOptions (UTF8.fromString s')
com :: Parser Command
@ -298,37 +298,33 @@ com =
#endif
"install"
( Install
<$> (info
<$> info
(installParser <**> helper)
( progDesc "Install or update GHC/cabal"
<> footerDoc (Just $ text installToolFooter)
)
)
)
<> command
"set"
((info
(Set <$> setParser <**> helper)
( progDesc "Set currently active GHC/cabal version"
<> footerDoc (Just $ text setFooter)
)
)
(info
(Set <$> setParser <**> helper)
( progDesc "Set currently active GHC/cabal version"
<> footerDoc (Just $ text setFooter)
)
)
<> command
"rm"
((info
(Rm <$> rmParser <**> helper)
( progDesc "Remove a GHC/cabal version"
<> footerDoc (Just $ text rmFooter)
)
)
(info
(Rm <$> rmParser <**> helper)
( progDesc "Remove a GHC/cabal version"
<> footerDoc (Just $ text rmFooter)
)
)
<> command
"list"
((info (List <$> listOpts <**> helper)
(progDesc "Show available GHCs and other tools")
)
(info (List <$> listOpts <**> helper)
(progDesc "Show available GHCs and other tools")
)
<> command
"upgrade"
@ -343,31 +339,28 @@ com =
<> command
"compile"
( Compile
<$> (info (compileP <**> helper)
(progDesc "Compile a tool from source")
)
<$> info (compileP <**> helper)
(progDesc "Compile a tool from source")
)
<> commandGroup "Main commands:"
)
<|> subparser
( command
"debug-info"
((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
((\_ -> DInfo) <$> info helper (progDesc "Show debug info"))
<> command
"tool-requirements"
( (\_ -> ToolRequirements)
<$> (info (helper)
(progDesc "Show the requirements for ghc/cabal")
)
<$> info helper
(progDesc "Show the requirements for ghc/cabal")
)
<> command
"changelog"
((info
(info
(fmap ChangeLog changelogP <**> helper)
( progDesc "Find/show changelog"
<> footerDoc (Just $ text changeLogFooter)
)
)
)
<> commandGroup "Other commands:"
<> hidden
@ -375,12 +368,11 @@ com =
<|> subparser
( command
"install-cabal"
((info
(info
((InstallCabalLegacy <$> installOpts (Just Cabal)) <**> helper)
( progDesc "Install or update cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
)
<> internal
)
@ -425,32 +417,29 @@ installParser =
( command
"ghc"
( InstallGHC
<$> (info
<$> info
(installOpts (Just GHC) <**> helper)
( progDesc "Install GHC"
<> footerDoc (Just $ text installGHCFooter)
)
)
)
<> command
"cabal"
( InstallCabal
<$> (info
<$> info
(installOpts (Just Cabal) <**> helper)
( progDesc "Install Cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
)
<> command
"hls"
( InstallHLS
<$> (info
<$> info
(installOpts (Just HLS) <**> helper)
( progDesc "Install haskell-languge-server"
<> footerDoc (Just $ text installHLSFooter)
)
)
)
)
)
@ -488,7 +477,7 @@ Examples:
installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool =
(\p (u, v) b -> InstallOptions v p u b)
<$> (optional
<$> optional
(option
(eitherReader platformParser)
( short 'p'
@ -498,19 +487,17 @@ installOpts tool =
"Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
)
)
)
<*> ( ( (,)
<$> (optional
<$> optional
(option
(eitherReader bindistParser)
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
"Install the specified version from this bindist"
)
)
)
<*> (Just <$> toolVersionArgument Nothing tool)
)
<|> (pure (Nothing, Nothing))
<|> pure (Nothing, Nothing)
)
<*> flag
False
@ -526,32 +513,29 @@ setParser =
( command
"ghc"
( SetGHC
<$> (info
<$> info
(setOpts (Just GHC) <**> helper)
( progDesc "Set GHC version"
<> footerDoc (Just $ text setGHCFooter)
)
)
)
<> command
"cabal"
( SetCabal
<$> (info
<$> info
(setOpts (Just Cabal) <**> helper)
( progDesc "Set Cabal version"
<> footerDoc (Just $ text setCabalFooter)
)
)
)
<> command
"hls"
( SetHLS
<$> (info
<$> info
(setOpts (Just HLS) <**> helper)
( progDesc "Set haskell-language-server version"
<> footerDoc (Just $ text setHLSFooter)
)
)
)
)
)
@ -587,7 +571,7 @@ listOpts =
"Tool to list versions for. Default is all"
)
)
<*> (optional
<*> optional
(option
(eitherReader criteriaParser)
( short 'c'
@ -596,7 +580,6 @@ listOpts =
<> help "Show only installed or set tool versions"
)
)
)
<*> switch
(short 'r' <> long "raw-format" <> help "More machine-parsable format"
)
@ -607,20 +590,18 @@ rmParser =
(Left <$> subparser
( command
"ghc"
(RmGHC <$> (info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version")))
(RmGHC <$> info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version"))
<> command
"cabal"
( RmCabal
<$> (info (versionParser' (Just ListInstalled) (Just Cabal) <**> helper)
(progDesc "Remove Cabal version")
)
<$> info (versionParser' (Just ListInstalled) (Just Cabal) <**> helper)
(progDesc "Remove Cabal version")
)
<> command
"hls"
( RmHLS
<$> (info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
(progDesc "Remove haskell-language-server version")
)
<$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
(progDesc "Remove haskell-language-server version")
)
)
)
@ -636,21 +617,20 @@ changelogP :: Parser ChangeLogOptions
changelogP =
(\x y -> ChangeLogOptions x y)
<$> switch (short 'o' <> long "open" <> help "xdg-open the changelog url")
<*> (optional
<*> optional
(option
(eitherReader
(\s' -> case fmap toLower s' of
"ghc" -> Right GHC
"cabal" -> Right Cabal
"ghcup" -> Right GHCup
e -> Left $ e
e -> Left e
)
)
(short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help
"Open changelog for given tool (default: ghc)"
)
)
)
<*> optional (toolVersionArgument Nothing Nothing)
compileP :: Parser CompileCommand
@ -658,12 +638,11 @@ compileP = subparser
( command
"ghc"
( CompileGHC
<$> (info
<$> info
(ghcCompileOpts <**> helper)
( progDesc "Compile GHC from source"
<> footerDoc (Just $ text compileFooter)
)
)
)
)
where
@ -692,14 +671,13 @@ ghcCompileOpts =
(\CabalCompileOptions {..} crossTarget addConfArgs setCompile -> GHCCompileOptions { .. }
)
<$> cabalCompileOpts
<*> (optional
<*> optional
(option
str
(short 'x' <> long "cross-target" <> metavar "CROSS_TARGET" <> help
"Build cross-compiler for this platform"
)
)
)
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
<*> flag
False
@ -711,15 +689,14 @@ ghcCompileOpts =
cabalCompileOpts :: Parser CabalCompileOptions
cabalCompileOpts =
CabalCompileOptions
<$> (option
<$> option
(eitherReader
(bimap (const "Not a valid version") id . version . T.pack)
(first (const "Not a valid version") . version . T.pack)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile"
)
)
<*> (option
<*> option
(eitherReader
(\x ->
(bimap (const "Not a valid version") Left . version . T.pack $ x)
@ -732,7 +709,6 @@ cabalCompileOpts =
<> help
"The GHC version (or full path) to bootstrap with (must be installed)"
)
)
<*> optional
(option
(eitherReader (readEither @Int))
@ -744,7 +720,7 @@ cabalCompileOpts =
(option
(eitherReader
(\x ->
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
@ -757,7 +733,7 @@ cabalCompileOpts =
(option
(eitherReader
(\x ->
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
@ -774,10 +750,9 @@ toolVersionParser = verP' <|> toolP
verP' = ToolVersion <$> versionParser
toolP =
ToolTag
<$> (option
<$> option
(eitherReader tagEither)
(short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
)
-- | same as toolVersionParser, except as an argument.
toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
@ -797,8 +772,8 @@ setVersionArgument criteria tool =
where
setEither s' =
parseSet s'
<|> bimap id SetToolTag (tagEither s')
<|> bimap id SetToolVersion (tVersionEither s')
<|> second SetToolTag (tagEither s')
<|> second SetToolVersion (tVersionEither s')
parseSet s' = case fmap toLower s' of
"next" -> Right SetNext
other -> Left [i|Unknown tag/version #{other}|]
@ -884,12 +859,12 @@ tagEither s' = case fmap toLower s' of
tVersionEither :: String -> Either String GHCTargetVersion
tVersionEither =
bimap (const "Not a valid version") id . MP.parse ghcTargetVerP "" . T.pack
first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack
toolVersionEither :: String -> Either String ToolVersion
toolVersionEither s' =
bimap id ToolTag (tagEither s') <|> bimap id ToolVersion (tVersionEither s')
second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s')
toolParser :: String -> Either String Tool
@ -930,7 +905,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
Left e -> Left $ errorBundlePretty e
where
archP :: MP.Parsec Void Text Architecture
archP = (MP.try (MP.chunk "x86_64" $> A_64)) <|> (MP.chunk "i386" $> A_32)
archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32)
platformP :: MP.Parsec Void Text PlatformRequest
platformP = choice'
[ (\a mv -> PlatformRequest a FreeBSD mv)
@ -990,7 +965,7 @@ toSettings options = do
pure $ mergeConf options dirs userConf
where
mergeConf :: Options -> Dirs -> UserSettings -> AppState
mergeConf (Options {..}) dirs (UserSettings {..}) =
mergeConf Options{..} dirs UserSettings{..} =
let cache = fromMaybe (fromMaybe False uCache) optCache
noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify
verbose = fromMaybe (fromMaybe False uVerbose) optVerbose
@ -1027,10 +1002,10 @@ upgradeOptsP =
"Upgrade ghcup in-place (wherever it's at)"
)
<|> ( UpgradeAt
<$> (option
<$> option
(eitherReader
(\x ->
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
@ -1038,14 +1013,13 @@ upgradeOptsP =
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
"Absolute filepath to write ghcup into"
)
)
)
<|> (pure UpgradeGHCupDir)
<|> pure UpgradeGHCupDir
describe_result :: String
describe_result = $( (LitE . StringL) <$>
describe_result = $( LitE . StringL <$>
runIO (do
CapturedProcess{..} <- executeOut [rel|git|] ["describe"] Nothing
case _exitCode of
@ -1059,7 +1033,7 @@ main :: IO ()
main = do
let versionHelp = infoOption
( ("The GHCup Haskell installer, version " <>)
$ (head . lines $ describe_result)
(head . lines $ describe_result)
)
(long "version" <> help "Show version" <> hidden)
let numericVersionHelp = infoOption
@ -1273,8 +1247,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) ("GHC installation successful")
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) "GHC installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
@ -1311,8 +1285,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) ("Cabal installation successful")
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) "Cabal installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
@ -1341,8 +1315,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) ("HLS installation successful")
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) "HLS installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
@ -1357,12 +1331,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let setGHC' SetOptions{..} =
(runSetGHC $ do
runSetGHC (do
v <- liftE $ fst <$> fromVersion' dls sToolVer GHC
liftE $ setGHC v SetGHCOnly
)
>>= \case
VRight (GHCTargetVersion{..}) -> do
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo)
[i|GHC #{prettyVer _tvVersion} successfully set as default version#{maybe "" (" for cross target " <>) _tvTarget}|]
@ -1372,13 +1346,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 5
let setCabal' SetOptions{..} =
(runSetCabal $ do
runSetCabal (do
v <- liftE $ fst <$> fromVersion' dls sToolVer Cabal
liftE $ setCabal (_tvVersion v)
pure v
)
>>= \case
VRight (GHCTargetVersion{..}) -> do
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo)
[i|Cabal #{prettyVer _tvVersion} successfully set as default version|]
@ -1388,13 +1362,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 14
let setHLS' SetOptions{..} =
(runSetHLS $ do
runSetHLS (do
v <- liftE $ fst <$> fromVersion' dls sToolVer HLS
liftE $ setHLS (_tvVersion v)
pure v
)
>>= \case
VRight (GHCTargetVersion{..}) -> do
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo)
[i|HLS #{prettyVer _tvVersion} successfully set as default version|]
@ -1404,14 +1378,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
(runRm $ do
runRm (do
liftE $
rmGHCVer ghcVer
pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
)
>>= \case
VRight vi -> do
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft e -> do
@ -1419,14 +1393,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 7
let rmCabal' tv =
(runRm $ do
runRm (do
liftE $
rmCabalVer tv
pure (getVersionInfo tv Cabal dls)
)
>>= \case
VRight vi -> do
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft e -> do
@ -1434,14 +1408,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 15
let rmHLS' tv =
(runRm $ do
runRm (do
liftE $
rmHLSVer tv
pure (getVersionInfo tv HLS dls)
)
>>= \case
VRight vi -> do
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft e -> do
@ -1470,8 +1444,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Set (Left (SetCabal sopts)) -> setCabal' sopts
Set (Left (SetHLS sopts)) -> setHLS' sopts
List (ListOptions {..}) ->
(runListGHC $ do
List ListOptions {..} ->
runListGHC (do
l <- listVersions dls lTool lCriteria pfreq
liftIO $ printListResult lRawFormat l
pure ExitSuccess
@ -1485,8 +1459,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Rm (Left (RmHLS rmopts)) -> rmHLS' rmopts
DInfo ->
do
(runDebugInfo $ liftE $ getDebugInfo)
do runDebugInfo $ liftE getDebugInfo
>>= \case
VRight dinfo -> do
putStrLn $ prettyDebugInfo dinfo
@ -1496,12 +1469,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 8
Compile (CompileGHC GHCCompileOptions {..}) ->
(runCompileGHC $ do
runCompileGHC (do
let vi = getVersionInfo targetVer GHC dls
forM_ (join $ fmap _viPreCompile vi) $ \msg -> do
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ $(logInfo) msg
lift $ $(logInfo)
("...waiting for 5 seconds, you can still abort...")
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
liftE $ compileGHC dls
(GHCTargetVersion crossTarget targetVer)
@ -1518,8 +1491,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
runLogger $ $(logInfo)
("GHC successfully compiled and installed")
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
"GHC successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
@ -1537,16 +1510,16 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 9
Upgrade (uOpts) force -> do
Upgrade uOpts force -> do
target <- case uOpts of
UpgradeInplace -> do
efp <- liftIO $ getExecutablePath
efp <- liftIO getExecutablePath
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
pure $ Just p
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
runUpgrade (liftE $ upgradeGHCup dls target force pfreq) >>= \case
VRight v' -> do
let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
@ -1563,14 +1536,12 @@ Make sure to clean up #{tmpdir} afterwards.|])
pure $ ExitFailure 11
ToolRequirements ->
( runLogger
$ runE
runLogger
(runE
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do
platform <- liftE $ getPlatform
req <-
(getCommonRequirements platform $ treq)
?? NoToolRequirements
platform <- liftE getPlatform
req <- getCommonRequirements platform treq ?? NoToolRequirements
liftIO $ T.hPutStr stdout (prettyRequirements req)
)
>>= \case
@ -1579,7 +1550,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
runLogger $ $(logError) $ T.pack $ prettyShow e
pure $ ExitFailure 12
ChangeLog (ChangeLogOptions {..}) -> do
ChangeLog ChangeLogOptions{..} -> do
let tool = fromMaybe GHC clTool
ver' = maybe
(Right Latest)
@ -1626,7 +1597,7 @@ fromVersion :: (MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, Mo
-> Maybe ToolVersion
-> Tool
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion av tv tool = fromVersion' av (toSetToolVer tv) tool
fromVersion av tv = fromVersion' av (toSetToolVer tv)
fromVersion' :: (MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
=> GHCupDownloads
@ -1880,7 +1851,7 @@ checkForUpdates dls pfreq = do
where
latestInstalled tool = (fmap lVer . lastMay)
<$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
<$> listVersions dls (Just tool) (Just ListInstalled) pfreq
prettyDebugInfo :: DebugInfo -> String