Compare commits
2 Commits
refactor-m
...
cabal-comp
| Author | SHA1 | Date | |
|---|---|---|---|
|
e88e131b9d
|
|||
|
4c7c9ab62e
|
@@ -15,5 +15,5 @@ git describe
|
||||
ecabal update
|
||||
ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hlint
|
||||
|
||||
hlint -r app/ lib/ test/
|
||||
hlint -r lib/ test/
|
||||
|
||||
|
||||
@@ -1,7 +1,10 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
|
||||
|
||||
@@ -91,23 +91,23 @@ validate dls _ = do
|
||||
checkHasRequiredPlatforms t v tags arch pspecs = do
|
||||
let v' = prettyVer v
|
||||
arch' = prettyShow arch
|
||||
when (Linux UnknownLinux `notElem` pspecs) $ do
|
||||
when (notElem (Linux UnknownLinux) pspecs) $ do
|
||||
lift $ logError $
|
||||
"Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
|
||||
addError
|
||||
when ((Darwin `notElem` pspecs) && arch == A_64) $ do
|
||||
when ((notElem Darwin pspecs) && arch == A_64) $ do
|
||||
lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
|
||||
addError
|
||||
when ((FreeBSD `notElem` pspecs) && arch == A_64) $ lift $ logWarn $
|
||||
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ logWarn $
|
||||
"FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
|
||||
when (Windows `notElem` pspecs && arch == A_64) $ do
|
||||
when (notElem Windows pspecs && arch == A_64) $ do
|
||||
lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
|
||||
addError
|
||||
|
||||
-- alpine needs to be set explicitly, because
|
||||
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
|
||||
-- (although it could be static)
|
||||
when (Linux Alpine `notElem` pspecs) $
|
||||
when (notElem (Linux Alpine) pspecs) $
|
||||
case t of
|
||||
GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
|
||||
Cabal | v > [vver|2.4.1.0|]
|
||||
@@ -117,7 +117,7 @@ validate dls _ = do
|
||||
_ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
|
||||
|
||||
checkUniqueTags tool = do
|
||||
let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
|
||||
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
|
||||
let nonUnique =
|
||||
fmap fst
|
||||
. filter (\(_, b) -> not b)
|
||||
@@ -155,8 +155,8 @@ validate dls _ = do
|
||||
|
||||
-- a tool must have at least one of each mandatory tags
|
||||
checkMandatoryTags tool = do
|
||||
let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
|
||||
forM_ [Latest, Recommended] $ \t -> case t `elem` allTags of
|
||||
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
|
||||
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
|
||||
False -> do
|
||||
lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
|
||||
addError
|
||||
@@ -202,7 +202,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
||||
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
|
||||
let gdlis = nubOrd $ gt ^.. each
|
||||
let allDls = either (const gdlis) (const dlis) etool
|
||||
when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref
|
||||
when (null allDls) $ logError "no tarballs selected by filter" *> (flip runReaderT ref addError)
|
||||
forM_ allDls (downloadAll ref)
|
||||
|
||||
-- exit
|
||||
@@ -260,7 +260,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
||||
when (basePath /= prel) $ do
|
||||
logError $
|
||||
"Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
|
||||
runReaderT addError ref
|
||||
(flip runReaderT ref addError)
|
||||
Just (RegexDir regexString) -> do
|
||||
logInfo $
|
||||
"verifying subdir (regex): " <> T.pack regexString
|
||||
@@ -268,13 +268,13 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
||||
compIgnoreCase
|
||||
execBlank
|
||||
regexString
|
||||
unless (match regex basePath) $ do
|
||||
when (not (match regex basePath)) $ do
|
||||
logError $
|
||||
"Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
|
||||
runReaderT addError ref
|
||||
(flip runReaderT ref addError)
|
||||
Nothing -> pure ()
|
||||
VRight Nothing -> pure ()
|
||||
VLeft e -> do
|
||||
logError $
|
||||
"Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
|
||||
runReaderT addError ref
|
||||
(flip runReaderT ref addError)
|
||||
|
||||
@@ -2,7 +2,10 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module BrickMain where
|
||||
@@ -365,7 +368,10 @@ listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
|
||||
|
||||
|
||||
selectLatest :: Vector ListResult -> Int
|
||||
selectLatest = fromMaybe 0 . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
|
||||
selectLatest v =
|
||||
case V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) v of
|
||||
Just ix -> ix
|
||||
Nothing -> 0
|
||||
|
||||
|
||||
-- | Replace the @appState@ or construct it based on a filter function
|
||||
@@ -392,14 +398,14 @@ filterVisible :: Bool -> Bool -> ListResult -> Bool
|
||||
filterVisible v t e | lInstalled e = True
|
||||
| v
|
||||
, not t
|
||||
, lTool e `notElem` hiddenTools = True
|
||||
, not (elem (lTool e) hiddenTools) = True
|
||||
| not v
|
||||
, t
|
||||
, Old `notElem` lTag e = True
|
||||
, not (elem Old (lTag e)) = True
|
||||
| v
|
||||
, t = True
|
||||
| otherwise = (Old `notElem` lTag e) &&
|
||||
(lTool e `notElem` hiddenTools)
|
||||
| otherwise = not (elem Old (lTag e)) &&
|
||||
not (elem (lTool e) hiddenTools)
|
||||
|
||||
|
||||
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
|
||||
@@ -501,7 +507,7 @@ del' _ (_, ListResult {..}) = do
|
||||
)
|
||||
>>= \case
|
||||
VRight vi -> do
|
||||
forM_ (_viPostRemove =<< vi) $ \msg ->
|
||||
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
|
||||
logInfo msg
|
||||
pure $ Right ()
|
||||
VLeft e -> pure $ Left (prettyShow e)
|
||||
@@ -588,7 +594,8 @@ getGHCupInfo = do
|
||||
r <-
|
||||
flip runReaderT settings
|
||||
. runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
|
||||
$ liftE getDownloadsF
|
||||
$ liftE
|
||||
$ getDownloadsF
|
||||
|
||||
case r of
|
||||
VRight a -> pure $ Right a
|
||||
|
||||
@@ -1,7 +1,11 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
|
||||
@@ -105,7 +109,7 @@ opts =
|
||||
Options
|
||||
<$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")
|
||||
<*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
|
||||
<*> optional
|
||||
<*> (optional
|
||||
(option
|
||||
(eitherReader parseUri)
|
||||
( short 's'
|
||||
@@ -115,6 +119,7 @@ opts =
|
||||
<> internal
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
|
||||
<*> optional (option
|
||||
(eitherReader keepOnParser)
|
||||
@@ -159,10 +164,11 @@ com =
|
||||
( command
|
||||
"tui"
|
||||
( (\_ -> Interactive)
|
||||
<$> info
|
||||
<$> (info
|
||||
helper
|
||||
( progDesc "Start the interactive GHCup UI"
|
||||
)
|
||||
)
|
||||
)
|
||||
<> command
|
||||
#else
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
@@ -1,7 +1,11 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
module GHCup.OptParse.Common where
|
||||
@@ -156,7 +160,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
|
||||
archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32)
|
||||
platformP :: MP.Parsec Void Text PlatformRequest
|
||||
platformP = choice'
|
||||
[ (`PlatformRequest` FreeBSD)
|
||||
[ (\a mv -> PlatformRequest a FreeBSD mv)
|
||||
<$> (archP <* MP.chunk "-")
|
||||
<*> ( MP.chunk "portbld"
|
||||
*> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof))
|
||||
@@ -164,7 +168,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
|
||||
)
|
||||
<* MP.chunk "-freebsd"
|
||||
)
|
||||
, (`PlatformRequest` Darwin)
|
||||
, (\a mv -> PlatformRequest a Darwin mv)
|
||||
<$> (archP <* MP.chunk "-")
|
||||
<*> ( MP.chunk "apple"
|
||||
*> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof))
|
||||
@@ -307,8 +311,11 @@ tagCompleter tool add = listIOCompleter $ do
|
||||
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
|
||||
case mGhcUpInfo of
|
||||
VRight ghcupInfo -> do
|
||||
let allTags = filter (/= Old)
|
||||
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
|
||||
let allTags = filter (\t -> t /= Old)
|
||||
$ join
|
||||
$ fmap _viTags
|
||||
$ M.elems
|
||||
$ availableToolVersions (_ghcupDownloads ghcupInfo) tool
|
||||
pure $ nub $ (add ++) $ fmap tagToString allTags
|
||||
VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add)
|
||||
|
||||
@@ -389,7 +396,7 @@ fromVersion' :: ( HasLog env
|
||||
] m (GHCTargetVersion, Maybe VersionInfo)
|
||||
fromVersion' SetRecommended tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
bimap mkTVer Just <$> getRecommended dls tool
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
|
||||
?? TagNotFound Recommended tool
|
||||
fromVersion' (SetToolVersion v) tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
@@ -400,18 +407,18 @@ fromVersion' (SetToolVersion v) tool = do
|
||||
lift (getLatestToolFor tool pvpIn dls) >>= \case
|
||||
Just (pvp_, vi') -> do
|
||||
v' <- lift $ pvpToVersion pvp_
|
||||
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
|
||||
when (v' /= (_tvVersion v)) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
|
||||
pure (GHCTargetVersion (_tvTarget v) v', Just vi')
|
||||
Nothing -> pure (v, vi)
|
||||
fromVersion' (SetToolTag Latest) tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
|
||||
fromVersion' (SetToolTag Recommended) tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool
|
||||
fromVersion' (SetToolTag (Base pvp'')) GHC = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
bimap mkTVer Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
|
||||
fromVersion' SetNext tool = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
|
||||
next <- case tool of
|
||||
@@ -423,7 +430,7 @@ fromVersion' SetNext tool = do
|
||||
. dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set)
|
||||
. cycle
|
||||
. sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
|
||||
. filter (\GHCTargetVersion {..} -> isNothing _tvTarget)
|
||||
. filter (\GHCTargetVersion {..} -> _tvTarget == Nothing)
|
||||
$ ghcs) ?? NoToolVersionSet tool
|
||||
Cabal -> do
|
||||
set <- cabalSet !? NoToolVersionSet tool
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
@@ -507,7 +508,7 @@ compile compileCommand settings runAppState runLogger = do
|
||||
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
||||
case keepDirs settings of
|
||||
Never -> runLogger $ logError $ T.pack $ prettyShow err
|
||||
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
|
||||
_ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
|
||||
"Check the logs at " <> T.pack logsDir <> " and the build directory "
|
||||
<> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
@@ -83,7 +84,7 @@ prettyDebugInfo DebugInfo {..} = "Debug Info" <> "\n" <>
|
||||
type DInfoEffects = '[ NoCompatiblePlatform , NoCompatibleArch , DistroNotFound ]
|
||||
|
||||
runDebugInfo :: (ReaderT env m (VEither DInfoEffects a) -> m (VEither DInfoEffects a))
|
||||
-> Excepts DInfoEffects (ReaderT env m) a
|
||||
-> (Excepts DInfoEffects (ReaderT env m) a)
|
||||
-> m (VEither DInfoEffects a)
|
||||
runDebugInfo runAppState =
|
||||
runAppState
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
@@ -103,7 +104,7 @@ type GCEffects = '[ NotInstalled ]
|
||||
|
||||
runGC :: MonadUnliftIO m
|
||||
=> (ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a))
|
||||
-> Excepts GCEffects (ResourceT (ReaderT AppState m)) a
|
||||
-> (Excepts GCEffects (ResourceT (ReaderT AppState m)) a)
|
||||
-> m (VEither GCEffects a)
|
||||
runGC runAppState =
|
||||
runAppState
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
@@ -274,7 +275,7 @@ runInstTool appstate' mInstPlatform =
|
||||
-------------------
|
||||
|
||||
|
||||
install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
|
||||
install :: (Either InstallCommand InstallOptions) -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
|
||||
install installCommand settings getAppState' runLogger = case installCommand of
|
||||
(Right iopts) -> do
|
||||
runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
|
||||
@@ -323,8 +324,8 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
pure $ ExitFailure 3
|
||||
VLeft err@(V (BuildFailed tmpdir _)) -> do
|
||||
case keepDirs settings of
|
||||
Never -> runLogger (logError $ T.pack $ prettyShow err)
|
||||
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
|
||||
Never -> runLogger $ (logError $ T.pack $ prettyShow err)
|
||||
_ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
|
||||
"Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||
pure $ ExitFailure 3
|
||||
|
||||
@@ -1,7 +1,11 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
@@ -95,7 +99,7 @@ printListResult :: Bool -> Bool -> [ListResult] -> IO ()
|
||||
printListResult no_color raw lr = do
|
||||
|
||||
let
|
||||
color | raw || no_color = (\_ x -> x)
|
||||
color | raw || no_color = flip const
|
||||
| otherwise = Pretty.color
|
||||
|
||||
let
|
||||
@@ -130,7 +134,7 @@ printListResult no_color raw lr = do
|
||||
, case lCross of
|
||||
Nothing -> T.unpack . prettyVer $ lVer
|
||||
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
|
||||
, intercalate "," (filter (/= "") . fmap printTag $ sort lTag)
|
||||
, intercalate "," $ (filter (/= "") . fmap printTag $ sort lTag)
|
||||
, intercalate ","
|
||||
$ (if hlsPowered
|
||||
then [color Green "hls-powered"]
|
||||
@@ -147,10 +151,10 @@ printListResult no_color raw lr = do
|
||||
$ lr
|
||||
let cols =
|
||||
foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows
|
||||
lengths = fmap (maximum . fmap strWidth) cols
|
||||
lengths = fmap maximum . (fmap . fmap) strWidth $ cols
|
||||
padded = fmap (\xs -> zipWith padTo xs lengths) rows
|
||||
|
||||
forM_ padded $ \row -> putStrLn $ unwords row
|
||||
forM_ padded $ \row -> putStrLn $ intercalate " " row
|
||||
where
|
||||
|
||||
padTo str' x =
|
||||
|
||||
@@ -3,6 +3,9 @@
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
@@ -46,7 +49,7 @@ type NukeEffects = '[ NotInstalled ]
|
||||
|
||||
|
||||
runNuke :: AppState
|
||||
-> Excepts NukeEffects (ReaderT AppState m) a
|
||||
-> (Excepts NukeEffects (ReaderT AppState m) a)
|
||||
-> m (VEither NukeEffects a)
|
||||
runNuke s' =
|
||||
flip runReaderT s' . runE @NukeEffects
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
@@ -84,7 +85,7 @@ prefetchP = subparser
|
||||
<$> (PrefetchGHCOptions
|
||||
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
|
||||
<*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
|
||||
<*> optional (toolVersionArgument Nothing (Just GHC)) )
|
||||
<*> ( optional (toolVersionArgument Nothing (Just GHC)) ))
|
||||
( progDesc "Download GHC assets for installation")
|
||||
)
|
||||
<>
|
||||
@@ -117,7 +118,7 @@ prefetchP = subparser
|
||||
<>
|
||||
command
|
||||
"metadata"
|
||||
(PrefetchMetadata <$ info
|
||||
(const PrefetchMetadata <$> info
|
||||
helper
|
||||
( progDesc "Download ghcup's metadata, needed for various operations")
|
||||
)
|
||||
@@ -161,7 +162,7 @@ type PrefetchEffects = '[ TagNotFound
|
||||
|
||||
runPrefetch :: MonadUnliftIO m
|
||||
=> (ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a))
|
||||
-> Excepts PrefetchEffects (ResourceT (ReaderT AppState m)) a
|
||||
-> (Excepts PrefetchEffects (ResourceT (ReaderT AppState m)) a)
|
||||
-> m (VEither PrefetchEffects a)
|
||||
runPrefetch runAppState =
|
||||
runAppState
|
||||
@@ -196,20 +197,20 @@ prefetch prefetchCommand runAppState runLogger =
|
||||
if pfGHCSrc
|
||||
then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir
|
||||
else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
|
||||
PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do
|
||||
PrefetchCabal (PrefetchOptions {pfCacheDir}) mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt Cabal
|
||||
liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir
|
||||
PrefetchHLS PrefetchOptions {pfCacheDir} mt -> do
|
||||
PrefetchHLS (PrefetchOptions {pfCacheDir}) mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt HLS
|
||||
liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir
|
||||
PrefetchStack PrefetchOptions {pfCacheDir} mt -> do
|
||||
PrefetchStack (PrefetchOptions {pfCacheDir}) mt -> do
|
||||
forM_ pfCacheDir (liftIO . createDirRecursive')
|
||||
(v, _) <- liftE $ fromVersion mt Stack
|
||||
liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
|
||||
PrefetchMetadata -> do
|
||||
_ <- liftE getDownloadsF
|
||||
_ <- liftE $ getDownloadsF
|
||||
pure ""
|
||||
) >>= \case
|
||||
VRight _ -> do
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
@@ -131,7 +132,7 @@ type RmEffects = '[ NotInstalled ]
|
||||
|
||||
|
||||
runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))
|
||||
-> Excepts RmEffects (ReaderT env m) a
|
||||
-> (Excepts RmEffects (ReaderT env m) a)
|
||||
-> m (VEither RmEffects a)
|
||||
runRm runAppState =
|
||||
runAppState
|
||||
@@ -151,7 +152,7 @@ rm :: ( Monad m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Either RmCommand RmOptions
|
||||
=> (Either RmCommand RmOptions)
|
||||
-> (ReaderT AppState m (VEither RmEffects (Maybe VersionInfo))
|
||||
-> m (VEither RmEffects (Maybe VersionInfo)))
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
|
||||
@@ -2,6 +2,8 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
@@ -40,7 +42,6 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
import qualified Data.Text as T
|
||||
import Data.Bifunctor (second)
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import GHCup.Types.Optics
|
||||
|
||||
|
||||
|
||||
@@ -186,7 +187,7 @@ type SetGHCEffects = '[ FileDoesNotExistError
|
||||
, NoToolVersionSet]
|
||||
|
||||
runSetGHC :: (ReaderT env m (VEither SetGHCEffects a) -> m (VEither SetGHCEffects a))
|
||||
-> Excepts SetGHCEffects (ReaderT env m) a
|
||||
-> (Excepts SetGHCEffects (ReaderT env m) a)
|
||||
-> m (VEither SetGHCEffects a)
|
||||
runSetGHC runAppState =
|
||||
runAppState
|
||||
@@ -200,7 +201,7 @@ type SetCabalEffects = '[ NotInstalled
|
||||
, NoToolVersionSet]
|
||||
|
||||
runSetCabal :: (ReaderT env m (VEither SetCabalEffects a) -> m (VEither SetCabalEffects a))
|
||||
-> Excepts SetCabalEffects (ReaderT env m) a
|
||||
-> (Excepts SetCabalEffects (ReaderT env m) a)
|
||||
-> m (VEither SetCabalEffects a)
|
||||
runSetCabal runAppState =
|
||||
runAppState
|
||||
@@ -214,7 +215,7 @@ type SetHLSEffects = '[ NotInstalled
|
||||
, NoToolVersionSet]
|
||||
|
||||
runSetHLS :: (ReaderT env m (VEither SetHLSEffects a) -> m (VEither SetHLSEffects a))
|
||||
-> Excepts SetHLSEffects (ReaderT env m) a
|
||||
-> (Excepts SetHLSEffects (ReaderT env m) a)
|
||||
-> m (VEither SetHLSEffects a)
|
||||
runSetHLS runAppState =
|
||||
runAppState
|
||||
@@ -228,7 +229,7 @@ type SetStackEffects = '[ NotInstalled
|
||||
, NoToolVersionSet]
|
||||
|
||||
runSetStack :: (ReaderT env m (VEither SetStackEffects a) -> m (VEither SetStackEffects a))
|
||||
-> Excepts SetStackEffects (ReaderT env m) a
|
||||
-> (Excepts SetStackEffects (ReaderT env m) a)
|
||||
-> m (VEither SetStackEffects a)
|
||||
runSetStack runAppState =
|
||||
runAppState
|
||||
@@ -242,18 +243,15 @@ runSetStack runAppState =
|
||||
-------------------
|
||||
|
||||
|
||||
set :: forall m env.
|
||||
( Monad m
|
||||
set :: forall m . ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
)
|
||||
=> Either SetCommand SetOptions
|
||||
-> (forall eff . ReaderT AppState m (VEither eff GHCTargetVersion)
|
||||
-> m (VEither eff GHCTargetVersion))
|
||||
-> (forall eff. ReaderT env m (VEither eff GHCTargetVersion)
|
||||
-> (forall eff . ReaderT LeanAppState m (VEither eff GHCTargetVersion)
|
||||
-> m (VEither eff GHCTargetVersion))
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
|
||||
@@ -2,6 +2,10 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
@@ -45,7 +49,7 @@ type ToolRequirementsEffects = '[ NoCompatiblePlatform , DistroNotFound , NoTool
|
||||
|
||||
|
||||
runToolRequirements :: (ReaderT env m (VEither ToolRequirementsEffects a) -> m (VEither ToolRequirementsEffects a))
|
||||
-> Excepts ToolRequirementsEffects (ReaderT env m) a
|
||||
-> (Excepts ToolRequirementsEffects (ReaderT env m) a)
|
||||
-> m (VEither ToolRequirementsEffects a)
|
||||
runToolRequirements runAppState =
|
||||
runAppState
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
@@ -35,7 +36,6 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception.Safe (MonadMask)
|
||||
import GHCup.Types.Optics
|
||||
|
||||
|
||||
|
||||
@@ -72,7 +72,7 @@ data UnsetOptions = UnsetOptions
|
||||
|
||||
unsetParser :: Parser UnsetCommand
|
||||
unsetParser =
|
||||
subparser
|
||||
(subparser
|
||||
( command
|
||||
"ghc"
|
||||
( UnsetGHC
|
||||
@@ -110,6 +110,7 @@ unsetParser =
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
where
|
||||
unsetGHCFooter :: String
|
||||
unsetGHCFooter = [s|Discussion:
|
||||
@@ -155,7 +156,7 @@ type UnsetEffects = '[ NotInstalled ]
|
||||
|
||||
|
||||
runUnsetGHC :: (ReaderT env m (VEither UnsetEffects a) -> m (VEither UnsetEffects a))
|
||||
-> Excepts UnsetEffects (ReaderT env m) a
|
||||
-> (Excepts UnsetEffects (ReaderT env m) a)
|
||||
-> m (VEither UnsetEffects a)
|
||||
runUnsetGHC runLeanAppState =
|
||||
runLeanAppState
|
||||
@@ -174,11 +175,9 @@ unset :: ( Monad m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
, HasDirs env
|
||||
, HasLog env
|
||||
)
|
||||
=> UnsetCommand
|
||||
-> (ReaderT env m (VEither UnsetEffects ())
|
||||
-> (ReaderT LeanAppState m (VEither UnsetEffects ())
|
||||
-> m (VEither UnsetEffects ()))
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
|
||||
@@ -3,6 +3,9 @@
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
@@ -112,7 +113,7 @@ whereisP = subparser
|
||||
<>
|
||||
command
|
||||
"ghcup"
|
||||
(WhereisTool GHCup <$> info ( pure Nothing <**> helper ) ( progDesc "Get ghcup location" ))
|
||||
(WhereisTool GHCup <$> info ( (pure Nothing) <**> helper ) ( progDesc "Get ghcup location" ))
|
||||
) <|> subparser ( commandGroup "Directory locations:"
|
||||
<>
|
||||
command
|
||||
@@ -265,7 +266,7 @@ whereis :: ( Monad m
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
|
||||
Dirs{ .. } <- runReaderT getDirs leanAppstate
|
||||
VRight Dirs{ .. } <- runAppState (VRight <$> getDirs)
|
||||
case (whereisCommand, whereisOptions) of
|
||||
(WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
|
||||
runLeanWhereIs leanAppstate (do
|
||||
@@ -282,7 +283,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
|
||||
runLogger $ logError $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 30
|
||||
|
||||
(WhereisTool tool whereVer, WhereisOptions{..}) -> do
|
||||
(WhereisTool tool whereVer, WhereisOptions{..}) ->
|
||||
runWhereIs runAppState (do
|
||||
(v, _) <- liftE $ fromVersion whereVer tool
|
||||
loc <- liftE $ whereIsTool tool v
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
|
||||
@@ -111,7 +112,7 @@ plan_json = $( do
|
||||
c <- B.readFile fp
|
||||
(Just res) <- pure $ decodeStrict' @Value c
|
||||
pure (fp, T.unpack $ decUTF8Safe' $ encodePretty res))
|
||||
unless (null fp) $ qAddDependentFile fp
|
||||
when (not . null $ fp ) $ qAddDependentFile fp
|
||||
pure . LitE . StringL $ c)
|
||||
|
||||
|
||||
@@ -123,7 +124,8 @@ main = do
|
||||
void enableAnsiSupport
|
||||
|
||||
let versionHelp = infoOption
|
||||
( "The GHCup Haskell installer, version " <> (head . lines $ describe_result)
|
||||
( ("The GHCup Haskell installer, version " <>)
|
||||
(head . lines $ describe_result)
|
||||
)
|
||||
(long "version" <> help "Show version" <> hidden)
|
||||
let planJson = infoOption
|
||||
@@ -168,7 +170,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
(settings, keybindings) <- toSettings opt
|
||||
|
||||
-- logger interpreter
|
||||
logfile <- runReaderT initGHCupFileLogging dirs
|
||||
logfile <- flip runReaderT dirs initGHCupFileLogging
|
||||
no_color <- isJust <$> lookupEnv "NO_COLOR"
|
||||
let loggerConfig = LoggerConfig
|
||||
{ lcPrintDebug = verbose settings
|
||||
@@ -202,7 +204,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
ghcupInfo <-
|
||||
( flip runReaderT leanAppstate
|
||||
. runE @'[DigestError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
|
||||
$ liftE getDownloadsF
|
||||
$ liftE
|
||||
$ getDownloadsF
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> pure r
|
||||
@@ -212,7 +215,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
exitWith (ExitFailure 2)
|
||||
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
|
||||
|
||||
race_ (liftIO $ runReaderT cleanupTrash s')
|
||||
race_ (liftIO $ flip runReaderT s' cleanupTrash)
|
||||
(threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
|
||||
|
||||
case optCommand of
|
||||
@@ -226,11 +229,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
Interactive -> pure ()
|
||||
#endif
|
||||
_ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
|
||||
Nothing -> runReaderT checkForUpdates s'
|
||||
Nothing -> flip runReaderT s' checkForUpdates
|
||||
Just _ -> pure ()
|
||||
|
||||
-- TODO: always run for windows
|
||||
siletRunLogger (flip runReaderT s' $ runE ensureGlobalTools) >>= \case
|
||||
(siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
|
||||
VRight _ -> pure ()
|
||||
VLeft e -> do
|
||||
runLogger
|
||||
@@ -248,7 +251,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
#endif
|
||||
runAppState action' = do
|
||||
s' <- liftIO appState
|
||||
runReaderT action' s'
|
||||
flip runReaderT s' action'
|
||||
|
||||
|
||||
-----------------
|
||||
|
||||
Reference in New Issue
Block a user