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

Chores

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
.gitlab-ci.yml
View File

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

3
.gitlab/script/ghcup_version.sh
View File

@ -20,7 +20,10 @@ git describe --always
ecabal update ecabal update
(
cd /tmp
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
)
if [ "${OS}" = "DARWIN" ] ; then if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} -ftui 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

14
app/ghcup-gen/Main.hs
View File

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

20
app/ghcup-gen/Validate.hs
View File

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

86
app/ghcup/BrickMain.hs
View File

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

189
app/ghcup/Main.hs
View File

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

2
cabal.project
View File

@ -9,6 +9,8 @@ package streamly
package ghcup package ghcup
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
tests: True
flags: +tui
constraints: http-io-streams -brotli constraints: http-io-streams -brotli

2
ghcup.cabal
View File

@ -52,7 +52,7 @@ common async
build-depends: async >=0.8 build-depends: async >=0.8
common base common base
build-depends: base >=4.12 && <5 build-depends: base >=4.13 && <5
common base16-bytestring common base16-bytestring
build-depends: base16-bytestring >= 0.1.1.6 build-depends: base16-bytestring >= 0.1.1.6

25
hie.yaml
View File

@ -1,19 +1,10 @@
cradle: cradle:
cabal: cabal:
- path: "./lib" - component: "ghcup:lib:ghcup"
component: "lib:ghcup" path: ./lib
- component: "ghcup:exe:ghcup"
- path: "./app/ghcup/Main.hs" path: ./app/ghcup
component: "ghcup:exe:ghcup" - component: "ghcup:exe:ghcup-gen"
path: "./app/ghcup-gen"
- path: "./app/ghcup/BrickMain.hs" - component: "ghcup:test:ghcup-test"
component: "ghcup:exe:ghcup" path: ./test
- path: "./app/ghcup-gen/Main.hs"
component: "ghcup:exe:ghcup-gen"
- path: "./app/ghcup-gen/Validate.hs"
component: "ghcup:exe:ghcup-gen"
- path: "./test"
component: "ghcup:test:ghcup-test"

107
lib/GHCup.hs
View File

@ -123,10 +123,9 @@ installGHCBindist :: ( MonadFail m
m m
() ()
installGHCBindist dlinfo ver pfreq = do installGHCBindist dlinfo ver pfreq = do
let tver = (mkTVer ver) let tver = mkTVer ver
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (lift $ ghcInstalled tver) whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
$ (throwE $ AlreadyInstalled GHC ver)
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -173,7 +172,7 @@ installPackedGHC :: ( MonadMask m
, ArchiveResult , ArchiveResult
#endif #endif
] m () ] m ()
installPackedGHC dl msubdir inst ver pfreq@(PlatformRequest {..}) = do installPackedGHC dl msubdir inst ver pfreq@PlatformRequest{..} = do
-- unpack -- unpack
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
@ -182,7 +181,7 @@ installPackedGHC dl msubdir inst ver pfreq@(PlatformRequest {..}) = do
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack) (liftE . intoSubdir tmpUnpack)
(msubdir) msubdir
liftE $ runBuildAction tmpUnpack liftE $ runBuildAction tmpUnpack
(Just inst) (Just inst)
@ -201,11 +200,11 @@ installUnpackedGHC :: ( MonadReader AppState m
-> Version -- ^ The GHC version -> Version -- ^ The GHC version
-> PlatformRequest -> PlatformRequest
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver (PlatformRequest {..}) = do installUnpackedGHC path inst ver PlatformRequest{..} = do
lift $ $(logInfo) "Installing GHC (this may take a while)" lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ execLogged "./configure" lEM $ execLogged "./configure"
False False
(["--prefix=" <> toFilePath inst] ++ alpineArgs) (("--prefix=" <> toFilePath inst) : alpineArgs)
[rel|ghc-configure|] [rel|ghc-configure|]
(Just path) (Just path)
Nothing Nothing
@ -283,7 +282,7 @@ installCabalBindist :: ( MonadMask m
] ]
m m
() ()
installCabalBindist dlinfo ver (PlatformRequest {..}) = do installCabalBindist dlinfo ver PlatformRequest {..} = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
AppState {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
@ -295,7 +294,7 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
-- ignore when the installation is a legacy cabal (binary, not symlink) -- ignore when the installation is a legacy cabal (binary, not symlink)
$ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|])) $ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|]))
) )
$ (throwE $ AlreadyInstalled Cabal ver) (throwE $ AlreadyInstalled Cabal ver)
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -311,12 +310,10 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
liftE $ installCabal' workdir binDir liftE $ installCabal' workdir binDir
-- create symlink if this is the latest version -- create symlink if this is the latest version
cVers <- lift $ fmap rights $ getInstalledCabals cVers <- lift $ fmap rights getInstalledCabals
let lInstCabal = headMay . reverse . sort $ cVers let lInstCabal = headMay . reverse . sort $ cVers
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
pure ()
where where
-- | Install an unpacked cabal distribution. -- | Install an unpacked cabal distribution.
installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m) installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
@ -331,7 +328,7 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
let destPath = inst </> destFileName let destPath = inst </> destFileName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile) (path </> cabalFile)
(destPath) destPath
Overwrite Overwrite
lift $ chmod_755 destPath lift $ chmod_755 destPath
@ -398,13 +395,13 @@ installHLSBindist :: ( MonadMask m
] ]
m m
() ()
installHLSBindist dlinfo ver (PlatformRequest {..}) = do installHLSBindist dlinfo ver PlatformRequest{..} = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|] lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
AppState {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
whenM (lift (hlsInstalled ver)) whenM (lift (hlsInstalled ver))
$ (throwE $ AlreadyInstalled HLS ver) (throwE $ AlreadyInstalled HLS ver)
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
@ -420,12 +417,10 @@ installHLSBindist dlinfo ver (PlatformRequest {..}) = do
liftE $ installHLS' workdir binDir liftE $ installHLS' workdir binDir
-- create symlink if this is the latest version -- create symlink if this is the latest version
hlsVers <- lift $ fmap rights $ getInstalledHLSs hlsVers <- lift $ fmap rights getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
pure ()
where where
-- | Install an unpacked hls distribution. -- | Install an unpacked hls distribution.
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
@ -525,7 +520,7 @@ setGHC ver sghc = do
let verBS = verToBS (_tvVersion ver) let verBS = verToBS (_tvVersion ver)
ghcdir <- lift $ ghcupGHCDir ver ghcdir <- lift $ ghcupGHCDir ver
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver)) whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
-- symlink destination -- symlink destination
AppState { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
@ -603,7 +598,7 @@ setCabal ver = do
AppState {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
liftIO $ createDirRecursive' binDir liftIO $ createDirRecursive' binDir
whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile)) whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
$ throwE $ throwE
$ NotInstalled Cabal (GHCTargetVersion Nothing ver) $ NotInstalled Cabal (GHCTargetVersion Nothing ver)
@ -647,7 +642,7 @@ setHLS ver = do
-- set haskell-language-server-<ghcver> symlinks -- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver bins <- lift $ hlsServerBinaries ver
when (bins == []) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver) when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
forM_ bins $ \f -> do forM_ bins $ \f -> do
let destL = toFilePath f let destL = toFilePath f
@ -705,7 +700,7 @@ data ListResult = ListResult
-- | Extract all available tool versions and their tags. -- | Extract all available tool versions and their tags.
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag] availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag]
availableToolVersions av tool = view availableToolVersions av tool = view
(at tool % non Map.empty % to (fmap (_viTags))) (at tool % non Map.empty % to (fmap _viTags))
av av
@ -733,13 +728,13 @@ listVersions av lt criteria pfreq = do
case t of case t of
GHC -> do GHC -> do
slr <- strayGHCs avTools slr <- strayGHCs avTools
pure $ (sort (slr ++ lr)) pure (sort (slr ++ lr))
Cabal -> do Cabal -> do
slr <- strayCabals avTools slr <- strayCabals avTools
pure $ (sort (slr ++ lr)) pure (sort (slr ++ lr))
HLS -> do HLS -> do
slr <- strayHLS avTools slr <- strayHLS avTools
pure $ (sort (slr ++ lr)) pure (sort (slr ++ lr))
GHCup -> pure lr GHCup -> pure lr
Nothing -> do Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria pfreq ghcvers <- listVersions av (Just GHC) criteria pfreq
@ -761,21 +756,21 @@ listVersions av lt criteria pfreq = do
Nothing -> do Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
fromSrc <- ghcSrcInstalled tver fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) $ hlsGHCVersions hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
pure $ Just $ ListResult pure $ Just $ ListResult
{ lTool = GHC { lTool = GHC
, lVer = _tvVersion , lVer = _tvVersion
, lCross = Nothing , lCross = Nothing
, lTag = [] , lTag = []
, lInstalled = True , lInstalled = True
, lStray = maybe True (const False) (Map.lookup _tvVersion avTools) , lStray = isNothing (Map.lookup _tvVersion avTools)
, lNoBindist = False , lNoBindist = False
, .. , ..
} }
Right tver@GHCTargetVersion{ .. } -> do Right tver@GHCTargetVersion{ .. } -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- ghcSrcInstalled tver fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) $ hlsGHCVersions hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
pure $ Just $ ListResult pure $ Just $ ListResult
{ lTool = GHC { lTool = GHC
, lVer = _tvVersion , lVer = _tvVersion
@ -801,14 +796,14 @@ listVersions av lt criteria pfreq = do
case Map.lookup ver avTools of case Map.lookup ver avTools of
Just _ -> pure Nothing Just _ -> pure Nothing
Nothing -> do Nothing -> do
lSet <- fmap (maybe False (== ver)) $ cabalSet lSet <- fmap (== Just ver) cabalSet
pure $ Just $ ListResult pure $ Just $ ListResult
{ lTool = Cabal { lTool = Cabal
, lVer = ver , lVer = ver
, lCross = Nothing , lCross = Nothing
, lTag = [] , lTag = []
, lInstalled = True , lInstalled = True
, lStray = maybe True (const False) (Map.lookup ver avTools) , lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False , lNoBindist = False
, fromSrc = False -- actually, we don't know :> , fromSrc = False -- actually, we don't know :>
, hlsPowered = False , hlsPowered = False
@ -829,14 +824,14 @@ listVersions av lt criteria pfreq = do
case Map.lookup ver avTools of case Map.lookup ver avTools of
Just _ -> pure Nothing Just _ -> pure Nothing
Nothing -> do Nothing -> do
lSet <- fmap (maybe False (== ver)) $ hlsSet lSet <- fmap (== Just ver) hlsSet
pure $ Just $ ListResult pure $ Just $ ListResult
{ lTool = HLS { lTool = HLS
, lVer = ver , lVer = ver
, lCross = Nothing , lCross = Nothing
, lTag = [] , lTag = []
, lInstalled = True , lInstalled = True
, lStray = maybe True (const False) (Map.lookup ver avTools) , lStray = isNothing (Map.lookup ver avTools)
, lNoBindist = False , lNoBindist = False
, fromSrc = False -- actually, we don't know :> , fromSrc = False -- actually, we don't know :>
, hlsPowered = False , hlsPowered = False
@ -856,11 +851,11 @@ listVersions av lt criteria pfreq = do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lInstalled <- ghcInstalled tver lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem v) $ hlsGHCVersions hlsPowered <- fmap (elem v) hlsGHCVersions
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do Cabal -> do
let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq av let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq av
lSet <- fmap (maybe False (== v)) $ cabalSet lSet <- fmap (== Just v) cabalSet
lInstalled <- cabalInstalled v lInstalled <- cabalInstalled v
pure ListResult { lVer = v pure ListResult { lVer = v
, lCross = Nothing , lCross = Nothing
@ -886,7 +881,7 @@ listVersions av lt criteria pfreq = do
} }
HLS -> do HLS -> do
let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq av let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq av
lSet <- fmap (maybe False (== v)) $ hlsSet lSet <- fmap (== Just v) hlsSet
lInstalled <- hlsInstalled v lInstalled <- hlsInstalled v
pure ListResult { lVer = v pure ListResult { lVer = v
, lCross = Nothing , lCross = Nothing
@ -927,7 +922,7 @@ rmGHCVer :: ( MonadReader AppState m
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmGHCVer ver = do rmGHCVer ver = do
isSetGHC <- lift $ fmap (maybe False (== ver)) $ ghcSet (_tvTarget ver) isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver)
whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver)) whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver))
dir <- lift $ ghcupGHCDir ver dir <- lift $ ghcupGHCDir ver
@ -960,8 +955,7 @@ rmGHCVer ver = do
liftIO liftIO
$ hideError doesNotExistErrorType $ hideError doesNotExistErrorType
$ deleteFile $ deleteFile (baseDir </> [rel|share|])
$ (baseDir </> [rel|share|])
-- | Delete a cabal version. Will try to fix the @cabal@ symlink -- | Delete a cabal version. Will try to fix the @cabal@ symlink
@ -972,15 +966,15 @@ rmCabalVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, M
rmCabalVer ver = do rmCabalVer ver = do
whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver)) whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver))
cSet <- lift $ cabalSet cSet <- lift cabalSet
AppState {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver) cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile) liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile)
when (maybe False (== ver) cSet) $ do when (Just ver == cSet) $ do
cVers <- lift $ fmap rights $ getInstalledCabals cVers <- lift $ fmap rights getInstalledCabals
case headMay . reverse . sort $ cVers of case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver Just latestver -> setCabal latestver
Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile
@ -995,21 +989,21 @@ rmHLSVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, Mon
rmHLSVer ver = do rmHLSVer ver = do
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)) whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))
isHlsSet <- lift $ hlsSet isHlsSet <- lift hlsSet
AppState {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
bins <- lift $ hlsAllBinaries ver bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f) forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f)
when (maybe False (== ver) isHlsSet) $ do when (Just ver == isHlsSet) $ do
-- delete all set symlinks -- delete all set symlinks
oldSyms <- lift hlsSymlinks oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do forM_ oldSyms $ \f -> do
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|] lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
liftIO $ deleteFile (binDir </> f) liftIO $ deleteFile (binDir </> f)
-- set latest hls -- set latest hls
hlsVers <- lift $ fmap rights $ getInstalledHLSs hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of case headMay . reverse . sort $ hlsVers of
Just latestver -> setHLS latestver Just latestver -> setHLS latestver
Nothing -> pure () Nothing -> pure ()
@ -1034,7 +1028,7 @@ getDebugInfo = do
diGHCDir <- lift ghcupGHCBaseDir diGHCDir <- lift ghcupGHCBaseDir
let diCacheDir = cacheDir let diCacheDir = cacheDir
diArch <- lE getArchitecture diArch <- lE getArchitecture
diPlatform <- liftE $ getPlatform diPlatform <- liftE getPlatform
pure $ DebugInfo { .. } pure $ DebugInfo { .. }
@ -1081,12 +1075,12 @@ compileGHC :: ( MonadMask m
] ]
m m
() ()
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@(PlatformRequest {..}) compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformRequest{..}
= do = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|] lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
alreadyInstalled <- lift $ ghcInstalled tver alreadyInstalled <- lift $ ghcInstalled tver
alreadySet <- fmap (maybe False (==tver)) $ lift $ ghcSet (_tvTarget tver) alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver)
-- download source tarball -- download source tarball
dlInfo <- dlInfo <-
@ -1131,7 +1125,6 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@(PlatformReque
-- restore -- restore
when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
pure ()
where where
defaultConf = case _tvTarget tver of defaultConf = case _tvTarget tver of
@ -1165,29 +1158,28 @@ Stage1Only = YES|]
(Path Abs) -- ^ output path of bindist (Path Abs) -- ^ output path of bindist
compileBindist bghc ghcdir workdir = do compileBindist bghc ghcdir workdir = do
lift $ $(logInfo) [i|configuring build|] lift $ $(logInfo) [i|configuring build|]
liftE $ checkBuildConfig liftE checkBuildConfig
AppState { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
cEnv <- liftIO $ getEnvironment cEnv <- liftIO getEnvironment
if if
| (_tvVersion tver) >= [vver|8.8.0|] -> do | _tvVersion tver >= [vver|8.8.0|] -> do
bghcPath <- case bghc of bghcPath <- case bghc of
Right ghc' -> pure ghc' Right ghc' -> pure ghc'
Left bver -> do Left bver -> do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
(liftIO $ searchPath spaths bver) !? NotFoundInPATH bver liftIO (searchPath spaths bver) !? NotFoundInPATH bver
lEM $ execLogged lEM $ execLogged
"./configure" "./configure"
False False
( ["--prefix=" <> toFilePath ghcdir] ( ["--prefix=" <> toFilePath ghcdir]
++ (maybe mempty ++ maybe mempty
(\x -> ["--target=" <> E.encodeUtf8 x]) (\x -> ["--target=" <> E.encodeUtf8 x])
(_tvTarget tver) (_tvTarget tver)
)
++ fmap E.encodeUtf8 aargs ++ fmap E.encodeUtf8 aargs
) )
[rel|ghc-conf|] [rel|ghc-conf|]
@ -1200,10 +1192,9 @@ Stage1Only = YES|]
( [ "--prefix=" <> toFilePath ghcdir ( [ "--prefix=" <> toFilePath ghcdir
, "--with-ghc=" <> either toFilePath toFilePath bghc , "--with-ghc=" <> either toFilePath toFilePath bghc
] ]
++ (maybe mempty ++ maybe mempty
(\x -> ["--target=" <> E.encodeUtf8 x]) (\x -> ["--target=" <> E.encodeUtf8 x])
(_tvTarget tver) (_tvTarget tver)
)
++ fmap E.encodeUtf8 aargs ++ fmap E.encodeUtf8 aargs
) )
[rel|ghc-conf|] [rel|ghc-conf|]
@ -1267,7 +1258,7 @@ Stage1Only = YES|]
-- for cross, we need Stage1Only -- for cross, we need Stage1Only
case _tvTarget tver of case _tvTarget tver of
Just _ -> when (not $ elem "Stage1Only = YES" lines') $ throwE Just _ -> when ("Stage1Only = YES" `notElem` lines') $ throwE
(InvalidBuildConfig (InvalidBuildConfig
[s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
) )
@ -1326,7 +1317,7 @@ upgradeGHCup dls mtarget force pfreq = do
Overwrite Overwrite
lift $ chmod_755 destFile lift $ chmod_755 destFile
liftIO (isInPath destFile) >>= \b -> when (not b) $ liftIO (isInPath destFile) >>= \b -> unless b $
lift $ $(logWarn) [i|"#{toFilePath (dirname destFile)}" is not in PATH! You have to add it in order to use ghcup.|] lift $ $(logWarn) [i|"#{toFilePath (dirname destFile)}" is not in PATH! You have to add it in order to use ghcup.|]
liftIO (isShadowed destFile) >>= \case liftIO (isShadowed destFile) >>= \case
Nothing -> pure () Nothing -> pure ()

20
lib/GHCup/Download.hs
View File

@ -127,7 +127,7 @@ getDownloadsF urlSource = do
GHCupURL -> liftE getBase GHCupURL -> liftE getBase
(OwnSource url) -> do (OwnSource url) -> do
bs <- reThrowAll DownloadFailed $ downloadBS url bs <- reThrowAll DownloadFailed $ downloadBS url
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
(OwnSpec av) -> pure av (OwnSpec av) -> pure av
(AddSource (Left ext)) -> do (AddSource (Left ext)) -> do
base <- liftE getBase base <- liftE getBase
@ -135,7 +135,7 @@ getDownloadsF urlSource = do
(AddSource (Right uri)) -> do (AddSource (Right uri)) -> do
base <- liftE getBase base <- liftE getBase
bsExt <- reThrowAll DownloadFailed $ downloadBS uri bsExt <- reThrowAll DownloadFailed $ downloadBS uri
ext <- lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bsExt) ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt)
pure (mergeGhcupInfo base ext) pure (mergeGhcupInfo base ext)
where where
@ -164,7 +164,7 @@ readFromCache = do
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file)) (\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
$ liftIO $ liftIO
$ readFile yaml_file $ readFile yaml_file
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs) lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m) getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
@ -173,8 +173,8 @@ getBase =
handleIO (\_ -> readFromCache) handleIO (\_ -> readFromCache)
$ catchE @_ @'[JSONError, FileDoesNotExistError] $ catchE @_ @'[JSONError, FileDoesNotExistError]
(\(DownloadFailed _) -> readFromCache) (\(DownloadFailed _) -> readFromCache)
$ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL) (reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL)
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict)) >>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict))
where where
-- First check if the json file is in the ~/.ghcup/cache dir -- First check if the json file is in the ~/.ghcup/cache dir
-- and check it's access time. If it has been accessed within the -- and check it's access time. If it has been accessed within the
@ -312,8 +312,8 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
in fmap snd in fmap snd
. find . find
(\(mverRange, _) -> maybe (\(mverRange, _) -> maybe
(mv' == Nothing) (isNothing mv')
(\range -> maybe False (flip versionRange range) mv') (\range -> maybe False (`versionRange` range) mv')
mverRange mverRange
) )
. M.toList . M.toList
@ -365,7 +365,7 @@ download dli dest mfn
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile) (liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme] $ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e -> (\e ->
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile) liftIO (hideError doesNotExistErrorType $ deleteFile destFile)
>> (throwE . DownloadFailed $ e) >> (throwE . DownloadFailed $ e)
) $ do ) $ do
lift getDownloader >>= \case lift getDownloader >>= \case
@ -416,7 +416,7 @@ downloadCached dli mfn = do
if if
| fileExists -> do | fileExists -> do
liftE $ checkDigest dli cachfile liftE $ checkDigest dli cachfile
pure $ cachfile pure cachfile
| otherwise -> liftE $ download dli cacheDir mfn | otherwise -> liftE $ download dli cacheDir mfn
False -> do False -> do
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
@ -453,7 +453,7 @@ downloadBS uri'
= dl False = dl False
| scheme == "file" | scheme == "file"
= liftIOException doesNotExistErrorType (FileDoesNotExistError path) = liftIOException doesNotExistErrorType (FileDoesNotExistError path)
$ (liftIO $ RD.readFile path) (liftIO $ RD.readFile path)
| otherwise | otherwise
= throwE UnsupportedScheme = throwE UnsupportedScheme

16
lib/GHCup/Download/IOStreams.hs
View File

@ -1,10 +1,6 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
@ -72,7 +68,7 @@ downloadBS' :: MonadIO m
, TooManyRedirs , TooManyRedirs
] ]
m m
(L.ByteString) L.ByteString
downloadBS' https host path port = do downloadBS' https host path port = do
bref <- liftIO $ newIORef (mempty :: Builder) bref <- liftIO $ newIORef (mempty :: Builder)
let stepper bs = modifyIORef bref (<> byteString bs) let stepper bs = modifyIORef bref (<> byteString bs)
@ -132,7 +128,7 @@ downloadInternal = go (5 :: Int)
if if
| scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing | scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
| scode >= 300 && scode < 400 -> case getHeader r "Location" of | scode >= 300 && scode < 400 -> case getHeader r "Location" of
Just r' -> pure $ Just $ r' Just r' -> pure $ Just r'
Nothing -> throwE NoLocationHeader Nothing -> throwE NoLocationHeader
| otherwise -> throwE $ HTTPStatusError scode | otherwise -> throwE $ HTTPStatusError scode
) )
@ -151,7 +147,7 @@ downloadInternal = go (5 :: Int)
Nothing -> 0 Nothing -> 0
mpb <- if progressBar mpb <- if progressBar
then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ())) then Just <$> liftIO (newProgressBar defStyle 10 (Progress 0 size ()))
else pure Nothing else pure Nothing
outStream <- liftIO $ Streams.makeOutputStream outStream <- liftIO $ Streams.makeOutputStream
@ -224,9 +220,9 @@ headInternal = go (5 :: Int)
if if
| scode >= 200 && scode < 300 -> do | scode >= 200 && scode < 300 -> do
let headers = getHeaderMap r let headers = getHeaderMap r
pure $ Right $ headers pure $ Right headers
| scode >= 300 && scode < 400 -> case getHeader r "Location" of | scode >= 300 && scode < 400 -> case getHeader r "Location" of
Just r' -> pure $ Left $ r' Just r' -> pure $ Left r'
Nothing -> throwE NoLocationHeader Nothing -> throwE NoLocationHeader
| otherwise -> throwE $ HTTPStatusError scode | otherwise -> throwE $ HTTPStatusError scode
) )
@ -243,7 +239,7 @@ withConnection' :: Bool
-> Maybe Int -> Maybe Int
-> (Connection -> IO a) -> (Connection -> IO a)
-> IO a -> IO a
withConnection' https host port action = bracket acquire closeConnection action withConnection' https host port = bracket acquire closeConnection
where where
acquire = case https of acquire = case https of

6
lib/GHCup/Download/Utils.hs
View File

@ -1,10 +1,6 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
@ -55,7 +51,7 @@ uriToQuadruple URI {..} = do
let queryBS = let queryBS =
BS.intercalate "&" BS.intercalate "&"
. fmap (\(x, y) -> encodeQuery x <> "=" <> encodeQuery y) . fmap (\(x, y) -> encodeQuery x <> "=" <> encodeQuery y)
$ (queryPairs uriQuery) $ queryPairs uriQuery
port = port =
preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
fullpath = if BS.null queryBS then uriPath else uriPath <> "?" <> queryBS fullpath = if BS.null queryBS then uriPath else uriPath <> "?" <> queryBS

3
lib/GHCup/Errors.hs
View File

@ -1,12 +1,11 @@
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-| {-|

9
lib/GHCup/Platform.hs
View File

@ -92,17 +92,16 @@ getPlatform = do
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver } pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
"darwin" -> do "darwin" -> do
ver <- ver <-
( either (const Nothing) Just either (const Nothing) Just
. versioning . versioning
-- TODO: maybe do this somewhere else -- TODO: maybe do this somewhere else
. getMajorVersion . getMajorVersion
. decUTF8Safe . decUTF8Safe
)
<$> getDarwinVersion <$> getDarwinVersion
pure $ PlatformResult { _platform = Darwin, _distroVersion = ver } pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
"freebsd" -> do "freebsd" -> do
ver <- ver <-
(either (const Nothing) Just . versioning . decUTF8Safe) either (const Nothing) Just . versioning . decUTF8Safe
<$> getFreeBSDVersion <$> getFreeBSDVersion
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver } pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
what -> throwE $ NoCompatiblePlatform what what -> throwE $ NoCompatiblePlatform what
@ -157,7 +156,7 @@ getLinuxDistro = do
try_os_release :: IO (Text, Maybe Text) try_os_release :: IO (Text, Maybe Text)
try_os_release = do try_os_release = do
Just (OsRelease { name = name, version_id = version_id }) <- Just OsRelease{ name = name, version_id = version_id } <-
fmap osRelease <$> parseOsRelease fmap osRelease <$> parseOsRelease
pure (T.pack name, fmap T.pack version_id) pure (T.pack name, fmap T.pack version_id)
@ -174,7 +173,7 @@ getLinuxDistro = do
let nameRegex n = let nameRegex n =
makeRegexOpts compIgnoreCase makeRegexOpts compIgnoreCase
execBlank execBlank
(([s|\<|] <> fS n <> [s|\>|] :: ByteString)) :: Regex ([s|\<|] <> fS n <> [s|\>|] :: ByteString) :: Regex
let verRegex = let verRegex =
makeRegexOpts compIgnoreCase makeRegexOpts compIgnoreCase
execBlank execBlank

4
lib/GHCup/Requirements.hs
View File

@ -49,8 +49,8 @@ getCommonRequirements pr tr =
in fmap snd in fmap snd
. find . find
(\(mverRange, _) -> maybe (\(mverRange, _) -> maybe
(mv' == Nothing) (isNothing mv')
(\range -> maybe False (flip versionRange range) mv') (\range -> maybe False (`versionRange` range) mv')
mverRange mverRange
) )
. M.toList . M.toList

2
lib/GHCup/Types.hs
View File

@ -365,7 +365,7 @@ pfReqToString (PlatformRequest arch plat ver) =
archToString arch ++ "-" ++ platformToString plat ++ pver archToString arch ++ "-" ++ platformToString plat ++ pver
where where
pver = case ver of pver = case ver of
Just v' -> "-" ++ (T.unpack $ prettyV v') Just v' -> "-" ++ T.unpack (prettyV v')
Nothing -> "" Nothing -> ""
instance Pretty PlatformRequest where instance Pretty PlatformRequest where

10
lib/GHCup/Types/JSON.hs
View File

@ -148,7 +148,7 @@ instance FromJSONKey Platform where
$ "Unexpected failure in decoding LinuxDistro: " $ "Unexpected failure in decoding LinuxDistro: "
<> show dstr <> show dstr
Nothing -> fail "Unexpected failure in Platform stripPrefix" Nothing -> fail "Unexpected failure in Platform stripPrefix"
| otherwise -> fail $ "Failure in Platform (FromJSONKey)" | otherwise -> fail "Failure in Platform (FromJSONKey)"
instance ToJSONKey Architecture where instance ToJSONKey Architecture where
toJSONKey = genericToJSONKey defaultJSONKeyOptions toJSONKey = genericToJSONKey defaultJSONKeyOptions
@ -272,7 +272,7 @@ verRangeToText (SimpleRange cmps) =
(versionCmpToText <$> NE.toList cmps) (versionCmpToText <$> NE.toList cmps)
in "( " <> inner <> " )" in "( " <> inner <> " )"
verRangeToText (OrRange cmps range) = verRangeToText (OrRange cmps range) =
let left = verRangeToText $ (SimpleRange cmps) let left = verRangeToText (SimpleRange cmps)
right = verRangeToText range right = verRangeToText range
in left <> " || " <> right in left <> " || " <> right
@ -288,7 +288,7 @@ versionRangeP = go <* MP.eof
go = go =
MP.try orParse MP.try orParse
<|> MP.try (fmap SimpleRange andParse) <|> MP.try (fmap SimpleRange andParse)
<|> (fmap (SimpleRange . pure) versionCmpP) <|> fmap (SimpleRange . pure) versionCmpP
orParse :: MP.Parsec Void T.Text VersionRange orParse :: MP.Parsec Void T.Text VersionRange
orParse = orParse =
@ -300,9 +300,7 @@ versionRangeP = go <* MP.eof
andParse = andParse =
fmap (\h t -> h :| t) fmap (\h t -> h :| t)
(MPC.space *> MP.chunk "(" *> MPC.space *> versionCmpP) (MPC.space *> MP.chunk "(" *> MPC.space *> versionCmpP)
<*> ( MP.try <*> MP.try (MP.many (MPC.space *> MP.chunk "&&" *> MPC.space *> versionCmpP))
$ MP.many (MPC.space *> MP.chunk "&&" *> MPC.space *> versionCmpP)
)
<* MPC.space <* MPC.space
<* MP.chunk ")" <* MP.chunk ")"
<* MPC.space <* MPC.space

86
lib/GHCup/Utils.hs
View File

@ -121,13 +121,13 @@ rmMinorSymlinks :: ( MonadReader AppState m
) )
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmMinorSymlinks tv@(GHCTargetVersion {..}) = do rmMinorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do forM_ files $ \f -> do
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> verToBS _tvVersion) f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> verToBS _tvVersion)
let fullF = (binDir </> f_xyz) let fullF = binDir </> f_xyz
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|] lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
@ -147,11 +147,11 @@ rmPlain target = do
forM_ mtv $ \tv -> do forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do forM_ files $ \f -> do
let fullF = (binDir </> f) let fullF = binDir </> f
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|] lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- old ghcup -- old ghcup
let hdc_file = (binDir </> [rel|haddock-ghc|]) let hdc_file = binDir </> [rel|haddock-ghc|]
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|] lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
@ -166,7 +166,7 @@ rmMajorSymlinks :: ( MonadReader AppState m
) )
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmMajorSymlinks tv@(GHCTargetVersion {..}) = do rmMajorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask AppState { dirs = Dirs {..} } <- lift ask
(mj, mi) <- getMajorMinorV _tvVersion (mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi let v' = intToText mj <> "." <> intToText mi
@ -174,7 +174,7 @@ rmMajorSymlinks tv@(GHCTargetVersion {..}) = do
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do forM_ files $ \f -> do
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> E.encodeUtf8 v') f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> E.encodeUtf8 v')
let fullF = (binDir </> f_xyz) let fullF = binDir </> f_xyz
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|] lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
@ -212,7 +212,7 @@ ghcSet mtarget = do
-- link destination is of the form ../ghc/<ver>/bin/ghc -- link destination is of the form ../ghc/<ver>/bin/ghc
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver> -- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
link <- readSymbolicLink $ toFilePath ghcBin link <- readSymbolicLink $ toFilePath ghcBin
Just <$> ghcLinkVersion link Just <$> ghcLinkVersion link
@ -256,7 +256,7 @@ getInstalledCabals = do
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
vs <- forM bins $ \f -> case fmap version (fmap decUTF8Safe . B.stripPrefix "cabal-" . toFilePath $ f) of vs <- forM bins $ \f -> case fmap (version . decUTF8Safe) . B.stripPrefix "cabal-" . toFilePath $ f of
Just (Right r) -> pure $ Right r Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f Nothing -> pure $ Left f
@ -267,8 +267,8 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed. -- | Whether the given cabal version is installed.
cabalInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool cabalInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
cabalInstalled ver = do cabalInstalled ver = do
vers <- fmap rights $ getInstalledCabals vers <- fmap rights getInstalledCabals
pure $ elem ver $ vers pure $ elem ver vers
-- Return the currently set cabal version, if any. -- Return the currently set cabal version, if any.
@ -279,7 +279,7 @@ cabalSet = do
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
if if
| b -> do | b -> do
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- isBrokenSymlink cabalbin broken <- isBrokenSymlink cabalbin
if broken if broken
then pure Nothing then pure Nothing
@ -321,23 +321,20 @@ getInstalledHLSs = do
execBlank execBlank
([s|^haskell-language-server-wrapper-.*$|] :: ByteString) ([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
) )
vs <- forM bins $ \f -> forM bins $ \f ->
case case
fmap fmap (version . decUTF8Safe) . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f
version
(fmap decUTF8Safe . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f)
of of
Just (Right r) -> pure $ Right r Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f Nothing -> pure $ Left f
pure $ vs
-- | Whether the given HLS version is installed. -- | Whether the given HLS version is installed.
hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
hlsInstalled ver = do hlsInstalled ver = do
vers <- fmap rights $ getInstalledHLSs vers <- fmap rights getInstalledHLSs
pure $ elem ver $ vers pure $ elem ver vers
@ -347,7 +344,7 @@ hlsSet = do
AppState {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|] let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- isBrokenSymlink hlsBin broken <- isBrokenSymlink hlsBin
if broken if broken
then pure Nothing then pure Nothing
@ -376,15 +373,13 @@ hlsGHCVersions = do
vers <- forM h $ \h' -> do vers <- forM h $ \h' -> do
bins <- hlsServerBinaries h' bins <- hlsServerBinaries h'
pure $ fmap pure $ fmap
(\bin -> (version
version
. decUTF8Safe . decUTF8Safe
. fromJust . fromJust
. B.stripPrefix "haskell-language-server-" . B.stripPrefix "haskell-language-server-"
. head . head
. B.split _tilde . B.split _tilde
. toFilePath . toFilePath
$ bin
) )
bins bins
pure . rights . concat . maybeToList $ vers pure . rights . concat . maybeToList $ vers
@ -421,7 +416,7 @@ hlsWrapperBinary ver = do
) )
) )
case wrapper of case wrapper of
[] -> pure $ Nothing [] -> pure Nothing
[x] -> pure $ Just x [x] -> pure $ Just x
_ -> throwM $ UnexpectedListLength _ -> throwM $ UnexpectedListLength
"There were multiple hls wrapper binaries for a single version" "There were multiple hls wrapper binaries for a single version"
@ -498,12 +493,8 @@ getLatestGHCFor :: Int -- ^ major version component
-> Int -- ^ minor version component -> Int -- ^ minor version component
-> GHCupDownloads -> GHCupDownloads
-> Maybe (Version, VersionInfo) -> Maybe (Version, VersionInfo)
getLatestGHCFor major' minor' dls = do getLatestGHCFor major' minor' dls =
join preview (ix GHC % to Map.toDescList) dls >>= lastMay . filter (\(v, _) -> matchMajor v major' minor')
. fmap (lastMay . filter (\(v, _) -> matchMajor v major' minor'))
. preview (ix GHC % to Map.toDescList)
$ dls
@ -524,7 +515,7 @@ unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
#endif #endif
] m () ] m ()
unpackToDir dest av = do unpackToDir dest av = do
fp <- (decUTF8Safe . toFilePath) <$> basename av fp <- decUTF8Safe . toFilePath <$> basename av
let dfp = decUTF8Safe . toFilePath $ dest let dfp = decUTF8Safe . toFilePath $ dest
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|] lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
fn <- toFilePath <$> basename av fn <- toFilePath <$> basename av
@ -570,9 +561,9 @@ intoSubdir bdir tardir = case tardir of
let rs = splitOn "/" r let rs = splitOn "/" r
foldlM foldlM
(\y x -> (\y x ->
(fmap sort . handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= \case (handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
[] -> throwE $ TarDirDoesNotExist tardir [] -> throwE $ TarDirDoesNotExist tardir
(p : _) -> pure (y </> p) (p : _) -> pure (y </> p)) . sort
) )
bdir bdir
rs rs
@ -591,16 +582,15 @@ intoSubdir bdir tardir = case tardir of
getTagged :: Tag getTagged :: Tag
-> AffineFold (Map.Map Version VersionInfo) (Version, VersionInfo) -> AffineFold (Map.Map Version VersionInfo) (Version, VersionInfo)
getTagged tag = getTagged tag =
( to (Map.filter (\VersionInfo {..} -> elem tag _viTags)) to (Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
% to Map.toDescList % to Map.toDescList
% _head % _head
)
getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo) getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatest av tool = headOf (ix tool % getTagged Latest) $ av getLatest av tool = headOf (ix tool % getTagged Latest) av
getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo) getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getRecommended av tool = headOf (ix tool % getTagged Recommended) $ av getRecommended av tool = headOf (ix tool % getTagged Recommended) av
-- | Gets the latest GHC with a given base version. -- | Gets the latest GHC with a given base version.
@ -671,10 +661,10 @@ ghcToolFiles ver = do
then pure id then pure id
else do else do
(Just symver) <- (Just symver) <-
(B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName) B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName
<$> (liftIO $ readSymbolicLink $ toFilePath ghcbinPath) <$> liftIO (readSymbolicLink $ toFilePath ghcbinPath)
when (B.null symver) when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken") (throwIO $ userError "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x)
pure $ onlyUnversioned files pure $ onlyUnversioned files
@ -699,8 +689,8 @@ make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
-> Maybe (Path Abs) -> Maybe (Path Abs)
-> m (Either ProcessError ()) -> m (Either ProcessError ())
make args workdir = do make args workdir = do
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath) spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|]) has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
let mymake = if has_gmake then "gmake" else "make" let mymake = if has_gmake then "gmake" else "make"
execLogged mymake True args [rel|ghc-make|] workdir Nothing execLogged mymake True args [rel|ghc-make|] workdir Nothing
@ -715,13 +705,13 @@ applyPatches pdir ddir = do
patches <- liftIO $ getDirsFiles pdir patches <- liftIO $ getDirsFiles pdir
forM_ (sort patches) $ \patch' -> do forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) [i|Applying patch #{patch'}|] lift $ $(logInfo) [i|Applying patch #{patch'}|]
(fmap (either (const Nothing) Just) $ liftIO $ exec fmap (either (const Nothing) Just)
(liftIO $ exec
"patch" "patch"
True True
["-p1", "-i", toFilePath patch'] ["-p1", "-i", toFilePath patch']
(Just ddir) (Just ddir)
Nothing Nothing)
)
!? PatchFailed !? PatchFailed
@ -767,8 +757,7 @@ runBuildAction bdir instdir action = do
(\es -> do (\es -> do
exAction exAction
throwE (BuildFailed bdir es) throwE (BuildFailed bdir es)
) ) action
$ action
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
bdir bdir
@ -800,14 +789,13 @@ getVersionInfo :: Version
-> Tool -> Tool
-> GHCupDownloads -> GHCupDownloads
-> Maybe VersionInfo -> Maybe VersionInfo
getVersionInfo v' tool dls = getVersionInfo v' tool =
headOf headOf
( ix tool ( ix tool
% to (Map.filterWithKey (\k _ -> k == v')) % to (Map.filterWithKey (\k _ -> k == v'))
% to Map.elems % to Map.elems
% _head % _head
) )
dls
-- Gathering monoidal values -- Gathering monoidal values
@ -816,4 +804,4 @@ traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
-- | Gathering monoidal values -- | Gathering monoidal values
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forFold = \t -> \f -> traverseFold f t forFold = \t -> (`traverseFold` t)

6
lib/GHCup/Utils/Dirs.hs
View File

@ -190,7 +190,7 @@ ghcupConfigFile = do
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
case bs of case bs of
Nothing -> pure defaultUserSettings Nothing -> pure defaultUserSettings
Just bs' -> lE' JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict $ bs' Just bs' -> lE' JSONDecodeError . first show . Y.decodeEither' . L.toStrict $ bs'
------------------------- -------------------------
@ -228,7 +228,7 @@ parseGHCupGHCDir (toFilePath -> f) = do
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs) mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp" tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> "ghcup-") tmp <- liftIO $ mkdtemp (tmpdir FP.</> "ghcup-")
parseAbs tmp parseAbs tmp
@ -266,7 +266,7 @@ relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2 common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
cPrefix = drop (length common) d1 cPrefix = drop (length common) d1
in joinPath (replicate (length cPrefix) "..") in joinPath (replicate (length cPrefix) "..")
<> joinPath ("/" : (drop (length common) d2)) <> joinPath ("/" : drop (length common) d2)

31
lib/GHCup/Utils/File.hs
View File

@ -107,12 +107,14 @@ makeLenses ''CapturedProcess
-- PATH does. -- PATH does.
findExecutable :: Path Rel -> IO (Maybe (Path Abs)) findExecutable :: Path Rel -> IO (Maybe (Path Abs))
findExecutable ex = do findExecutable ex = do
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath sPaths <- fmap (catMaybes . fmap parseAbs) getSearchPath
-- We don't want exceptions to mess up our result. If we can't -- We don't want exceptions to mess up our result. If we can't
-- figure out if a file exists, then treat it as a negative result. -- figure out if a file exists, then treat it as a negative result.
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap asum $ fmap
(handleIO (\_ -> pure Nothing)
-- asum for short-circuiting behavior -- asum for short-circuiting behavior
(\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex))) . (\s' -> (isExecutable (s' </> ex) >>= guard) $> Just (s' </> ex))
)
sPaths sPaths
@ -150,11 +152,12 @@ execLogged exe spath args lfile chdir env = do
void void
$ forkIO $ forkIO
$ EX.handle (\(_ :: IOException) -> pure ()) $ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ()) $ EX.finally
$ (if verbose (if verbose
then tee fd stdoutRead then tee fd stdoutRead
else printToRegion fd stdoutRead 6 pState else printToRegion fd stdoutRead 6 pState
) )
(putMVar done ())
-- fork the subprocess -- fork the subprocess
pid <- SPPB.forkProcess $ do pid <- SPPB.forkProcess $ do
@ -203,7 +206,7 @@ execLogged exe spath args lfile chdir env = do
$ handle $ handle
(\(ex :: SomeException) -> do (\(ex :: SomeException) -> do
ps <- liftIO $ takeMVar pState ps <- liftIO $ takeMVar pState
when (ps == True) (forM_ rs (liftIO . closeConsoleRegion)) when ps (forM_ rs (liftIO . closeConsoleRegion))
throw ex throw ex
) )
$ readTilEOF (lineAction rs) fdIn $ readTilEOF (lineAction rs) fdIn
@ -247,7 +250,7 @@ execLogged exe spath args lfile chdir env = do
=> Fd -- ^ input file descriptor => Fd -- ^ input file descriptor
-> ByteString -- ^ rest buffer (read across newline) -> ByteString -- ^ rest buffer (read across newline)
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof) -> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
readLine fd = \inBs -> go inBs readLine fd = go
where where
go inBs = do go inBs = do
-- if buffer is not empty, process it first -- if buffer is not empty, process it first
@ -275,7 +278,7 @@ execLogged exe spath args lfile chdir env = do
(bs, rest, eof) <- readLine fd' bs' (bs, rest, eof) <- readLine fd' bs'
if eof if eof
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing) then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
else (void $ action' bs) >> go rest else void (action' bs) >> go rest
-- | Capture the stdout and stderr of the given action, which -- | Capture the stdout and stderr of the given action, which
@ -329,7 +332,7 @@ captureOutStreams action = do
, _stdErr = stderr' , _stdErr = stderr'
} }
_ -> throwIO $ userError $ ("No such PID " ++ show pid) _ -> throwIO $ userError ("No such PID " ++ show pid)
where where
writeStds pout perr rout rerr = do writeStds pout perr rout rerr = do
@ -356,7 +359,7 @@ captureOutStreams action = do
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
actionWithPipes a = actionWithPipes a =
createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2) createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
cleanup :: [Fd] -> IO () cleanup :: [Fd] -> IO ()
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
@ -423,7 +426,7 @@ isShadowed :: Path Abs -> IO (Maybe (Path Abs))
isShadowed p = do isShadowed p = do
let dir = dirname p let dir = dirname p
fn <- basename p fn <- basename p
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath) spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
if dir `elem` spaths if dir `elem` spaths
then do then do
let shadowPaths = takeWhile (/= dir) spaths let shadowPaths = takeWhile (/= dir) spaths
@ -437,7 +440,7 @@ isInPath :: Path Abs -> IO Bool
isInPath p = do isInPath p = do
let dir = dirname p let dir = dirname p
fn <- basename p fn <- basename p
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath) spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
if dir `elem` spaths if dir `elem` spaths
then isJust <$> searchPath [dir] fn then isJust <$> searchPath [dir] fn
else pure False else pure False
@ -451,7 +454,7 @@ findFiles path regex = do
. S.toList . S.toList
. S.filter (\(_, p) -> match regex p) . S.filter (\(_, p) -> match regex p)
$ dirContentsStream dirStream $ dirContentsStream dirStream
pure $ join $ fmap parseRel f pure $ parseRel =<< f
findFiles' :: Path Abs -> MP.Parsec Void Text () -> IO [Path Rel] findFiles' :: Path Abs -> MP.Parsec Void Text () -> IO [Path Rel]
@ -464,7 +467,7 @@ findFiles' path parser = do
Left _ -> False Left _ -> False
Right p' -> isJust $ MP.parseMaybe parser p') Right p' -> isJust $ MP.parseMaybe parser p')
$ dirContentsStream dirStream $ dirContentsStream dirStream
pure $ join $ fmap parseRel f pure $ parseRel =<< f
isBrokenSymlink :: Path Abs -> IO Bool isBrokenSymlink :: Path Abs -> IO Bool

3
lib/GHCup/Utils/Logger.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-| {-|
@ -51,7 +50,7 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]" LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n") let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug))) when (lcPrintDebug || (not lcPrintDebug && (level /= LevelDebug)))
$ colorOutter out $ colorOutter out
-- raw output -- raw output

20
lib/GHCup/Utils/MegaParsec.hs
View File

@ -15,7 +15,6 @@ module GHCup.Utils.MegaParsec where
import GHCup.Types import GHCup.Types
import Control.Applicative import Control.Applicative
import Control.Monad
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
#endif #endif
@ -61,9 +60,9 @@ ghcTargetBinP :: Text -> MP.Parsec Void Text (Maybe Text, Text)
ghcTargetBinP t = ghcTargetBinP t =
(,) (,)
<$> ( MP.try <$> ( MP.try
(Just <$> (parseUntil1 (MP.chunk "-" *> MP.chunk t)) <* MP.chunk "-" (Just <$> parseUntil1 (MP.chunk "-" *> MP.chunk t) <* MP.chunk "-"
) )
<|> (flip const Nothing <$> mempty) <|> ((\ _ x -> x) Nothing <$> mempty)
) )
<*> (MP.chunk t <* MP.eof) <*> (MP.chunk t <* MP.eof)
@ -74,8 +73,8 @@ ghcTargetBinP t =
ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion
ghcTargetVerP = ghcTargetVerP =
(\x y -> GHCTargetVersion x y) (\x y -> GHCTargetVersion x y)
<$> (MP.try (Just <$> (parseUntil1 (MP.chunk "-" *> verP')) <* MP.chunk "-") <$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
<|> (flip const Nothing <$> mempty) <|> ((\ _ x -> x) Nothing <$> mempty)
) )
<*> (version' <* MP.eof) <*> (version' <* MP.eof)
where where
@ -85,16 +84,15 @@ ghcTargetVerP =
let startsWithDigists = let startsWithDigists =
and and
. take 3 . take 3
. join . concatMap
. (fmap . fmap) (map
(\case (\case
(Digits _) -> True (Digits _) -> True
(Str _) -> False (Str _) -> False
) ) . NE.toList)
. fmap NE.toList
. NE.toList . NE.toList
$ (_vChunks v) $ _vChunks v
if startsWithDigists && not (isJust (_vEpoch v)) if startsWithDigists && isNothing (_vEpoch v)
then pure $ prettyVer v then pure $ prettyVer v
else fail "Oh" else fail "Oh"

17
lib/GHCup/Utils/Prelude.hs
View File

@ -1,10 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
@ -131,7 +128,7 @@ lE' :: forall e' e es a m
=> (e' -> e) => (e' -> e)
-> Either e' a -> Either e' a
-> Excepts es m a -> Excepts es m a
lE' f = liftE . veitherToExcepts . fromEither . bimap f id lE' f = liftE . veitherToExcepts . fromEither . first f
lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
lEM em = lift em >>= lE lEM em = lift em >>= lE
@ -141,7 +138,7 @@ lEM' :: forall e' e es a m
=> (e' -> e) => (e' -> e)
-> m (Either e' a) -> m (Either e' a)
-> Excepts es m a -> Excepts es m a
lEM' f em = lift em >>= lE . bimap f id lEM' f em = lift em >>= lE . first f
fromEither :: Either a b -> VEither '[a] b fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight fromEither = either (VLeft . V) VRight
@ -200,8 +197,8 @@ hideExcept :: forall e es es' a m
-> a -> a
-> Excepts es m a -> Excepts es m a
-> Excepts es' m a -> Excepts es' m a
hideExcept _ a action = hideExcept _ a =
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a))
hideExcept' :: forall e es es' m hideExcept' :: forall e es es' m
@ -209,8 +206,8 @@ hideExcept' :: forall e es es' m
=> e => e
-> Excepts es m () -> Excepts es m ()
-> Excepts es' m () -> Excepts es' m ()
hideExcept' _ action = hideExcept' _ =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ()))
reThrowAll :: forall e es es' a m reThrowAll :: forall e es es' a m
@ -259,7 +256,7 @@ addToCurrentEnv :: MonadIO m
=> [(ByteString, ByteString)] => [(ByteString, ByteString)]
-> m [(ByteString, ByteString)] -> m [(ByteString, ByteString)]
addToCurrentEnv adds = do addToCurrentEnv adds = do
cEnv <- liftIO $ getEnvironment cEnv <- liftIO getEnvironment
pure (adds ++ cEnv) pure (adds ++ cEnv)

4
lib/GHCup/Utils/Version/QQ.hs
View File

@ -57,7 +57,7 @@ deriving instance Lift (NonEmpty Word)
qq :: (Text -> Q Exp) -> QuasiQuoter qq :: (Text -> Q Exp) -> QuasiQuoter
qq quoteExp' = QuasiQuoter qq quoteExp' = QuasiQuoter
{ quoteExp = (\s -> quoteExp' . T.pack $ s) { quoteExp = \s -> quoteExp' . T.pack $ s
, quotePat = \_ -> , quotePat = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType = \_ -> , quoteType = \_ ->
@ -101,4 +101,4 @@ liftText :: T.Text -> Q Exp
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt) liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
liftDataWithText :: Data a => a -> Q Exp liftDataWithText :: Data a => a -> Q Exp
liftDataWithText = dataToExpQ (\a -> liftText <$> cast a) liftDataWithText = dataToExpQ (fmap liftText . cast)

25
test/GHCup/ArbitraryTypes.hs
View File

@ -1,10 +1,7 @@
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module GHCup.ArbitraryTypes where module GHCup.ArbitraryTypes where
@ -57,7 +54,7 @@ instance Arbitrary T.Text where
shrink xs = T.pack <$> shrink (T.unpack xs) shrink xs = T.pack <$> shrink (T.unpack xs)
instance Arbitrary (NonEmpty Word) where instance Arbitrary (NonEmpty Word) where
arbitrary = fmap fromList $ listOf1 $ arbitrary arbitrary = fmap fromList $ listOf1 arbitrary
-- utf8 encoded bytestring -- utf8 encoded bytestring
instance Arbitrary ByteString where instance Arbitrary ByteString where
@ -70,7 +67,7 @@ instance Arbitrary ByteString where
--------------------- ---------------------
instance Arbitrary Scheme where instance Arbitrary Scheme where
arbitrary = oneof [ Scheme <$> pure "http", Scheme <$> pure "https" ] arbitrary = oneof [ pure (Scheme "http"), pure (Scheme "https") ]
instance Arbitrary Host where instance Arbitrary Host where
arbitrary = genericArbitrary arbitrary = genericArbitrary
@ -82,7 +79,7 @@ instance Arbitrary Port where
instance Arbitrary (URIRef Absolute) where instance Arbitrary (URIRef Absolute) where
arbitrary = arbitrary =
URI <$> arbitrary <*> pure Nothing <*> arbitrary <*> (Query <$> pure []) <*> pure Nothing URI <$> arbitrary <*> pure Nothing <*> arbitrary <*> pure (Query []) <*> pure Nothing
@ -95,32 +92,28 @@ instance Arbitrary Mess where
(x, y, z) <- genVer (x, y, z) <- genVer
pure pure
$ either (error . show) id $ either (error . show) id
$ mess $ mess (intToText x <> "." <> intToText y <> "." <> intToText z)
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary Version where instance Arbitrary Version where
arbitrary = do arbitrary = do
(x, y, z) <- genVer (x, y, z) <- genVer
pure pure
$ either (error . show) id $ either (error . show) id
$ version $ version (intToText x <> "." <> intToText y <> "." <> intToText z)
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary SemVer where instance Arbitrary SemVer where
arbitrary = do arbitrary = do
(x, y, z) <- genVer (x, y, z) <- genVer
pure pure
$ either (error . show) id $ either (error . show) id
$ semver $ semver (intToText x <> "." <> intToText y <> "." <> intToText z)
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary PVP where instance Arbitrary PVP where
arbitrary = do arbitrary = do
(x, y, z) <- genVer (x, y, z) <- genVer
pure pure
$ either (error . show) id $ either (error . show) id
$ pvp $ pvp (intToText x <> "." <> intToText y <> "." <> intToText z)
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary Versioning where instance Arbitrary Versioning where
arbitrary = Ideal <$> arbitrary arbitrary = Ideal <$> arbitrary
@ -173,8 +166,8 @@ instance Arbitrary VersionCmp where
instance Arbitrary (Path Rel) where instance Arbitrary (Path Rel) where
arbitrary = arbitrary =
(either (error . show) id . parseRel . E.encodeUtf8 . T.pack) either (error . show) id . parseRel . E.encodeUtf8 . T.pack
<$> (listOf1 $ elements ['a' .. 'z']) <$> listOf1 (elements ['a' .. 'z'])
instance Arbitrary TarDir where instance Arbitrary TarDir where
arbitrary = genericArbitrary arbitrary = genericArbitrary

1
test/GHCup/Types/JSONSpec.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module GHCup.Types.JSONSpec where module GHCup.Types.JSONSpec where

4
test/Main.hs
View File

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