Chores
This commit is contained in:
parent
910d660732
commit
d5b5f1fddd
GPG Key ID:
3786C5262ECB4A3F
@ -1,4 +1,5 @@
|
||||
stages:
|
||||
- hlint
|
||||
- test
|
||||
- release
|
||||
|
||||
@ -153,6 +154,7 @@ test:linux:stack:
|
||||
- ./.gitlab/script/ghcup_stack.sh
|
||||
extends:
|
||||
- .debian
|
||||
needs: []
|
||||
|
||||
######## bootstrap test ########
|
||||
|
||||
@ -167,6 +169,7 @@ test:linux:bootstrap_script:
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
extends:
|
||||
- .debian
|
||||
needs: []
|
||||
|
||||
######## linux test ########
|
||||
|
||||
@ -176,6 +179,7 @@ test:linux:recommended:
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
needs: []
|
||||
|
||||
test:linux:latest:
|
||||
stage: test
|
||||
@ -183,6 +187,7 @@ test:linux:latest:
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
needs: []
|
||||
|
||||
######## linux 32bit test ########
|
||||
|
||||
@ -192,22 +197,27 @@ test:linux:recommended:32bit:
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.2.0.0"
|
||||
needs: []
|
||||
|
||||
######## arm tests ########
|
||||
|
||||
test:linux:recommended:armv7:
|
||||
stage: test
|
||||
extends: .test_ghcup_version:armv7
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
when: manual
|
||||
needs: []
|
||||
|
||||
test:linux:recommended:aarch64:
|
||||
stage: test
|
||||
extends: .test_ghcup_version:aarch64
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
when: manual
|
||||
needs: []
|
||||
|
||||
######## darwin test ########
|
||||
|
||||
@ -217,6 +227,7 @@ test:mac:recommended:
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
needs: []
|
||||
|
||||
test:mac:latest:
|
||||
stage: test
|
||||
@ -224,6 +235,7 @@ test:mac:latest:
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
needs: []
|
||||
|
||||
|
||||
######## freebsd test ########
|
||||
@ -234,6 +246,9 @@ test:freebsd:recommended:
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
allow_failure: true # freebsd runners are unreliable
|
||||
when: manual
|
||||
needs: []
|
||||
|
||||
test:freebsd:latest:
|
||||
stage: test
|
||||
@ -241,6 +256,9 @@ test:freebsd:latest:
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
allow_failure: true # freebsd runners are unreliable
|
||||
when: manual
|
||||
needs: []
|
||||
|
||||
|
||||
######## linux release ########
|
||||
@ -332,3 +350,24 @@ release:freebsd:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
|
||||
|
||||
######## hlint ########
|
||||
|
||||
hlint:
|
||||
stage: hlint
|
||||
extends:
|
||||
- .alpine:64bit
|
||||
before_script:
|
||||
- ./.gitlab/before_script/linux/alpine/install_deps.sh
|
||||
script:
|
||||
- ./.gitlab/script/hlint.sh
|
||||
variables:
|
||||
GHC_VERSION: "8.10.4"
|
||||
CABAL_VERSION: "3.4.0.0"
|
||||
JSON_VERSION: "0.0.4"
|
||||
allow_failure: true
|
||||
artifacts:
|
||||
expire_in: 2 week
|
||||
paths:
|
||||
- report.html
|
||||
when: on_failure
|
||||
|
||||
@ -20,7 +20,10 @@ git describe --always
|
||||
|
||||
ecabal update
|
||||
|
||||
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
|
||||
(
|
||||
cd /tmp
|
||||
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
|
||||
)
|
||||
|
||||
if [ "${OS}" = "DARWIN" ] ; then
|
||||
ecabal build -w ghc-${GHC_VERSION} -ftui
|
||||
|
||||
19
.gitlab/script/hlint.sh
Executable file
19
.gitlab/script/hlint.sh
Executable 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
83
.hlint.yaml
Normal 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
|
||||
@ -44,11 +44,10 @@ data Input
|
||||
fileInput :: Parser Input
|
||||
fileInput =
|
||||
FileInput
|
||||
<$> (strOption
|
||||
<$> strOption
|
||||
(long "file" <> short 'f' <> metavar "FILENAME" <> help
|
||||
"Input file to validate"
|
||||
)
|
||||
)
|
||||
|
||||
stdInput :: Parser Input
|
||||
stdInput = flag'
|
||||
@ -76,7 +75,7 @@ tarballFilterP = option readm $
|
||||
case span (/= '-') s of
|
||||
(_, []) -> fail "invalid format, missing '-' after the tool name"
|
||||
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
|
||||
TarballFilter <$> pure (Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
|
||||
pure (TarballFilter $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
|
||||
_ -> fail "invalid tool"
|
||||
low = fmap toLower
|
||||
|
||||
@ -86,21 +85,18 @@ opts = Options <$> com
|
||||
|
||||
com :: Parser Command
|
||||
com = subparser
|
||||
( (command
|
||||
( command
|
||||
"check"
|
||||
( ValidateYAML
|
||||
<$> (info (validateYAMLOpts <**> helper)
|
||||
(progDesc "Validate the YAML")
|
||||
)
|
||||
<$> info (validateYAMLOpts <**> helper)
|
||||
(progDesc "Validate the YAML")
|
||||
)
|
||||
)
|
||||
<> (command
|
||||
<> command
|
||||
"check-tarballs"
|
||||
(info
|
||||
((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
|
||||
(progDesc "Validate all tarballs (download and checksum)")
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
@ -85,26 +85,26 @@ validate dls = do
|
||||
checkHasRequiredPlatforms t v tags arch pspecs = do
|
||||
let v' = prettyVer v
|
||||
arch' = prettyShow arch
|
||||
when (not $ any (== Linux UnknownLinux) pspecs) $ do
|
||||
when (notElem (Linux UnknownLinux) pspecs) $ do
|
||||
lift $ $(logError)
|
||||
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch'}|]
|
||||
addError
|
||||
when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do
|
||||
when ((notElem Darwin pspecs) && arch == A_64) $ do
|
||||
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch'}|]
|
||||
addError
|
||||
when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
|
||||
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn)
|
||||
[i|FreeBSD missing for #{t} #{v'} #{arch'}|]
|
||||
|
||||
-- alpine needs to be set explicitly, because
|
||||
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
|
||||
-- (although it could be static)
|
||||
when (not $ any (== Linux Alpine) pspecs) $
|
||||
when (notElem (Linux Alpine) pspecs) $
|
||||
case t of
|
||||
GHCup | arch `elem` [A_64, A_32] -> (lift $ $(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]) >> addError
|
||||
GHCup | arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]) >> addError
|
||||
Cabal | v > [vver|2.4.1.0|]
|
||||
, arch `elem` [A_64, A_32] -> (lift $ $(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]) >> addError
|
||||
, arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]) >> addError
|
||||
GHC | Latest `elem` tags || Recommended `elem` tags
|
||||
, arch `elem` [A_64, A_32] -> lift $ $(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]
|
||||
, arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|])
|
||||
_ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]
|
||||
|
||||
checkUniqueTags tool = do
|
||||
@ -116,7 +116,7 @@ validate dls = do
|
||||
(\case
|
||||
[] -> throwM $ InternalError "empty inner list"
|
||||
(t : ts) ->
|
||||
pure $ (t, ) $ if isUniqueTag t then ts == [] else True
|
||||
pure $ (t, ) (not (isUniqueTag t) || null ts)
|
||||
)
|
||||
. group
|
||||
. sort
|
||||
@ -190,7 +190,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do
|
||||
%& indices (matchTest versionRegex . T.unpack . prettyVer)
|
||||
% (viSourceDL % _Just `summing` viArch % each % each % each)
|
||||
when (null dlis) $ $(logError) [i|no tarballs selected by filter|] *> addError
|
||||
forM_ dlis $ downloadAll
|
||||
forM_ dlis downloadAll
|
||||
|
||||
-- exit
|
||||
e <- liftIO $ readIORef ref
|
||||
@ -203,7 +203,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do
|
||||
where
|
||||
runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
|
||||
, colorOutter = B.hPut stderr
|
||||
, rawOutter = (\_ -> pure ())
|
||||
, rawOutter = \_ -> pure ()
|
||||
}
|
||||
downloadAll dli = do
|
||||
dirs <- liftIO getDirs
|
||||
|
||||
@ -98,16 +98,15 @@ keyHandlers KeyBindings {..} =
|
||||
, (bSet, const "Set" , withIOAction set')
|
||||
, (bChangelog, const "ChangeLog", withIOAction changelog')
|
||||
, ( bShowAll
|
||||
, (\BrickSettings {..} ->
|
||||
if showAll then "Hide old versions" else "Show all versions"
|
||||
)
|
||||
, \BrickSettings {..} ->
|
||||
if showAll then "Hide old versions" else "Show all versions"
|
||||
, hideShowHandler
|
||||
)
|
||||
, (bUp, const "Up", \BrickState {..} -> continue (BrickState { appState = (moveCursor 1 appState Up), .. }))
|
||||
, (bDown, const "Down", \BrickState {..} -> continue (BrickState { appState = (moveCursor 1 appState Down), .. }))
|
||||
, (bUp, const "Up", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Up, .. })
|
||||
, (bDown, const "Down", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Down, .. })
|
||||
]
|
||||
where
|
||||
hideShowHandler (BrickState {..}) =
|
||||
hideShowHandler BrickState{..} =
|
||||
let newAppSettings = appSettings { showAll = not . showAll $ appSettings }
|
||||
newInternalState = constructList appData newAppSettings (Just appState)
|
||||
in continue (BrickState appData newAppSettings newInternalState appKeys)
|
||||
@ -115,19 +114,18 @@ keyHandlers KeyBindings {..} =
|
||||
|
||||
showKey :: Vty.Key -> String
|
||||
showKey (Vty.KChar c) = [c]
|
||||
showKey (Vty.KUp) = "↑"
|
||||
showKey (Vty.KDown) = "↓"
|
||||
showKey Vty.KUp = "↑"
|
||||
showKey Vty.KDown = "↓"
|
||||
showKey key = tail (show key)
|
||||
|
||||
|
||||
ui :: AttrMap -> BrickState -> Widget String
|
||||
ui dimAttrs BrickState { appSettings = as@(BrickSettings {}), ..}
|
||||
= ( padBottom Max
|
||||
$ ( withBorderStyle unicode
|
||||
$ borderWithLabel (str "GHCup")
|
||||
$ (center $ (header <=> hBorder <=> renderList' appState))
|
||||
ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
|
||||
= padBottom Max
|
||||
( withBorderStyle unicode
|
||||
$ borderWithLabel (str "GHCup")
|
||||
(center (header <=> hBorder <=> renderList' appState))
|
||||
)
|
||||
)
|
||||
<=> footer
|
||||
|
||||
where
|
||||
@ -136,15 +134,16 @@ ui dimAttrs BrickState { appSettings = as@(BrickSettings {}), ..}
|
||||
. txtWrap
|
||||
. T.pack
|
||||
. foldr1 (\x y -> x <> " " <> y)
|
||||
$ (fmap (\(key, s, _) -> (showKey key <> ":" <> s as)) $ keyHandlers appKeys)
|
||||
. fmap (\(key, s, _) -> showKey key <> ":" <> s as)
|
||||
$ keyHandlers appKeys
|
||||
header =
|
||||
(minHSize 2 $ emptyWidget)
|
||||
<+> (padLeft (Pad 2) $ minHSize 6 $ str "Tool")
|
||||
<+> (minHSize 15 $ str "Version")
|
||||
<+> (padLeft (Pad 1) $ minHSize 25 $ str "Tags")
|
||||
<+> (padLeft (Pad 5) $ str "Notes")
|
||||
minHSize 2 emptyWidget
|
||||
<+> padLeft (Pad 2) (minHSize 6 $ str "Tool")
|
||||
<+> minHSize 15 (str "Version")
|
||||
<+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
|
||||
<+> padLeft (Pad 5) (str "Notes")
|
||||
renderList' = withDefAttr listAttr . drawListElements renderItem True
|
||||
renderItem _ b listResult@(ListResult {..}) =
|
||||
renderItem _ b listResult@ListResult{..} =
|
||||
let marks = if
|
||||
| lSet -> (withAttr "set" $ str "✔✔")
|
||||
| lInstalled -> (withAttr "installed" $ str "✓ ")
|
||||
@ -153,8 +152,8 @@ ui dimAttrs BrickState { appSettings = as@(BrickSettings {}), ..}
|
||||
Nothing -> T.unpack . prettyVer $ lVer
|
||||
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
|
||||
dim
|
||||
| lNoBindist && (not lInstalled)
|
||||
&& (not b) -- TODO: overloading dim and active ignores active
|
||||
| lNoBindist && not lInstalled
|
||||
&& not b -- TODO: overloading dim and active ignores active
|
||||
-- so we hack around it here
|
||||
= updateAttrMap (const dimAttrs) . withAttr "no-bindist"
|
||||
| otherwise = id
|
||||
@ -165,24 +164,23 @@ ui dimAttrs BrickState { appSettings = as@(BrickSettings {}), ..}
|
||||
active = if b then forceAttr "active" else id
|
||||
in hooray $ active $ dim
|
||||
( marks
|
||||
<+> (( padLeft (Pad 2)
|
||||
$ minHSize 6
|
||||
$ (printTool lTool)
|
||||
<+> padLeft (Pad 2)
|
||||
( minHSize 6
|
||||
(printTool lTool)
|
||||
)
|
||||
)
|
||||
<+> (minHSize 15 $ (str ver))
|
||||
<+> minHSize 15 (str ver)
|
||||
<+> (let l = catMaybes . fmap printTag $ sort lTag
|
||||
in padLeft (Pad 1) $ minHSize 25 $ if null l
|
||||
then emptyWidget
|
||||
else foldr1 (\x y -> x <+> str "," <+> y) l
|
||||
)
|
||||
<+> ( padLeft (Pad 5)
|
||||
$ let notes = printNotes listResult
|
||||
<+> padLeft (Pad 5)
|
||||
( let notes = printNotes listResult
|
||||
in if null notes
|
||||
then emptyWidget
|
||||
else foldr1 (\x y -> x <+> str "," <+> y) $ notes
|
||||
else foldr1 (\x y -> x <+> str "," <+> y) notes
|
||||
)
|
||||
<+> (vLimit 1 $ fill ' ')
|
||||
<+> vLimit 1 (fill ' ')
|
||||
)
|
||||
|
||||
printTag Recommended = Just $ withAttr "recommended" $ str "recommended"
|
||||
@ -289,7 +287,7 @@ dimAttributes no_color = attrMap
|
||||
| otherwise = Vty.withBackColor
|
||||
|
||||
eventHandler :: BrickState -> BrickEvent n e -> EventM n (Next BrickState)
|
||||
eventHandler st@(BrickState {..}) ev = do
|
||||
eventHandler st@BrickState{..} ev = do
|
||||
AppState { keyBindings = kb } <- liftIO $ readIORef settings'
|
||||
case ev of
|
||||
(MouseDown _ Vty.BScrollUp _ _) ->
|
||||
@ -298,9 +296,9 @@ eventHandler st@(BrickState {..}) ev = do
|
||||
continue (BrickState { appState = moveCursor 1 appState Down, .. })
|
||||
(VtyEvent (Vty.EvResize _ _)) -> continue st
|
||||
(VtyEvent (Vty.EvKey Vty.KUp _)) ->
|
||||
continue (BrickState { appState = (moveCursor 1 appState Up), .. })
|
||||
continue BrickState{ appState = moveCursor 1 appState Up, .. }
|
||||
(VtyEvent (Vty.EvKey Vty.KDown _)) ->
|
||||
continue (BrickState { appState = (moveCursor 1 appState Down), .. })
|
||||
continue BrickState{ appState = moveCursor 1 appState Down, .. }
|
||||
(VtyEvent (Vty.EvKey key _)) ->
|
||||
case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
|
||||
Nothing -> continue st
|
||||
@ -309,7 +307,7 @@ eventHandler st@(BrickState {..}) ev = do
|
||||
|
||||
|
||||
moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
|
||||
moveCursor steps ais@(BrickInternalState {..}) direction =
|
||||
moveCursor steps ais@BrickInternalState{..} direction =
|
||||
let newIx = if direction == Down then ix + steps else ix - steps
|
||||
in case clr !? newIx of
|
||||
Just _ -> BrickInternalState { ix = newIx, .. }
|
||||
@ -325,7 +323,7 @@ withIOAction action as = case listSelectedElement' (appState as) of
|
||||
Nothing -> continue as
|
||||
Just (ix, e) -> suspendAndResume $ do
|
||||
action as (ix, e) >>= \case
|
||||
Left err -> putStrLn $ ("Error: " <> err)
|
||||
Left err -> putStrLn ("Error: " <> err)
|
||||
Right _ -> putStrLn "Success"
|
||||
getAppData Nothing (pfreq . appData $ as) >>= \case
|
||||
Right data' -> do
|
||||
@ -339,7 +337,7 @@ withIOAction action as = case listSelectedElement' (appState as) of
|
||||
-- This synchronises @BrickInternalState@ with @BrickData@
|
||||
-- and @BrickSettings@.
|
||||
updateList :: BrickData -> BrickState -> BrickState
|
||||
updateList appD (BrickState {..}) =
|
||||
updateList appD BrickState{..} =
|
||||
let newInternalState = constructList appD appSettings (Just appState)
|
||||
in BrickState { appState = newInternalState
|
||||
, appData = appD
|
||||
@ -352,11 +350,11 @@ constructList :: BrickData
|
||||
-> BrickSettings
|
||||
-> Maybe BrickInternalState
|
||||
-> BrickInternalState
|
||||
constructList appD appSettings mapp =
|
||||
replaceLR (filterVisible (showAll appSettings)) (lr appD) mapp
|
||||
constructList appD appSettings =
|
||||
replaceLR (filterVisible (showAll appSettings)) (lr appD)
|
||||
|
||||
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
|
||||
listSelectedElement' (BrickInternalState {..}) = fmap (ix, ) $ clr !? ix
|
||||
listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
|
||||
|
||||
|
||||
selectLatest :: Vector ListResult -> Int
|
||||
@ -420,7 +418,7 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
||||
, TarDirDoesNotExist
|
||||
]
|
||||
|
||||
(run $ do
|
||||
run (do
|
||||
case lTool of
|
||||
GHC -> do
|
||||
let vi = getVersionInfo lVer GHC dls
|
||||
@ -437,7 +435,7 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure $ Right ()
|
||||
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
|
||||
@ -457,7 +455,7 @@ set' _ (_, ListResult {..}) = do
|
||||
. flip runReaderT settings
|
||||
. runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
|
||||
|
||||
(run $ do
|
||||
run (do
|
||||
case lTool of
|
||||
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
|
||||
Cabal -> liftE $ setCabal lVer $> ()
|
||||
@ -477,7 +475,7 @@ del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
|
||||
|
||||
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
||||
|
||||
(run $ do
|
||||
run (do
|
||||
let vi = getVersionInfo lVer lTool dls
|
||||
case lTool of
|
||||
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
|
||||
@ -602,6 +600,6 @@ getAppData mg pfreq' = do
|
||||
case r of
|
||||
Right dls -> do
|
||||
lV <- listVersions dls Nothing Nothing pfreq'
|
||||
pure $ Right $ (BrickData (reverse lV) dls pfreq')
|
||||
pure $ Right $ BrickData (reverse lV) dls pfreq'
|
||||
Left e -> pure $ Left [i|#{e}|]
|
||||
|
||||
|
||||
@ -276,7 +276,7 @@ opts =
|
||||
<*> com
|
||||
where
|
||||
parseUri s' =
|
||||
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
|
||||
first show $ parseURI strictURIParserOptions (UTF8.fromString s')
|
||||
|
||||
|
||||
com :: Parser Command
|
||||
@ -298,37 +298,33 @@ com =
|
||||
#endif
|
||||
"install"
|
||||
( Install
|
||||
<$> (info
|
||||
<$> info
|
||||
(installParser <**> helper)
|
||||
( progDesc "Install or update GHC/cabal"
|
||||
<> footerDoc (Just $ text installToolFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"set"
|
||||
((info
|
||||
(Set <$> setParser <**> helper)
|
||||
( progDesc "Set currently active GHC/cabal version"
|
||||
<> footerDoc (Just $ text setFooter)
|
||||
)
|
||||
)
|
||||
(info
|
||||
(Set <$> setParser <**> helper)
|
||||
( progDesc "Set currently active GHC/cabal version"
|
||||
<> footerDoc (Just $ text setFooter)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"rm"
|
||||
((info
|
||||
(Rm <$> rmParser <**> helper)
|
||||
( progDesc "Remove a GHC/cabal version"
|
||||
<> footerDoc (Just $ text rmFooter)
|
||||
)
|
||||
)
|
||||
(info
|
||||
(Rm <$> rmParser <**> helper)
|
||||
( progDesc "Remove a GHC/cabal version"
|
||||
<> footerDoc (Just $ text rmFooter)
|
||||
)
|
||||
)
|
||||
|
||||
<> command
|
||||
"list"
|
||||
((info (List <$> listOpts <**> helper)
|
||||
(progDesc "Show available GHCs and other tools")
|
||||
)
|
||||
(info (List <$> listOpts <**> helper)
|
||||
(progDesc "Show available GHCs and other tools")
|
||||
)
|
||||
<> command
|
||||
"upgrade"
|
||||
@ -343,31 +339,28 @@ com =
|
||||
<> command
|
||||
"compile"
|
||||
( Compile
|
||||
<$> (info (compileP <**> helper)
|
||||
(progDesc "Compile a tool from source")
|
||||
)
|
||||
<$> info (compileP <**> helper)
|
||||
(progDesc "Compile a tool from source")
|
||||
)
|
||||
<> commandGroup "Main commands:"
|
||||
)
|
||||
<|> subparser
|
||||
( command
|
||||
"debug-info"
|
||||
((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
|
||||
((\_ -> DInfo) <$> info helper (progDesc "Show debug info"))
|
||||
<> command
|
||||
"tool-requirements"
|
||||
( (\_ -> ToolRequirements)
|
||||
<$> (info (helper)
|
||||
(progDesc "Show the requirements for ghc/cabal")
|
||||
)
|
||||
<$> info helper
|
||||
(progDesc "Show the requirements for ghc/cabal")
|
||||
)
|
||||
<> command
|
||||
"changelog"
|
||||
((info
|
||||
(info
|
||||
(fmap ChangeLog changelogP <**> helper)
|
||||
( progDesc "Find/show changelog"
|
||||
<> footerDoc (Just $ text changeLogFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
<> commandGroup "Other commands:"
|
||||
<> hidden
|
||||
@ -375,12 +368,11 @@ com =
|
||||
<|> subparser
|
||||
( command
|
||||
"install-cabal"
|
||||
((info
|
||||
(info
|
||||
((InstallCabalLegacy <$> installOpts (Just Cabal)) <**> helper)
|
||||
( progDesc "Install or update cabal"
|
||||
<> footerDoc (Just $ text installCabalFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
<> internal
|
||||
)
|
||||
@ -425,32 +417,29 @@ installParser =
|
||||
( command
|
||||
"ghc"
|
||||
( InstallGHC
|
||||
<$> (info
|
||||
<$> info
|
||||
(installOpts (Just GHC) <**> helper)
|
||||
( progDesc "Install GHC"
|
||||
<> footerDoc (Just $ text installGHCFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"cabal"
|
||||
( InstallCabal
|
||||
<$> (info
|
||||
<$> info
|
||||
(installOpts (Just Cabal) <**> helper)
|
||||
( progDesc "Install Cabal"
|
||||
<> footerDoc (Just $ text installCabalFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"hls"
|
||||
( InstallHLS
|
||||
<$> (info
|
||||
<$> info
|
||||
(installOpts (Just HLS) <**> helper)
|
||||
( progDesc "Install haskell-languge-server"
|
||||
<> footerDoc (Just $ text installHLSFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
@ -488,7 +477,7 @@ Examples:
|
||||
installOpts :: Maybe Tool -> Parser InstallOptions
|
||||
installOpts tool =
|
||||
(\p (u, v) b -> InstallOptions v p u b)
|
||||
<$> (optional
|
||||
<$> optional
|
||||
(option
|
||||
(eitherReader platformParser)
|
||||
( short 'p'
|
||||
@ -498,19 +487,17 @@ installOpts tool =
|
||||
"Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> ( ( (,)
|
||||
<$> (optional
|
||||
<$> optional
|
||||
(option
|
||||
(eitherReader bindistParser)
|
||||
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
|
||||
"Install the specified version from this bindist"
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> (Just <$> toolVersionArgument Nothing tool)
|
||||
)
|
||||
<|> (pure (Nothing, Nothing))
|
||||
<|> pure (Nothing, Nothing)
|
||||
)
|
||||
<*> flag
|
||||
False
|
||||
@ -526,32 +513,29 @@ setParser =
|
||||
( command
|
||||
"ghc"
|
||||
( SetGHC
|
||||
<$> (info
|
||||
<$> info
|
||||
(setOpts (Just GHC) <**> helper)
|
||||
( progDesc "Set GHC version"
|
||||
<> footerDoc (Just $ text setGHCFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"cabal"
|
||||
( SetCabal
|
||||
<$> (info
|
||||
<$> info
|
||||
(setOpts (Just Cabal) <**> helper)
|
||||
( progDesc "Set Cabal version"
|
||||
<> footerDoc (Just $ text setCabalFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"hls"
|
||||
( SetHLS
|
||||
<$> (info
|
||||
<$> info
|
||||
(setOpts (Just HLS) <**> helper)
|
||||
( progDesc "Set haskell-language-server version"
|
||||
<> footerDoc (Just $ text setHLSFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
@ -587,7 +571,7 @@ listOpts =
|
||||
"Tool to list versions for. Default is all"
|
||||
)
|
||||
)
|
||||
<*> (optional
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader criteriaParser)
|
||||
( short 'c'
|
||||
@ -596,7 +580,6 @@ listOpts =
|
||||
<> help "Show only installed or set tool versions"
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> switch
|
||||
(short 'r' <> long "raw-format" <> help "More machine-parsable format"
|
||||
)
|
||||
@ -607,20 +590,18 @@ rmParser =
|
||||
(Left <$> subparser
|
||||
( command
|
||||
"ghc"
|
||||
(RmGHC <$> (info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version")))
|
||||
(RmGHC <$> info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version"))
|
||||
<> command
|
||||
"cabal"
|
||||
( RmCabal
|
||||
<$> (info (versionParser' (Just ListInstalled) (Just Cabal) <**> helper)
|
||||
(progDesc "Remove Cabal version")
|
||||
)
|
||||
<$> info (versionParser' (Just ListInstalled) (Just Cabal) <**> helper)
|
||||
(progDesc "Remove Cabal version")
|
||||
)
|
||||
<> command
|
||||
"hls"
|
||||
( RmHLS
|
||||
<$> (info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
|
||||
(progDesc "Remove haskell-language-server version")
|
||||
)
|
||||
<$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
|
||||
(progDesc "Remove haskell-language-server version")
|
||||
)
|
||||
)
|
||||
)
|
||||
@ -636,21 +617,20 @@ changelogP :: Parser ChangeLogOptions
|
||||
changelogP =
|
||||
(\x y -> ChangeLogOptions x y)
|
||||
<$> switch (short 'o' <> long "open" <> help "xdg-open the changelog url")
|
||||
<*> (optional
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader
|
||||
(\s' -> case fmap toLower s' of
|
||||
"ghc" -> Right GHC
|
||||
"cabal" -> Right Cabal
|
||||
"ghcup" -> Right GHCup
|
||||
e -> Left $ e
|
||||
e -> Left e
|
||||
)
|
||||
)
|
||||
(short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help
|
||||
"Open changelog for given tool (default: ghc)"
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> optional (toolVersionArgument Nothing Nothing)
|
||||
|
||||
compileP :: Parser CompileCommand
|
||||
@ -658,12 +638,11 @@ compileP = subparser
|
||||
( command
|
||||
"ghc"
|
||||
( CompileGHC
|
||||
<$> (info
|
||||
<$> info
|
||||
(ghcCompileOpts <**> helper)
|
||||
( progDesc "Compile GHC from source"
|
||||
<> footerDoc (Just $ text compileFooter)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
where
|
||||
@ -692,14 +671,13 @@ ghcCompileOpts =
|
||||
(\CabalCompileOptions {..} crossTarget addConfArgs setCompile -> GHCCompileOptions { .. }
|
||||
)
|
||||
<$> cabalCompileOpts
|
||||
<*> (optional
|
||||
<*> optional
|
||||
(option
|
||||
str
|
||||
(short 'x' <> long "cross-target" <> metavar "CROSS_TARGET" <> help
|
||||
"Build cross-compiler for this platform"
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
|
||||
<*> flag
|
||||
False
|
||||
@ -711,15 +689,14 @@ ghcCompileOpts =
|
||||
cabalCompileOpts :: Parser CabalCompileOptions
|
||||
cabalCompileOpts =
|
||||
CabalCompileOptions
|
||||
<$> (option
|
||||
<$> option
|
||||
(eitherReader
|
||||
(bimap (const "Not a valid version") id . version . T.pack)
|
||||
(first (const "Not a valid version") . version . T.pack)
|
||||
)
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help
|
||||
"The tool version to compile"
|
||||
)
|
||||
)
|
||||
<*> (option
|
||||
<*> option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
(bimap (const "Not a valid version") Left . version . T.pack $ x)
|
||||
@ -732,7 +709,6 @@ cabalCompileOpts =
|
||||
<> help
|
||||
"The GHC version (or full path) to bootstrap with (must be installed)"
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader (readEither @Int))
|
||||
@ -744,7 +720,7 @@ cabalCompileOpts =
|
||||
(option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
@ -757,7 +733,7 @@ cabalCompileOpts =
|
||||
(option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
@ -774,10 +750,9 @@ toolVersionParser = verP' <|> toolP
|
||||
verP' = ToolVersion <$> versionParser
|
||||
toolP =
|
||||
ToolTag
|
||||
<$> (option
|
||||
<$> option
|
||||
(eitherReader tagEither)
|
||||
(short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
|
||||
)
|
||||
|
||||
-- | same as toolVersionParser, except as an argument.
|
||||
toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
|
||||
@ -797,8 +772,8 @@ setVersionArgument criteria tool =
|
||||
where
|
||||
setEither s' =
|
||||
parseSet s'
|
||||
<|> bimap id SetToolTag (tagEither s')
|
||||
<|> bimap id SetToolVersion (tVersionEither s')
|
||||
<|> second SetToolTag (tagEither s')
|
||||
<|> second SetToolVersion (tVersionEither s')
|
||||
parseSet s' = case fmap toLower s' of
|
||||
"next" -> Right SetNext
|
||||
other -> Left [i|Unknown tag/version #{other}|]
|
||||
@ -884,12 +859,12 @@ tagEither s' = case fmap toLower s' of
|
||||
|
||||
tVersionEither :: String -> Either String GHCTargetVersion
|
||||
tVersionEither =
|
||||
bimap (const "Not a valid version") id . MP.parse ghcTargetVerP "" . T.pack
|
||||
first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack
|
||||
|
||||
|
||||
toolVersionEither :: String -> Either String ToolVersion
|
||||
toolVersionEither s' =
|
||||
bimap id ToolTag (tagEither s') <|> bimap id ToolVersion (tVersionEither s')
|
||||
second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s')
|
||||
|
||||
|
||||
toolParser :: String -> Either String Tool
|
||||
@ -930,7 +905,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
|
||||
Left e -> Left $ errorBundlePretty e
|
||||
where
|
||||
archP :: MP.Parsec Void Text Architecture
|
||||
archP = (MP.try (MP.chunk "x86_64" $> A_64)) <|> (MP.chunk "i386" $> A_32)
|
||||
archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32)
|
||||
platformP :: MP.Parsec Void Text PlatformRequest
|
||||
platformP = choice'
|
||||
[ (\a mv -> PlatformRequest a FreeBSD mv)
|
||||
@ -990,7 +965,7 @@ toSettings options = do
|
||||
pure $ mergeConf options dirs userConf
|
||||
where
|
||||
mergeConf :: Options -> Dirs -> UserSettings -> AppState
|
||||
mergeConf (Options {..}) dirs (UserSettings {..}) =
|
||||
mergeConf Options{..} dirs UserSettings{..} =
|
||||
let cache = fromMaybe (fromMaybe False uCache) optCache
|
||||
noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify
|
||||
verbose = fromMaybe (fromMaybe False uVerbose) optVerbose
|
||||
@ -1027,10 +1002,10 @@ upgradeOptsP =
|
||||
"Upgrade ghcup in-place (wherever it's at)"
|
||||
)
|
||||
<|> ( UpgradeAt
|
||||
<$> (option
|
||||
<$> option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
@ -1038,14 +1013,13 @@ upgradeOptsP =
|
||||
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
|
||||
"Absolute filepath to write ghcup into"
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (pure UpgradeGHCupDir)
|
||||
<|> pure UpgradeGHCupDir
|
||||
|
||||
|
||||
|
||||
describe_result :: String
|
||||
describe_result = $( (LitE . StringL) <$>
|
||||
describe_result = $( LitE . StringL <$>
|
||||
runIO (do
|
||||
CapturedProcess{..} <- executeOut [rel|git|] ["describe"] Nothing
|
||||
case _exitCode of
|
||||
@ -1059,7 +1033,7 @@ main :: IO ()
|
||||
main = do
|
||||
let versionHelp = infoOption
|
||||
( ("The GHCup Haskell installer, version " <>)
|
||||
$ (head . lines $ describe_result)
|
||||
(head . lines $ describe_result)
|
||||
)
|
||||
(long "version" <> help "Show version" <> hidden)
|
||||
let numericVersionHelp = infoOption
|
||||
@ -1273,8 +1247,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ $(logInfo) ("GHC installation successful")
|
||||
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
|
||||
runLogger $ $(logInfo) "GHC installation successful"
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
@ -1311,8 +1285,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ $(logInfo) ("Cabal installation successful")
|
||||
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
|
||||
runLogger $ $(logInfo) "Cabal installation successful"
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
@ -1341,8 +1315,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ $(logInfo) ("HLS installation successful")
|
||||
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
|
||||
runLogger $ $(logInfo) "HLS installation successful"
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
@ -1357,12 +1331,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
|
||||
|
||||
let setGHC' SetOptions{..} =
|
||||
(runSetGHC $ do
|
||||
runSetGHC (do
|
||||
v <- liftE $ fst <$> fromVersion' dls sToolVer GHC
|
||||
liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
>>= \case
|
||||
VRight (GHCTargetVersion{..}) -> do
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
$ $(logInfo)
|
||||
[i|GHC #{prettyVer _tvVersion} successfully set as default version#{maybe "" (" for cross target " <>) _tvTarget}|]
|
||||
@ -1372,13 +1346,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
pure $ ExitFailure 5
|
||||
|
||||
let setCabal' SetOptions{..} =
|
||||
(runSetCabal $ do
|
||||
runSetCabal (do
|
||||
v <- liftE $ fst <$> fromVersion' dls sToolVer Cabal
|
||||
liftE $ setCabal (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
>>= \case
|
||||
VRight (GHCTargetVersion{..}) -> do
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
$ $(logInfo)
|
||||
[i|Cabal #{prettyVer _tvVersion} successfully set as default version|]
|
||||
@ -1388,13 +1362,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
pure $ ExitFailure 14
|
||||
|
||||
let setHLS' SetOptions{..} =
|
||||
(runSetHLS $ do
|
||||
runSetHLS (do
|
||||
v <- liftE $ fst <$> fromVersion' dls sToolVer HLS
|
||||
liftE $ setHLS (_tvVersion v)
|
||||
pure v
|
||||
)
|
||||
>>= \case
|
||||
VRight (GHCTargetVersion{..}) -> do
|
||||
VRight GHCTargetVersion{..} -> do
|
||||
runLogger
|
||||
$ $(logInfo)
|
||||
[i|HLS #{prettyVer _tvVersion} successfully set as default version|]
|
||||
@ -1404,14 +1378,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
pure $ ExitFailure 14
|
||||
|
||||
let rmGHC' RmOptions{..} =
|
||||
(runRm $ do
|
||||
runRm (do
|
||||
liftE $
|
||||
rmGHCVer ghcVer
|
||||
pure (getVersionInfo (_tvVersion ghcVer) GHC dls)
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
|
||||
forM_ (_viPostRemove =<< vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
@ -1419,14 +1393,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
pure $ ExitFailure 7
|
||||
|
||||
let rmCabal' tv =
|
||||
(runRm $ do
|
||||
runRm (do
|
||||
liftE $
|
||||
rmCabalVer tv
|
||||
pure (getVersionInfo tv Cabal dls)
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
|
||||
forM_ (_viPostRemove =<< vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
@ -1434,14 +1408,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
pure $ ExitFailure 15
|
||||
|
||||
let rmHLS' tv =
|
||||
(runRm $ do
|
||||
runRm (do
|
||||
liftE $
|
||||
rmHLSVer tv
|
||||
pure (getVersionInfo tv HLS dls)
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
|
||||
forM_ (_viPostRemove =<< vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft e -> do
|
||||
@ -1470,8 +1444,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
Set (Left (SetCabal sopts)) -> setCabal' sopts
|
||||
Set (Left (SetHLS sopts)) -> setHLS' sopts
|
||||
|
||||
List (ListOptions {..}) ->
|
||||
(runListGHC $ do
|
||||
List ListOptions {..} ->
|
||||
runListGHC (do
|
||||
l <- listVersions dls lTool lCriteria pfreq
|
||||
liftIO $ printListResult lRawFormat l
|
||||
pure ExitSuccess
|
||||
@ -1485,8 +1459,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
Rm (Left (RmHLS rmopts)) -> rmHLS' rmopts
|
||||
|
||||
DInfo ->
|
||||
do
|
||||
(runDebugInfo $ liftE $ getDebugInfo)
|
||||
do runDebugInfo $ liftE getDebugInfo
|
||||
>>= \case
|
||||
VRight dinfo -> do
|
||||
putStrLn $ prettyDebugInfo dinfo
|
||||
@ -1496,12 +1469,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
pure $ ExitFailure 8
|
||||
|
||||
Compile (CompileGHC GHCCompileOptions {..}) ->
|
||||
(runCompileGHC $ do
|
||||
runCompileGHC (do
|
||||
let vi = getVersionInfo targetVer GHC dls
|
||||
forM_ (join $ fmap _viPreCompile vi) $ \msg -> do
|
||||
forM_ (_viPreCompile =<< vi) $ \msg -> do
|
||||
lift $ $(logInfo) msg
|
||||
lift $ $(logInfo)
|
||||
("...waiting for 5 seconds, you can still abort...")
|
||||
"...waiting for 5 seconds, you can still abort..."
|
||||
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
|
||||
liftE $ compileGHC dls
|
||||
(GHCTargetVersion crossTarget targetVer)
|
||||
@ -1518,8 +1491,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
runLogger $ $(logInfo)
|
||||
("GHC successfully compiled and installed")
|
||||
forM_ (join $ fmap _viPostInstall vi) $ \msg ->
|
||||
"GHC successfully compiled and installed"
|
||||
forM_ (_viPostInstall =<< vi) $ \msg ->
|
||||
runLogger $ $(logInfo) msg
|
||||
pure ExitSuccess
|
||||
VLeft (V (AlreadyInstalled _ v)) -> do
|
||||
@ -1537,16 +1510,16 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 9
|
||||
|
||||
Upgrade (uOpts) force -> do
|
||||
Upgrade uOpts force -> do
|
||||
target <- case uOpts of
|
||||
UpgradeInplace -> do
|
||||
efp <- liftIO $ getExecutablePath
|
||||
efp <- liftIO getExecutablePath
|
||||
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
|
||||
pure $ Just p
|
||||
(UpgradeAt p) -> pure $ Just p
|
||||
UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
|
||||
|
||||
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
|
||||
runUpgrade (liftE $ upgradeGHCup dls target force pfreq) >>= \case
|
||||
VRight v' -> do
|
||||
let pretty_v = prettyVer v'
|
||||
let vi = fromJust $ snd <$> getLatest dls GHCup
|
||||
@ -1563,14 +1536,12 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
pure $ ExitFailure 11
|
||||
|
||||
ToolRequirements ->
|
||||
( runLogger
|
||||
$ runE
|
||||
runLogger
|
||||
(runE
|
||||
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
|
||||
$ do
|
||||
platform <- liftE $ getPlatform
|
||||
req <-
|
||||
(getCommonRequirements platform $ treq)
|
||||
?? NoToolRequirements
|
||||
platform <- liftE getPlatform
|
||||
req <- getCommonRequirements platform treq ?? NoToolRequirements
|
||||
liftIO $ T.hPutStr stdout (prettyRequirements req)
|
||||
)
|
||||
>>= \case
|
||||
@ -1579,7 +1550,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 12
|
||||
|
||||
ChangeLog (ChangeLogOptions {..}) -> do
|
||||
ChangeLog ChangeLogOptions{..} -> do
|
||||
let tool = fromMaybe GHC clTool
|
||||
ver' = maybe
|
||||
(Right Latest)
|
||||
@ -1626,7 +1597,7 @@ fromVersion :: (MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, Mo
|
||||
-> Maybe ToolVersion
|
||||
-> Tool
|
||||
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
fromVersion av tv tool = fromVersion' av (toSetToolVer tv) tool
|
||||
fromVersion av tv = fromVersion' av (toSetToolVer tv)
|
||||
|
||||
fromVersion' :: (MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
|
||||
=> GHCupDownloads
|
||||
@ -1880,7 +1851,7 @@ checkForUpdates dls pfreq = do
|
||||
|
||||
where
|
||||
latestInstalled tool = (fmap lVer . lastMay)
|
||||
<$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
|
||||
<$> listVersions dls (Just tool) (Just ListInstalled) pfreq
|
||||
|
||||
|
||||
prettyDebugInfo :: DebugInfo -> String
|
||||
|
||||
@ -9,6 +9,8 @@ package streamly
|
||||
|
||||
package ghcup
|
||||
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
|
||||
tests: True
|
||||
flags: +tui
|
||||
|
||||
constraints: http-io-streams -brotli
|
||||
|
||||
|
||||
@ -52,7 +52,7 @@ common async
|
||||
build-depends: async >=0.8
|
||||
|
||||
common base
|
||||
build-depends: base >=4.12 && <5
|
||||
build-depends: base >=4.13 && <5
|
||||
|
||||
common base16-bytestring
|
||||
build-depends: base16-bytestring >= 0.1.1.6
|
||||
|
||||
25
hie.yaml
25
hie.yaml
@ -1,19 +1,10 @@
|
||||
cradle:
|
||||
cabal:
|
||||
- path: "./lib"
|
||||
component: "lib:ghcup"
|
||||
|
||||
- path: "./app/ghcup/Main.hs"
|
||||
component: "ghcup:exe:ghcup"
|
||||
|
||||
- path: "./app/ghcup/BrickMain.hs"
|
||||
component: "ghcup:exe:ghcup"
|
||||
|
||||
- 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"
|
||||
- component: "ghcup:lib:ghcup"
|
||||
path: ./lib
|
||||
- component: "ghcup:exe:ghcup"
|
||||
path: ./app/ghcup
|
||||
- component: "ghcup:exe:ghcup-gen"
|
||||
path: "./app/ghcup-gen"
|
||||
- component: "ghcup:test:ghcup-test"
|
||||
path: ./test
|
||||
|
||||
111
lib/GHCup.hs
111
lib/GHCup.hs
@ -123,10 +123,9 @@ installGHCBindist :: ( MonadFail m
|
||||
m
|
||||
()
|
||||
installGHCBindist dlinfo ver pfreq = do
|
||||
let tver = (mkTVer ver)
|
||||
let tver = mkTVer ver
|
||||
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
|
||||
whenM (lift $ ghcInstalled tver)
|
||||
$ (throwE $ AlreadyInstalled GHC ver)
|
||||
whenM (lift $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC ver)
|
||||
|
||||
-- download (or use cached version)
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
@ -173,7 +172,7 @@ installPackedGHC :: ( MonadMask m
|
||||
, ArchiveResult
|
||||
#endif
|
||||
] m ()
|
||||
installPackedGHC dl msubdir inst ver pfreq@(PlatformRequest {..}) = do
|
||||
installPackedGHC dl msubdir inst ver pfreq@PlatformRequest{..} = do
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
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
|
||||
workdir <- maybe (pure tmpUnpack)
|
||||
(liftE . intoSubdir tmpUnpack)
|
||||
(msubdir)
|
||||
msubdir
|
||||
|
||||
liftE $ runBuildAction tmpUnpack
|
||||
(Just inst)
|
||||
@ -201,11 +200,11 @@ installUnpackedGHC :: ( MonadReader AppState m
|
||||
-> Version -- ^ The GHC version
|
||||
-> PlatformRequest
|
||||
-> Excepts '[ProcessError] m ()
|
||||
installUnpackedGHC path inst ver (PlatformRequest {..}) = do
|
||||
installUnpackedGHC path inst ver PlatformRequest{..} = do
|
||||
lift $ $(logInfo) "Installing GHC (this may take a while)"
|
||||
lEM $ execLogged "./configure"
|
||||
False
|
||||
(["--prefix=" <> toFilePath inst] ++ alpineArgs)
|
||||
(("--prefix=" <> toFilePath inst) : alpineArgs)
|
||||
[rel|ghc-configure|]
|
||||
(Just path)
|
||||
Nothing
|
||||
@ -283,7 +282,7 @@ installCabalBindist :: ( MonadMask m
|
||||
]
|
||||
m
|
||||
()
|
||||
installCabalBindist dlinfo ver (PlatformRequest {..}) = do
|
||||
installCabalBindist dlinfo ver PlatformRequest {..} = do
|
||||
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
|
||||
|
||||
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)
|
||||
$ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|]))
|
||||
)
|
||||
$ (throwE $ AlreadyInstalled Cabal ver)
|
||||
(throwE $ AlreadyInstalled Cabal ver)
|
||||
|
||||
-- download (or use cached version)
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
@ -311,12 +310,10 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
|
||||
liftE $ installCabal' workdir binDir
|
||||
|
||||
-- create symlink if this is the latest version
|
||||
cVers <- lift $ fmap rights $ getInstalledCabals
|
||||
cVers <- lift $ fmap rights getInstalledCabals
|
||||
let lInstCabal = headMay . reverse . sort $ cVers
|
||||
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
|
||||
|
||||
pure ()
|
||||
|
||||
where
|
||||
-- | Install an unpacked cabal distribution.
|
||||
installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
@ -331,7 +328,7 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
|
||||
let destPath = inst </> destFileName
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> cabalFile)
|
||||
(destPath)
|
||||
destPath
|
||||
Overwrite
|
||||
lift $ chmod_755 destPath
|
||||
|
||||
@ -398,13 +395,13 @@ installHLSBindist :: ( MonadMask m
|
||||
]
|
||||
m
|
||||
()
|
||||
installHLSBindist dlinfo ver (PlatformRequest {..}) = do
|
||||
installHLSBindist dlinfo ver PlatformRequest{..} = do
|
||||
lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
|
||||
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
whenM (lift (hlsInstalled ver))
|
||||
$ (throwE $ AlreadyInstalled HLS ver)
|
||||
(throwE $ AlreadyInstalled HLS ver)
|
||||
|
||||
-- download (or use cached version)
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
@ -420,12 +417,10 @@ installHLSBindist dlinfo ver (PlatformRequest {..}) = do
|
||||
liftE $ installHLS' workdir binDir
|
||||
|
||||
-- create symlink if this is the latest version
|
||||
hlsVers <- lift $ fmap rights $ getInstalledHLSs
|
||||
hlsVers <- lift $ fmap rights getInstalledHLSs
|
||||
let lInstHLS = headMay . reverse . sort $ hlsVers
|
||||
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
|
||||
|
||||
pure ()
|
||||
|
||||
where
|
||||
-- | Install an unpacked hls distribution.
|
||||
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
|
||||
@ -525,7 +520,7 @@ setGHC ver sghc = do
|
||||
let verBS = verToBS (_tvVersion 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
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
@ -603,7 +598,7 @@ setCabal ver = do
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
liftIO $ createDirRecursive' binDir
|
||||
|
||||
whenM (liftIO $ fmap not $ doesFileExist (binDir </> targetFile))
|
||||
whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
|
||||
$ throwE
|
||||
$ NotInstalled Cabal (GHCTargetVersion Nothing ver)
|
||||
|
||||
@ -647,7 +642,7 @@ setHLS ver = do
|
||||
|
||||
-- set haskell-language-server-<ghcver> symlinks
|
||||
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
|
||||
let destL = toFilePath f
|
||||
@ -705,7 +700,7 @@ data ListResult = ListResult
|
||||
-- | Extract all available tool versions and their tags.
|
||||
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag]
|
||||
availableToolVersions av tool = view
|
||||
(at tool % non Map.empty % to (fmap (_viTags)))
|
||||
(at tool % non Map.empty % to (fmap _viTags))
|
||||
av
|
||||
|
||||
|
||||
@ -733,13 +728,13 @@ listVersions av lt criteria pfreq = do
|
||||
case t of
|
||||
GHC -> do
|
||||
slr <- strayGHCs avTools
|
||||
pure $ (sort (slr ++ lr))
|
||||
pure (sort (slr ++ lr))
|
||||
Cabal -> do
|
||||
slr <- strayCabals avTools
|
||||
pure $ (sort (slr ++ lr))
|
||||
pure (sort (slr ++ lr))
|
||||
HLS -> do
|
||||
slr <- strayHLS avTools
|
||||
pure $ (sort (slr ++ lr))
|
||||
pure (sort (slr ++ lr))
|
||||
GHCup -> pure lr
|
||||
Nothing -> do
|
||||
ghcvers <- listVersions av (Just GHC) criteria pfreq
|
||||
@ -761,21 +756,21 @@ listVersions av lt criteria pfreq = do
|
||||
Nothing -> do
|
||||
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
|
||||
fromSrc <- ghcSrcInstalled tver
|
||||
hlsPowered <- fmap (elem _tvVersion) $ hlsGHCVersions
|
||||
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = GHC
|
||||
, lVer = _tvVersion
|
||||
, lCross = Nothing
|
||||
, lTag = []
|
||||
, lInstalled = True
|
||||
, lStray = maybe True (const False) (Map.lookup _tvVersion avTools)
|
||||
, lStray = isNothing (Map.lookup _tvVersion avTools)
|
||||
, lNoBindist = False
|
||||
, ..
|
||||
}
|
||||
Right tver@GHCTargetVersion{ .. } -> do
|
||||
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
|
||||
fromSrc <- ghcSrcInstalled tver
|
||||
hlsPowered <- fmap (elem _tvVersion) $ hlsGHCVersions
|
||||
hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = GHC
|
||||
, lVer = _tvVersion
|
||||
@ -801,14 +796,14 @@ listVersions av lt criteria pfreq = do
|
||||
case Map.lookup ver avTools of
|
||||
Just _ -> pure Nothing
|
||||
Nothing -> do
|
||||
lSet <- fmap (maybe False (== ver)) $ cabalSet
|
||||
lSet <- fmap (== Just ver) cabalSet
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = Cabal
|
||||
, lVer = ver
|
||||
, lCross = Nothing
|
||||
, lTag = []
|
||||
, lInstalled = True
|
||||
, lStray = maybe True (const False) (Map.lookup ver avTools)
|
||||
, lStray = isNothing (Map.lookup ver avTools)
|
||||
, lNoBindist = False
|
||||
, fromSrc = False -- actually, we don't know :>
|
||||
, hlsPowered = False
|
||||
@ -829,14 +824,14 @@ listVersions av lt criteria pfreq = do
|
||||
case Map.lookup ver avTools of
|
||||
Just _ -> pure Nothing
|
||||
Nothing -> do
|
||||
lSet <- fmap (maybe False (== ver)) $ hlsSet
|
||||
lSet <- fmap (== Just ver) hlsSet
|
||||
pure $ Just $ ListResult
|
||||
{ lTool = HLS
|
||||
, lVer = ver
|
||||
, lCross = Nothing
|
||||
, lTag = []
|
||||
, lInstalled = True
|
||||
, lStray = maybe True (const False) (Map.lookup ver avTools)
|
||||
, lStray = isNothing (Map.lookup ver avTools)
|
||||
, lNoBindist = False
|
||||
, fromSrc = False -- actually, we don't know :>
|
||||
, hlsPowered = False
|
||||
@ -856,11 +851,11 @@ listVersions av lt criteria pfreq = do
|
||||
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
|
||||
lInstalled <- ghcInstalled tver
|
||||
fromSrc <- ghcSrcInstalled tver
|
||||
hlsPowered <- fmap (elem v) $ hlsGHCVersions
|
||||
hlsPowered <- fmap (elem v) hlsGHCVersions
|
||||
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
|
||||
Cabal -> do
|
||||
let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq av
|
||||
lSet <- fmap (maybe False (== v)) $ cabalSet
|
||||
lSet <- fmap (== Just v) cabalSet
|
||||
lInstalled <- cabalInstalled v
|
||||
pure ListResult { lVer = v
|
||||
, lCross = Nothing
|
||||
@ -886,7 +881,7 @@ listVersions av lt criteria pfreq = do
|
||||
}
|
||||
HLS -> do
|
||||
let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq av
|
||||
lSet <- fmap (maybe False (== v)) $ hlsSet
|
||||
lSet <- fmap (== Just v) hlsSet
|
||||
lInstalled <- hlsInstalled v
|
||||
pure ListResult { lVer = v
|
||||
, lCross = Nothing
|
||||
@ -927,7 +922,7 @@ rmGHCVer :: ( MonadReader AppState m
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
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))
|
||||
dir <- lift $ ghcupGHCDir ver
|
||||
@ -960,8 +955,7 @@ rmGHCVer ver = do
|
||||
|
||||
liftIO
|
||||
$ hideError doesNotExistErrorType
|
||||
$ deleteFile
|
||||
$ (baseDir </> [rel|share|])
|
||||
$ deleteFile (baseDir </> [rel|share|])
|
||||
|
||||
|
||||
-- | 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
|
||||
whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver))
|
||||
|
||||
cSet <- lift $ cabalSet
|
||||
cSet <- lift cabalSet
|
||||
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile)
|
||||
|
||||
when (maybe False (== ver) cSet) $ do
|
||||
cVers <- lift $ fmap rights $ getInstalledCabals
|
||||
when (Just ver == cSet) $ do
|
||||
cVers <- lift $ fmap rights getInstalledCabals
|
||||
case headMay . reverse . sort $ cVers of
|
||||
Just latestver -> setCabal latestver
|
||||
Nothing -> liftIO $ hideError doesNotExistErrorType $ deleteFile
|
||||
@ -995,21 +989,21 @@ rmHLSVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, Mon
|
||||
rmHLSVer ver = do
|
||||
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))
|
||||
|
||||
isHlsSet <- lift $ hlsSet
|
||||
isHlsSet <- lift hlsSet
|
||||
|
||||
AppState {dirs = Dirs {..}} <- lift ask
|
||||
|
||||
bins <- lift $ hlsAllBinaries ver
|
||||
forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f)
|
||||
|
||||
when (maybe False (== ver) isHlsSet) $ do
|
||||
when (Just ver == isHlsSet) $ do
|
||||
-- delete all set symlinks
|
||||
oldSyms <- lift hlsSymlinks
|
||||
forM_ oldSyms $ \f -> do
|
||||
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
|
||||
liftIO $ deleteFile (binDir </> f)
|
||||
-- set latest hls
|
||||
hlsVers <- lift $ fmap rights $ getInstalledHLSs
|
||||
hlsVers <- lift $ fmap rights getInstalledHLSs
|
||||
case headMay . reverse . sort $ hlsVers of
|
||||
Just latestver -> setHLS latestver
|
||||
Nothing -> pure ()
|
||||
@ -1034,7 +1028,7 @@ getDebugInfo = do
|
||||
diGHCDir <- lift ghcupGHCBaseDir
|
||||
let diCacheDir = cacheDir
|
||||
diArch <- lE getArchitecture
|
||||
diPlatform <- liftE $ getPlatform
|
||||
diPlatform <- liftE getPlatform
|
||||
pure $ DebugInfo { .. }
|
||||
|
||||
|
||||
@ -1081,12 +1075,12 @@ compileGHC :: ( MonadMask m
|
||||
]
|
||||
m
|
||||
()
|
||||
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@(PlatformRequest {..})
|
||||
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformRequest{..}
|
||||
= do
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
|
||||
|
||||
alreadyInstalled <- lift $ ghcInstalled tver
|
||||
alreadySet <- fmap (maybe False (==tver)) $ lift $ ghcSet (_tvTarget tver)
|
||||
alreadySet <- fmap (== Just tver) $ lift $ ghcSet (_tvTarget tver)
|
||||
|
||||
-- download source tarball
|
||||
dlInfo <-
|
||||
@ -1131,7 +1125,6 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@(PlatformReque
|
||||
|
||||
-- restore
|
||||
when alreadySet $ liftE $ void $ setGHC tver SetGHCOnly
|
||||
pure ()
|
||||
|
||||
where
|
||||
defaultConf = case _tvTarget tver of
|
||||
@ -1165,29 +1158,28 @@ Stage1Only = YES|]
|
||||
(Path Abs) -- ^ output path of bindist
|
||||
compileBindist bghc ghcdir workdir = do
|
||||
lift $ $(logInfo) [i|configuring build|]
|
||||
liftE $ checkBuildConfig
|
||||
liftE checkBuildConfig
|
||||
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
|
||||
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
|
||||
|
||||
cEnv <- liftIO $ getEnvironment
|
||||
cEnv <- liftIO getEnvironment
|
||||
|
||||
if
|
||||
| (_tvVersion tver) >= [vver|8.8.0|] -> do
|
||||
| _tvVersion tver >= [vver|8.8.0|] -> do
|
||||
bghcPath <- case bghc of
|
||||
Right ghc' -> pure ghc'
|
||||
Left bver -> do
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
(liftIO $ searchPath spaths bver) !? NotFoundInPATH bver
|
||||
liftIO (searchPath spaths bver) !? NotFoundInPATH bver
|
||||
lEM $ execLogged
|
||||
"./configure"
|
||||
False
|
||||
( ["--prefix=" <> toFilePath ghcdir]
|
||||
++ (maybe mempty
|
||||
++ maybe mempty
|
||||
(\x -> ["--target=" <> E.encodeUtf8 x])
|
||||
(_tvTarget tver)
|
||||
)
|
||||
++ fmap E.encodeUtf8 aargs
|
||||
)
|
||||
[rel|ghc-conf|]
|
||||
@ -1200,10 +1192,9 @@ Stage1Only = YES|]
|
||||
( [ "--prefix=" <> toFilePath ghcdir
|
||||
, "--with-ghc=" <> either toFilePath toFilePath bghc
|
||||
]
|
||||
++ (maybe mempty
|
||||
(\x -> ["--target=" <> E.encodeUtf8 x])
|
||||
(_tvTarget tver)
|
||||
)
|
||||
++ maybe mempty
|
||||
(\x -> ["--target=" <> E.encodeUtf8 x])
|
||||
(_tvTarget tver)
|
||||
++ fmap E.encodeUtf8 aargs
|
||||
)
|
||||
[rel|ghc-conf|]
|
||||
@ -1267,7 +1258,7 @@ Stage1Only = YES|]
|
||||
|
||||
-- for cross, we need Stage1Only
|
||||
case _tvTarget tver of
|
||||
Just _ -> when (not $ elem "Stage1Only = YES" lines') $ throwE
|
||||
Just _ -> when ("Stage1Only = YES" `notElem` lines') $ throwE
|
||||
(InvalidBuildConfig
|
||||
[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
|
||||
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.|]
|
||||
liftIO (isShadowed destFile) >>= \case
|
||||
Nothing -> pure ()
|
||||
|
||||
@ -127,7 +127,7 @@ getDownloadsF urlSource = do
|
||||
GHCupURL -> liftE getBase
|
||||
(OwnSource url) -> do
|
||||
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
|
||||
(AddSource (Left ext)) -> do
|
||||
base <- liftE getBase
|
||||
@ -135,7 +135,7 @@ getDownloadsF urlSource = do
|
||||
(AddSource (Right uri)) -> do
|
||||
base <- liftE getBase
|
||||
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)
|
||||
|
||||
where
|
||||
@ -164,7 +164,7 @@ readFromCache = do
|
||||
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
|
||||
$ liftIO
|
||||
$ 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)
|
||||
@ -173,8 +173,8 @@ getBase =
|
||||
handleIO (\_ -> readFromCache)
|
||||
$ catchE @_ @'[JSONError, FileDoesNotExistError]
|
||||
(\(DownloadFailed _) -> readFromCache)
|
||||
$ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL)
|
||||
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict))
|
||||
(reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL)
|
||||
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict))
|
||||
where
|
||||
-- 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
|
||||
@ -312,8 +312,8 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
|
||||
in fmap snd
|
||||
. find
|
||||
(\(mverRange, _) -> maybe
|
||||
(mv' == Nothing)
|
||||
(\range -> maybe False (flip versionRange range) mv')
|
||||
(isNothing mv')
|
||||
(\range -> maybe False (`versionRange` range) mv')
|
||||
mverRange
|
||||
)
|
||||
. M.toList
|
||||
@ -365,7 +365,7 @@ download dli dest mfn
|
||||
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
|
||||
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
|
||||
(\e ->
|
||||
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
|
||||
liftIO (hideError doesNotExistErrorType $ deleteFile destFile)
|
||||
>> (throwE . DownloadFailed $ e)
|
||||
) $ do
|
||||
lift getDownloader >>= \case
|
||||
@ -416,7 +416,7 @@ downloadCached dli mfn = do
|
||||
if
|
||||
| fileExists -> do
|
||||
liftE $ checkDigest dli cachfile
|
||||
pure $ cachfile
|
||||
pure cachfile
|
||||
| otherwise -> liftE $ download dli cacheDir mfn
|
||||
False -> do
|
||||
tmp <- lift withGHCupTmpDir
|
||||
@ -453,7 +453,7 @@ downloadBS uri'
|
||||
= dl False
|
||||
| scheme == "file"
|
||||
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
|
||||
$ (liftIO $ RD.readFile path)
|
||||
(liftIO $ RD.readFile path)
|
||||
| otherwise
|
||||
= throwE UnsupportedScheme
|
||||
|
||||
|
||||
@ -1,10 +1,6 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
@ -72,7 +68,7 @@ downloadBS' :: MonadIO m
|
||||
, TooManyRedirs
|
||||
]
|
||||
m
|
||||
(L.ByteString)
|
||||
L.ByteString
|
||||
downloadBS' https host path port = do
|
||||
bref <- liftIO $ newIORef (mempty :: Builder)
|
||||
let stepper bs = modifyIORef bref (<> byteString bs)
|
||||
@ -132,7 +128,7 @@ downloadInternal = go (5 :: Int)
|
||||
if
|
||||
| scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
|
||||
| scode >= 300 && scode < 400 -> case getHeader r "Location" of
|
||||
Just r' -> pure $ Just $ r'
|
||||
Just r' -> pure $ Just r'
|
||||
Nothing -> throwE NoLocationHeader
|
||||
| otherwise -> throwE $ HTTPStatusError scode
|
||||
)
|
||||
@ -151,7 +147,7 @@ downloadInternal = go (5 :: Int)
|
||||
Nothing -> 0
|
||||
|
||||
mpb <- if progressBar
|
||||
then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
|
||||
then Just <$> liftIO (newProgressBar defStyle 10 (Progress 0 size ()))
|
||||
else pure Nothing
|
||||
|
||||
outStream <- liftIO $ Streams.makeOutputStream
|
||||
@ -224,9 +220,9 @@ headInternal = go (5 :: Int)
|
||||
if
|
||||
| scode >= 200 && scode < 300 -> do
|
||||
let headers = getHeaderMap r
|
||||
pure $ Right $ headers
|
||||
pure $ Right headers
|
||||
| scode >= 300 && scode < 400 -> case getHeader r "Location" of
|
||||
Just r' -> pure $ Left $ r'
|
||||
Just r' -> pure $ Left r'
|
||||
Nothing -> throwE NoLocationHeader
|
||||
| otherwise -> throwE $ HTTPStatusError scode
|
||||
)
|
||||
@ -243,7 +239,7 @@ withConnection' :: Bool
|
||||
-> Maybe Int
|
||||
-> (Connection -> IO a)
|
||||
-> IO a
|
||||
withConnection' https host port action = bracket acquire closeConnection action
|
||||
withConnection' https host port = bracket acquire closeConnection
|
||||
|
||||
where
|
||||
acquire = case https of
|
||||
|
||||
@ -1,10 +1,6 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
@ -55,7 +51,7 @@ uriToQuadruple URI {..} = do
|
||||
let queryBS =
|
||||
BS.intercalate "&"
|
||||
. fmap (\(x, y) -> encodeQuery x <> "=" <> encodeQuery y)
|
||||
$ (queryPairs uriQuery)
|
||||
$ queryPairs uriQuery
|
||||
port =
|
||||
preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
|
||||
fullpath = if BS.null queryBS then uriPath else uriPath <> "?" <> queryBS
|
||||
|
||||
@ -1,12 +1,11 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
{-|
|
||||
|
||||
@ -92,17 +92,16 @@ getPlatform = do
|
||||
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
|
||||
"darwin" -> do
|
||||
ver <-
|
||||
( either (const Nothing) Just
|
||||
either (const Nothing) Just
|
||||
. versioning
|
||||
-- TODO: maybe do this somewhere else
|
||||
. getMajorVersion
|
||||
. decUTF8Safe
|
||||
)
|
||||
<$> getDarwinVersion
|
||||
<$> getDarwinVersion
|
||||
pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
|
||||
"freebsd" -> do
|
||||
ver <-
|
||||
(either (const Nothing) Just . versioning . decUTF8Safe)
|
||||
either (const Nothing) Just . versioning . decUTF8Safe
|
||||
<$> getFreeBSDVersion
|
||||
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
|
||||
what -> throwE $ NoCompatiblePlatform what
|
||||
@ -157,7 +156,7 @@ getLinuxDistro = do
|
||||
|
||||
try_os_release :: IO (Text, Maybe Text)
|
||||
try_os_release = do
|
||||
Just (OsRelease { name = name, version_id = version_id }) <-
|
||||
Just OsRelease{ name = name, version_id = version_id } <-
|
||||
fmap osRelease <$> parseOsRelease
|
||||
pure (T.pack name, fmap T.pack version_id)
|
||||
|
||||
@ -174,7 +173,7 @@ getLinuxDistro = do
|
||||
let nameRegex n =
|
||||
makeRegexOpts compIgnoreCase
|
||||
execBlank
|
||||
(([s|\<|] <> fS n <> [s|\>|] :: ByteString)) :: Regex
|
||||
([s|\<|] <> fS n <> [s|\>|] :: ByteString) :: Regex
|
||||
let verRegex =
|
||||
makeRegexOpts compIgnoreCase
|
||||
execBlank
|
||||
|
||||
@ -49,8 +49,8 @@ getCommonRequirements pr tr =
|
||||
in fmap snd
|
||||
. find
|
||||
(\(mverRange, _) -> maybe
|
||||
(mv' == Nothing)
|
||||
(\range -> maybe False (flip versionRange range) mv')
|
||||
(isNothing mv')
|
||||
(\range -> maybe False (`versionRange` range) mv')
|
||||
mverRange
|
||||
)
|
||||
. M.toList
|
||||
|
||||
@ -365,7 +365,7 @@ pfReqToString (PlatformRequest arch plat ver) =
|
||||
archToString arch ++ "-" ++ platformToString plat ++ pver
|
||||
where
|
||||
pver = case ver of
|
||||
Just v' -> "-" ++ (T.unpack $ prettyV v')
|
||||
Just v' -> "-" ++ T.unpack (prettyV v')
|
||||
Nothing -> ""
|
||||
|
||||
instance Pretty PlatformRequest where
|
||||
|
||||
@ -148,7 +148,7 @@ instance FromJSONKey Platform where
|
||||
$ "Unexpected failure in decoding LinuxDistro: "
|
||||
<> show dstr
|
||||
Nothing -> fail "Unexpected failure in Platform stripPrefix"
|
||||
| otherwise -> fail $ "Failure in Platform (FromJSONKey)"
|
||||
| otherwise -> fail "Failure in Platform (FromJSONKey)"
|
||||
|
||||
instance ToJSONKey Architecture where
|
||||
toJSONKey = genericToJSONKey defaultJSONKeyOptions
|
||||
@ -272,7 +272,7 @@ verRangeToText (SimpleRange cmps) =
|
||||
(versionCmpToText <$> NE.toList cmps)
|
||||
in "( " <> inner <> " )"
|
||||
verRangeToText (OrRange cmps range) =
|
||||
let left = verRangeToText $ (SimpleRange cmps)
|
||||
let left = verRangeToText (SimpleRange cmps)
|
||||
right = verRangeToText range
|
||||
in left <> " || " <> right
|
||||
|
||||
@ -288,7 +288,7 @@ versionRangeP = go <* MP.eof
|
||||
go =
|
||||
MP.try orParse
|
||||
<|> MP.try (fmap SimpleRange andParse)
|
||||
<|> (fmap (SimpleRange . pure) versionCmpP)
|
||||
<|> fmap (SimpleRange . pure) versionCmpP
|
||||
|
||||
orParse :: MP.Parsec Void T.Text VersionRange
|
||||
orParse =
|
||||
@ -300,9 +300,7 @@ versionRangeP = go <* MP.eof
|
||||
andParse =
|
||||
fmap (\h t -> h :| t)
|
||||
(MPC.space *> MP.chunk "(" *> MPC.space *> versionCmpP)
|
||||
<*> ( MP.try
|
||||
$ MP.many (MPC.space *> MP.chunk "&&" *> MPC.space *> versionCmpP)
|
||||
)
|
||||
<*> MP.try (MP.many (MPC.space *> MP.chunk "&&" *> MPC.space *> versionCmpP))
|
||||
<* MPC.space
|
||||
<* MP.chunk ")"
|
||||
<* MPC.space
|
||||
|
||||
@ -121,13 +121,13 @@ rmMinorSymlinks :: ( MonadReader AppState m
|
||||
)
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmMinorSymlinks tv@(GHCTargetVersion {..}) = do
|
||||
rmMinorSymlinks tv@GHCTargetVersion{..} = do
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
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}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
@ -147,11 +147,11 @@ rmPlain target = do
|
||||
forM_ mtv $ \tv -> do
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
let fullF = (binDir </> f)
|
||||
let fullF = binDir </> f
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
-- old ghcup
|
||||
let hdc_file = (binDir </> [rel|haddock-ghc|])
|
||||
let hdc_file = binDir </> [rel|haddock-ghc|]
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
|
||||
|
||||
@ -166,7 +166,7 @@ rmMajorSymlinks :: ( MonadReader AppState m
|
||||
)
|
||||
=> GHCTargetVersion
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmMajorSymlinks tv@(GHCTargetVersion {..}) = do
|
||||
rmMajorSymlinks tv@GHCTargetVersion{..} = do
|
||||
AppState { dirs = Dirs {..} } <- lift ask
|
||||
(mj, mi) <- getMajorMinorV _tvVersion
|
||||
let v' = intToText mj <> "." <> intToText mi
|
||||
@ -174,7 +174,7 @@ rmMajorSymlinks tv@(GHCTargetVersion {..}) = do
|
||||
files <- liftE $ ghcToolFiles tv
|
||||
forM_ files $ \f -> do
|
||||
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}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
@ -212,7 +212,7 @@ ghcSet mtarget = do
|
||||
|
||||
-- link destination is of the form ../ghc/<ver>/bin/ghc
|
||||
-- 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
|
||||
Just <$> ghcLinkVersion link
|
||||
|
||||
@ -256,7 +256,7 @@ getInstalledCabals = do
|
||||
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
||||
binDir
|
||||
(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 (Left _) -> pure $ Left f
|
||||
Nothing -> pure $ Left f
|
||||
@ -267,8 +267,8 @@ getInstalledCabals = do
|
||||
-- | Whether the given cabal version is installed.
|
||||
cabalInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
|
||||
cabalInstalled ver = do
|
||||
vers <- fmap rights $ getInstalledCabals
|
||||
pure $ elem ver $ vers
|
||||
vers <- fmap rights getInstalledCabals
|
||||
pure $ elem ver vers
|
||||
|
||||
|
||||
-- Return the currently set cabal version, if any.
|
||||
@ -279,7 +279,7 @@ cabalSet = do
|
||||
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
|
||||
if
|
||||
| b -> do
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
broken <- isBrokenSymlink cabalbin
|
||||
if broken
|
||||
then pure Nothing
|
||||
@ -321,23 +321,20 @@ getInstalledHLSs = do
|
||||
execBlank
|
||||
([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
|
||||
)
|
||||
vs <- forM bins $ \f ->
|
||||
forM bins $ \f ->
|
||||
case
|
||||
fmap
|
||||
version
|
||||
(fmap decUTF8Safe . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f)
|
||||
fmap (version . decUTF8Safe) . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f
|
||||
of
|
||||
Just (Right r) -> pure $ Right r
|
||||
Just (Left _) -> pure $ Left f
|
||||
Nothing -> pure $ Left f
|
||||
pure $ vs
|
||||
|
||||
|
||||
-- | Whether the given HLS version is installed.
|
||||
hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
|
||||
hlsInstalled ver = do
|
||||
vers <- fmap rights $ getInstalledHLSs
|
||||
pure $ elem ver $ vers
|
||||
vers <- fmap rights getInstalledHLSs
|
||||
pure $ elem ver vers
|
||||
|
||||
|
||||
|
||||
@ -347,7 +344,7 @@ hlsSet = do
|
||||
AppState {dirs = Dirs {..}} <- ask
|
||||
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
|
||||
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
|
||||
broken <- isBrokenSymlink hlsBin
|
||||
if broken
|
||||
then pure Nothing
|
||||
@ -376,15 +373,13 @@ hlsGHCVersions = do
|
||||
vers <- forM h $ \h' -> do
|
||||
bins <- hlsServerBinaries h'
|
||||
pure $ fmap
|
||||
(\bin ->
|
||||
version
|
||||
. decUTF8Safe
|
||||
. fromJust
|
||||
. B.stripPrefix "haskell-language-server-"
|
||||
. head
|
||||
. B.split _tilde
|
||||
. toFilePath
|
||||
$ bin
|
||||
(version
|
||||
. decUTF8Safe
|
||||
. fromJust
|
||||
. B.stripPrefix "haskell-language-server-"
|
||||
. head
|
||||
. B.split _tilde
|
||||
. toFilePath
|
||||
)
|
||||
bins
|
||||
pure . rights . concat . maybeToList $ vers
|
||||
@ -421,7 +416,7 @@ hlsWrapperBinary ver = do
|
||||
)
|
||||
)
|
||||
case wrapper of
|
||||
[] -> pure $ Nothing
|
||||
[] -> pure Nothing
|
||||
[x] -> pure $ Just x
|
||||
_ -> throwM $ UnexpectedListLength
|
||||
"There were multiple hls wrapper binaries for a single version"
|
||||
@ -498,12 +493,8 @@ getLatestGHCFor :: Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> GHCupDownloads
|
||||
-> Maybe (Version, VersionInfo)
|
||||
getLatestGHCFor major' minor' dls = do
|
||||
join
|
||||
. fmap (lastMay . filter (\(v, _) -> matchMajor v major' minor'))
|
||||
. preview (ix GHC % to Map.toDescList)
|
||||
$ dls
|
||||
|
||||
getLatestGHCFor major' minor' dls =
|
||||
preview (ix GHC % to Map.toDescList) dls >>= lastMay . filter (\(v, _) -> matchMajor v major' minor')
|
||||
|
||||
|
||||
|
||||
@ -524,7 +515,7 @@ unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
|
||||
#endif
|
||||
] m ()
|
||||
unpackToDir dest av = do
|
||||
fp <- (decUTF8Safe . toFilePath) <$> basename av
|
||||
fp <- decUTF8Safe . toFilePath <$> basename av
|
||||
let dfp = decUTF8Safe . toFilePath $ dest
|
||||
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
|
||||
fn <- toFilePath <$> basename av
|
||||
@ -570,9 +561,9 @@ intoSubdir bdir tardir = case tardir of
|
||||
let rs = splitOn "/" r
|
||||
foldlM
|
||||
(\y x ->
|
||||
(fmap sort . handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= \case
|
||||
(handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
|
||||
[] -> throwE $ TarDirDoesNotExist tardir
|
||||
(p : _) -> pure (y </> p)
|
||||
(p : _) -> pure (y </> p)) . sort
|
||||
)
|
||||
bdir
|
||||
rs
|
||||
@ -591,16 +582,15 @@ intoSubdir bdir tardir = case tardir of
|
||||
getTagged :: Tag
|
||||
-> AffineFold (Map.Map Version VersionInfo) (Version, VersionInfo)
|
||||
getTagged tag =
|
||||
( to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
|
||||
to (Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
|
||||
% to Map.toDescList
|
||||
% _head
|
||||
)
|
||||
|
||||
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 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.
|
||||
@ -671,10 +661,10 @@ ghcToolFiles ver = do
|
||||
then pure id
|
||||
else do
|
||||
(Just symver) <-
|
||||
(B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName)
|
||||
<$> (liftIO $ readSymbolicLink $ toFilePath ghcbinPath)
|
||||
B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName
|
||||
<$> liftIO (readSymbolicLink $ toFilePath ghcbinPath)
|
||||
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 $ onlyUnversioned files
|
||||
@ -699,8 +689,8 @@ make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
|
||||
-> Maybe (Path Abs)
|
||||
-> m (Either ProcessError ())
|
||||
make args workdir = do
|
||||
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
|
||||
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|])
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
|
||||
let mymake = if has_gmake then "gmake" else "make"
|
||||
execLogged mymake True args [rel|ghc-make|] workdir Nothing
|
||||
|
||||
@ -715,13 +705,13 @@ applyPatches pdir ddir = do
|
||||
patches <- liftIO $ getDirsFiles pdir
|
||||
forM_ (sort patches) $ \patch' -> do
|
||||
lift $ $(logInfo) [i|Applying patch #{patch'}|]
|
||||
(fmap (either (const Nothing) Just) $ liftIO $ exec
|
||||
"patch"
|
||||
True
|
||||
["-p1", "-i", toFilePath patch']
|
||||
(Just ddir)
|
||||
Nothing
|
||||
)
|
||||
fmap (either (const Nothing) Just)
|
||||
(liftIO $ exec
|
||||
"patch"
|
||||
True
|
||||
["-p1", "-i", toFilePath patch']
|
||||
(Just ddir)
|
||||
Nothing)
|
||||
!? PatchFailed
|
||||
|
||||
|
||||
@ -767,8 +757,7 @@ runBuildAction bdir instdir action = do
|
||||
(\es -> do
|
||||
exAction
|
||||
throwE (BuildFailed bdir es)
|
||||
)
|
||||
$ action
|
||||
) action
|
||||
|
||||
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
|
||||
bdir
|
||||
@ -800,14 +789,13 @@ getVersionInfo :: Version
|
||||
-> Tool
|
||||
-> GHCupDownloads
|
||||
-> Maybe VersionInfo
|
||||
getVersionInfo v' tool dls =
|
||||
getVersionInfo v' tool =
|
||||
headOf
|
||||
( ix tool
|
||||
% to (Map.filterWithKey (\k _ -> k == v'))
|
||||
% to Map.elems
|
||||
% _head
|
||||
)
|
||||
dls
|
||||
|
||||
|
||||
-- Gathering monoidal values
|
||||
@ -816,4 +804,4 @@ traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
|
||||
|
||||
-- | Gathering monoidal values
|
||||
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
|
||||
forFold = \t -> \f -> traverseFold f t
|
||||
forFold = \t -> (`traverseFold` t)
|
||||
|
||||
@ -190,7 +190,7 @@ ghcupConfigFile = do
|
||||
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
|
||||
case bs of
|
||||
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 = do
|
||||
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
|
||||
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> "ghcup-")
|
||||
tmp <- liftIO $ mkdtemp (tmpdir FP.</> "ghcup-")
|
||||
parseAbs tmp
|
||||
|
||||
|
||||
@ -266,7 +266,7 @@ relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
|
||||
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
|
||||
cPrefix = drop (length common) d1
|
||||
in joinPath (replicate (length cPrefix) "..")
|
||||
<> joinPath ("/" : (drop (length common) d2))
|
||||
<> joinPath ("/" : drop (length common) d2)
|
||||
|
||||
|
||||
|
||||
|
||||
@ -107,12 +107,14 @@ makeLenses ''CapturedProcess
|
||||
-- PATH does.
|
||||
findExecutable :: Path Rel -> IO (Maybe (Path Abs))
|
||||
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
|
||||
-- figure out if a file exists, then treat it as a negative result.
|
||||
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
|
||||
-- asum for short-circuiting behavior
|
||||
(\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
|
||||
asum $ fmap
|
||||
(handleIO (\_ -> pure Nothing)
|
||||
-- asum for short-circuiting behavior
|
||||
. (\s' -> (isExecutable (s' </> ex) >>= guard) $> Just (s' </> ex))
|
||||
)
|
||||
sPaths
|
||||
|
||||
|
||||
@ -150,11 +152,12 @@ execLogged exe spath args lfile chdir env = do
|
||||
void
|
||||
$ forkIO
|
||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||
$ flip EX.finally (putMVar done ())
|
||||
$ (if verbose
|
||||
then tee fd stdoutRead
|
||||
else printToRegion fd stdoutRead 6 pState
|
||||
)
|
||||
$ EX.finally
|
||||
(if verbose
|
||||
then tee fd stdoutRead
|
||||
else printToRegion fd stdoutRead 6 pState
|
||||
)
|
||||
(putMVar done ())
|
||||
|
||||
-- fork the subprocess
|
||||
pid <- SPPB.forkProcess $ do
|
||||
@ -203,7 +206,7 @@ execLogged exe spath args lfile chdir env = do
|
||||
$ handle
|
||||
(\(ex :: SomeException) -> do
|
||||
ps <- liftIO $ takeMVar pState
|
||||
when (ps == True) (forM_ rs (liftIO . closeConsoleRegion))
|
||||
when ps (forM_ rs (liftIO . closeConsoleRegion))
|
||||
throw ex
|
||||
)
|
||||
$ readTilEOF (lineAction rs) fdIn
|
||||
@ -247,7 +250,7 @@ execLogged exe spath args lfile chdir env = do
|
||||
=> Fd -- ^ input file descriptor
|
||||
-> ByteString -- ^ rest buffer (read across newline)
|
||||
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
|
||||
readLine fd = \inBs -> go inBs
|
||||
readLine fd = go
|
||||
where
|
||||
go inBs = do
|
||||
-- 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'
|
||||
if eof
|
||||
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
|
||||
@ -329,7 +332,7 @@ captureOutStreams action = do
|
||||
, _stdErr = stderr'
|
||||
}
|
||||
|
||||
_ -> throwIO $ userError $ ("No such PID " ++ show pid)
|
||||
_ -> throwIO $ userError ("No such PID " ++ show pid)
|
||||
|
||||
where
|
||||
writeStds pout perr rout rerr = do
|
||||
@ -356,7 +359,7 @@ captureOutStreams action = do
|
||||
|
||||
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
|
||||
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 fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
|
||||
@ -423,7 +426,7 @@ isShadowed :: Path Abs -> IO (Maybe (Path Abs))
|
||||
isShadowed p = do
|
||||
let dir = dirname p
|
||||
fn <- basename p
|
||||
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
if dir `elem` spaths
|
||||
then do
|
||||
let shadowPaths = takeWhile (/= dir) spaths
|
||||
@ -437,7 +440,7 @@ isInPath :: Path Abs -> IO Bool
|
||||
isInPath p = do
|
||||
let dir = dirname p
|
||||
fn <- basename p
|
||||
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
if dir `elem` spaths
|
||||
then isJust <$> searchPath [dir] fn
|
||||
else pure False
|
||||
@ -451,7 +454,7 @@ findFiles path regex = do
|
||||
. S.toList
|
||||
. S.filter (\(_, p) -> match regex p)
|
||||
$ dirContentsStream dirStream
|
||||
pure $ join $ fmap parseRel f
|
||||
pure $ parseRel =<< f
|
||||
|
||||
|
||||
findFiles' :: Path Abs -> MP.Parsec Void Text () -> IO [Path Rel]
|
||||
@ -464,7 +467,7 @@ findFiles' path parser = do
|
||||
Left _ -> False
|
||||
Right p' -> isJust $ MP.parseMaybe parser p')
|
||||
$ dirContentsStream dirStream
|
||||
pure $ join $ fmap parseRel f
|
||||
pure $ parseRel =<< f
|
||||
|
||||
|
||||
isBrokenSymlink :: Path Abs -> IO Bool
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
{-|
|
||||
@ -51,7 +50,7 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
|
||||
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
|
||||
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
|
||||
|
||||
when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
|
||||
when (lcPrintDebug || (not lcPrintDebug && (level /= LevelDebug)))
|
||||
$ colorOutter out
|
||||
|
||||
-- raw output
|
||||
|
||||
@ -15,7 +15,6 @@ module GHCup.Utils.MegaParsec where
|
||||
import GHCup.Types
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
@ -61,9 +60,9 @@ ghcTargetBinP :: Text -> MP.Parsec Void Text (Maybe Text, Text)
|
||||
ghcTargetBinP t =
|
||||
(,)
|
||||
<$> ( 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)
|
||||
|
||||
@ -74,8 +73,8 @@ ghcTargetBinP t =
|
||||
ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion
|
||||
ghcTargetVerP =
|
||||
(\x y -> GHCTargetVersion x y)
|
||||
<$> (MP.try (Just <$> (parseUntil1 (MP.chunk "-" *> verP')) <* MP.chunk "-")
|
||||
<|> (flip const Nothing <$> mempty)
|
||||
<$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
|
||||
<|> ((\ _ x -> x) Nothing <$> mempty)
|
||||
)
|
||||
<*> (version' <* MP.eof)
|
||||
where
|
||||
@ -85,16 +84,15 @@ ghcTargetVerP =
|
||||
let startsWithDigists =
|
||||
and
|
||||
. take 3
|
||||
. join
|
||||
. (fmap . fmap)
|
||||
. concatMap
|
||||
(map
|
||||
(\case
|
||||
(Digits _) -> True
|
||||
(Str _) -> False
|
||||
)
|
||||
. fmap NE.toList
|
||||
) . NE.toList)
|
||||
. NE.toList
|
||||
$ (_vChunks v)
|
||||
if startsWithDigists && not (isJust (_vEpoch v))
|
||||
$ _vChunks v
|
||||
if startsWithDigists && isNothing (_vEpoch v)
|
||||
then pure $ prettyVer v
|
||||
else fail "Oh"
|
||||
|
||||
|
||||
@ -1,10 +1,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
@ -131,7 +128,7 @@ lE' :: forall e' e es a m
|
||||
=> (e' -> e)
|
||||
-> Either e' 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 em = lift em >>= lE
|
||||
@ -141,7 +138,7 @@ lEM' :: forall e' e es a m
|
||||
=> (e' -> e)
|
||||
-> m (Either e' 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 (VLeft . V) VRight
|
||||
@ -200,8 +197,8 @@ hideExcept :: forall e es es' a m
|
||||
-> a
|
||||
-> Excepts es m a
|
||||
-> Excepts es' m a
|
||||
hideExcept _ a action =
|
||||
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
|
||||
hideExcept _ a =
|
||||
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a))
|
||||
|
||||
|
||||
hideExcept' :: forall e es es' m
|
||||
@ -209,8 +206,8 @@ hideExcept' :: forall e es es' m
|
||||
=> e
|
||||
-> Excepts es m ()
|
||||
-> Excepts es' m ()
|
||||
hideExcept' _ action =
|
||||
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
|
||||
hideExcept' _ =
|
||||
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ()))
|
||||
|
||||
|
||||
reThrowAll :: forall e es es' a m
|
||||
@ -259,7 +256,7 @@ addToCurrentEnv :: MonadIO m
|
||||
=> [(ByteString, ByteString)]
|
||||
-> m [(ByteString, ByteString)]
|
||||
addToCurrentEnv adds = do
|
||||
cEnv <- liftIO $ getEnvironment
|
||||
cEnv <- liftIO getEnvironment
|
||||
pure (adds ++ cEnv)
|
||||
|
||||
|
||||
|
||||
@ -57,7 +57,7 @@ deriving instance Lift (NonEmpty Word)
|
||||
|
||||
qq :: (Text -> Q Exp) -> QuasiQuoter
|
||||
qq quoteExp' = QuasiQuoter
|
||||
{ quoteExp = (\s -> quoteExp' . T.pack $ s)
|
||||
{ quoteExp = \s -> quoteExp' . T.pack $ s
|
||||
, quotePat = \_ ->
|
||||
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
|
||||
, quoteType = \_ ->
|
||||
@ -101,4 +101,4 @@ liftText :: T.Text -> Q Exp
|
||||
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
|
||||
|
||||
liftDataWithText :: Data a => a -> Q Exp
|
||||
liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)
|
||||
liftDataWithText = dataToExpQ (fmap liftText . cast)
|
||||
|
||||
@ -1,10 +1,7 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module GHCup.ArbitraryTypes where
|
||||
|
||||
@ -57,7 +54,7 @@ instance Arbitrary T.Text where
|
||||
shrink xs = T.pack <$> shrink (T.unpack xs)
|
||||
|
||||
instance Arbitrary (NonEmpty Word) where
|
||||
arbitrary = fmap fromList $ listOf1 $ arbitrary
|
||||
arbitrary = fmap fromList $ listOf1 arbitrary
|
||||
|
||||
-- utf8 encoded bytestring
|
||||
instance Arbitrary ByteString where
|
||||
@ -70,7 +67,7 @@ instance Arbitrary ByteString 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
|
||||
arbitrary = genericArbitrary
|
||||
@ -82,7 +79,7 @@ instance Arbitrary Port where
|
||||
|
||||
instance Arbitrary (URIRef Absolute) where
|
||||
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
|
||||
pure
|
||||
$ either (error . show) id
|
||||
$ mess
|
||||
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
|
||||
$ mess (intToText x <> "." <> intToText y <> "." <> intToText z)
|
||||
|
||||
instance Arbitrary Version where
|
||||
arbitrary = do
|
||||
(x, y, z) <- genVer
|
||||
pure
|
||||
$ either (error . show) id
|
||||
$ version
|
||||
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
|
||||
$ version (intToText x <> "." <> intToText y <> "." <> intToText z)
|
||||
|
||||
instance Arbitrary SemVer where
|
||||
arbitrary = do
|
||||
(x, y, z) <- genVer
|
||||
pure
|
||||
$ either (error . show) id
|
||||
$ semver
|
||||
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
|
||||
$ semver (intToText x <> "." <> intToText y <> "." <> intToText z)
|
||||
|
||||
instance Arbitrary PVP where
|
||||
arbitrary = do
|
||||
(x, y, z) <- genVer
|
||||
pure
|
||||
$ either (error . show) id
|
||||
$ pvp
|
||||
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
|
||||
$ pvp (intToText x <> "." <> intToText y <> "." <> intToText z)
|
||||
|
||||
instance Arbitrary Versioning where
|
||||
arbitrary = Ideal <$> arbitrary
|
||||
@ -173,8 +166,8 @@ instance Arbitrary VersionCmp where
|
||||
|
||||
instance Arbitrary (Path Rel) where
|
||||
arbitrary =
|
||||
(either (error . show) id . parseRel . E.encodeUtf8 . T.pack)
|
||||
<$> (listOf1 $ elements ['a' .. 'z'])
|
||||
either (error . show) id . parseRel . E.encodeUtf8 . T.pack
|
||||
<$> listOf1 (elements ['a' .. 'z'])
|
||||
|
||||
instance Arbitrary TarDir where
|
||||
arbitrary = genericArbitrary
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module GHCup.Types.JSONSpec where
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
import Test.Hspec.Runner
|
||||
import Test.Hspec.Formatters
|
||||
import qualified Spec
|
||||
@ -9,4 +7,4 @@ main :: IO ()
|
||||
main =
|
||||
hspecWith
|
||||
defaultConfig { configFormatter = Just progress }
|
||||
$ Spec.spec
|
||||
Spec.spec
|
||||
|
||||
Loading…
Reference in New Issue
Block a user