Compare commits

..

2 Commits

Author SHA1 Message Date
e88e131b9d Update .gitignore 2021-10-17 16:13:27 +02:00
4c7c9ab62e Refactor app Main 2021-10-17 16:11:36 +02:00
22 changed files with 127 additions and 81 deletions

View File

@@ -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/

View File

@@ -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 #-}

View File

@@ -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)

View File

@@ -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

View File

@@ -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

View File

@@ -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 #-}

View File

@@ -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

View File

@@ -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.")

View File

@@ -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 #-}

View File

@@ -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

View File

@@ -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

View File

@@ -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

View File

@@ -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 =

View File

@@ -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

View File

@@ -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

View File

@@ -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 ())

View File

@@ -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

View File

@@ -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

View File

@@ -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

View File

@@ -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 #-}

View File

@@ -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

View File

@@ -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'
----------------- -----------------