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