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 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 DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

View File

@@ -91,23 +91,23 @@ validate dls _ = do
checkHasRequiredPlatforms t v tags arch pspecs = do
let v' = prettyVer v
arch' = prettyShow arch
when (Linux UnknownLinux `notElem` pspecs) $ do
when (notElem (Linux UnknownLinux) pspecs) $ do
lift $ logError $
"Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
when ((Darwin `notElem` pspecs) && arch == A_64) $ do
when ((notElem Darwin pspecs) && arch == A_64) $ do
lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
when ((FreeBSD `notElem` pspecs) && arch == A_64) $ lift $ logWarn $
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ logWarn $
"FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
when (Windows `notElem` pspecs && arch == A_64) $ do
when (notElem Windows pspecs && arch == A_64) $ do
lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
-- alpine needs to be set explicitly, because
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
-- (although it could be static)
when (Linux Alpine `notElem` pspecs) $
when (notElem (Linux Alpine) pspecs) $
case t of
GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
Cabal | v > [vver|2.4.1.0|]
@@ -117,7 +117,7 @@ validate dls _ = do
_ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
checkUniqueTags tool = do
let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
let nonUnique =
fmap fst
. filter (\(_, b) -> not b)
@@ -155,8 +155,8 @@ validate dls _ = do
-- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do
let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
forM_ [Latest, Recommended] $ \t -> case t `elem` allTags of
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do
lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
addError
@@ -202,7 +202,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
let gdlis = nubOrd $ gt ^.. each
let allDls = either (const gdlis) (const dlis) etool
when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref
when (null allDls) $ logError "no tarballs selected by filter" *> (flip runReaderT ref addError)
forM_ allDls (downloadAll ref)
-- exit
@@ -260,7 +260,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
when (basePath /= prel) $ do
logError $
"Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
runReaderT addError ref
(flip runReaderT ref addError)
Just (RegexDir regexString) -> do
logInfo $
"verifying subdir (regex): " <> T.pack regexString
@@ -268,13 +268,13 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
compIgnoreCase
execBlank
regexString
unless (match regex basePath) $ do
when (not (match regex basePath)) $ do
logError $
"Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
runReaderT addError ref
(flip runReaderT ref addError)
Nothing -> pure ()
VRight Nothing -> pure ()
VLeft e -> do
logError $
"Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
runReaderT addError ref
(flip runReaderT ref addError)

View File

@@ -2,7 +2,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
module BrickMain where
@@ -365,7 +368,10 @@ listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
selectLatest :: Vector ListResult -> Int
selectLatest = fromMaybe 0 . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
selectLatest v =
case V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) v of
Just ix -> ix
Nothing -> 0
-- | Replace the @appState@ or construct it based on a filter function
@@ -392,14 +398,14 @@ filterVisible :: Bool -> Bool -> ListResult -> Bool
filterVisible v t e | lInstalled e = True
| v
, not t
, lTool e `notElem` hiddenTools = True
, not (elem (lTool e) hiddenTools) = True
| not v
, t
, Old `notElem` lTag e = True
, not (elem Old (lTag e)) = True
| v
, t = True
| otherwise = (Old `notElem` lTag e) &&
(lTool e `notElem` hiddenTools)
| otherwise = not (elem Old (lTag e)) &&
not (elem (lTool e) hiddenTools)
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
@@ -501,7 +507,7 @@ del' _ (_, ListResult {..}) = do
)
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
logInfo msg
pure $ Right ()
VLeft e -> pure $ Left (prettyShow e)
@@ -588,7 +594,8 @@ getGHCupInfo = do
r <-
flip runReaderT settings
. runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE getDownloadsF
$ liftE
$ getDownloadsF
case r of
VRight a -> pure $ Right a

View File

@@ -1,7 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
@@ -105,7 +109,7 @@ opts =
Options
<$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")
<*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
<*> optional
<*> (optional
(option
(eitherReader parseUri)
( short 's'
@@ -115,6 +119,7 @@ opts =
<> internal
)
)
)
<*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
<*> optional (option
(eitherReader keepOnParser)
@@ -159,10 +164,11 @@ com =
( command
"tui"
( (\_ -> Interactive)
<$> info
<$> (info
helper
( progDesc "Start the interactive GHCup UI"
)
)
)
<> command
#else

View File

@@ -2,6 +2,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}

View File

@@ -1,7 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
module GHCup.OptParse.Common where
@@ -156,7 +160,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32)
platformP :: MP.Parsec Void Text PlatformRequest
platformP = choice'
[ (`PlatformRequest` FreeBSD)
[ (\a mv -> PlatformRequest a FreeBSD mv)
<$> (archP <* MP.chunk "-")
<*> ( MP.chunk "portbld"
*> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof))
@@ -164,7 +168,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
)
<* MP.chunk "-freebsd"
)
, (`PlatformRequest` Darwin)
, (\a mv -> PlatformRequest a Darwin mv)
<$> (archP <* MP.chunk "-")
<*> ( MP.chunk "apple"
*> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof))
@@ -307,8 +311,11 @@ tagCompleter tool add = listIOCompleter $ do
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
case mGhcUpInfo of
VRight ghcupInfo -> do
let allTags = filter (/= Old)
$ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
let allTags = filter (\t -> t /= Old)
$ join
$ fmap _viTags
$ M.elems
$ availableToolVersions (_ghcupDownloads ghcupInfo) tool
pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add)
@@ -389,7 +396,7 @@ fromVersion' :: ( HasLog env
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' SetRecommended tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
?? TagNotFound Recommended tool
fromVersion' (SetToolVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@@ -400,18 +407,18 @@ fromVersion' (SetToolVersion v) tool = do
lift (getLatestToolFor tool pvpIn dls) >>= \case
Just (pvp_, vi') -> do
v' <- lift $ pvpToVersion pvp_
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
when (v' /= (_tvVersion v)) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion (_tvTarget v) v', Just vi')
Nothing -> pure (v, vi)
fromVersion' (SetToolTag Latest) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool
(\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolTag Recommended) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' (SetToolTag (Base pvp'')) GHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
(\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' SetNext tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
next <- case tool of
@@ -423,7 +430,7 @@ fromVersion' SetNext tool = do
. dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set)
. cycle
. sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
. filter (\GHCTargetVersion {..} -> isNothing _tvTarget)
. filter (\GHCTargetVersion {..} -> _tvTarget == Nothing)
$ ghcs) ?? NoToolVersionSet tool
Cabal -> do
set <- cabalSet !? NoToolVersionSet tool

View File

@@ -5,6 +5,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
@@ -507,7 +508,7 @@ compile compileCommand settings runAppState runLogger = do
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
_ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")

View File

@@ -2,6 +2,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}

View File

@@ -5,6 +5,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
@@ -83,7 +84,7 @@ prettyDebugInfo DebugInfo {..} = "Debug Info" <> "\n" <>
type DInfoEffects = '[ NoCompatiblePlatform , NoCompatibleArch , DistroNotFound ]
runDebugInfo :: (ReaderT env m (VEither DInfoEffects a) -> m (VEither DInfoEffects a))
-> Excepts DInfoEffects (ReaderT env m) a
-> (Excepts DInfoEffects (ReaderT env m) a)
-> m (VEither DInfoEffects a)
runDebugInfo runAppState =
runAppState

View File

@@ -5,6 +5,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
@@ -103,7 +104,7 @@ type GCEffects = '[ NotInstalled ]
runGC :: MonadUnliftIO m
=> (ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a))
-> Excepts GCEffects (ResourceT (ReaderT AppState m)) a
-> (Excepts GCEffects (ResourceT (ReaderT AppState m)) a)
-> m (VEither GCEffects a)
runGC runAppState =
runAppState

View File

@@ -2,6 +2,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -274,7 +275,7 @@ runInstTool appstate' mInstPlatform =
-------------------
install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
install :: (Either InstallCommand InstallOptions) -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
install installCommand settings getAppState' runLogger = case installCommand of
(Right iopts) -> do
runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
@@ -323,8 +324,8 @@ install installCommand settings getAppState' runLogger = case installCommand of
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger $ (logError $ T.pack $ prettyShow err)
_ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3

View File

@@ -1,7 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
@@ -95,7 +99,7 @@ printListResult :: Bool -> Bool -> [ListResult] -> IO ()
printListResult no_color raw lr = do
let
color | raw || no_color = (\_ x -> x)
color | raw || no_color = flip const
| otherwise = Pretty.color
let
@@ -130,7 +134,7 @@ printListResult no_color raw lr = do
, case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
, intercalate "," (filter (/= "") . fmap printTag $ sort lTag)
, intercalate "," $ (filter (/= "") . fmap printTag $ sort lTag)
, intercalate ","
$ (if hlsPowered
then [color Green "hls-powered"]
@@ -147,10 +151,10 @@ printListResult no_color raw lr = do
$ lr
let cols =
foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows
lengths = fmap (maximum . fmap strWidth) cols
lengths = fmap maximum . (fmap . fmap) strWidth $ cols
padded = fmap (\xs -> zipWith padTo xs lengths) rows
forM_ padded $ \row -> putStrLn $ unwords row
forM_ padded $ \row -> putStrLn $ intercalate " " row
where
padTo str' x =

View File

@@ -3,6 +3,9 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
@@ -46,7 +49,7 @@ type NukeEffects = '[ NotInstalled ]
runNuke :: AppState
-> Excepts NukeEffects (ReaderT AppState m) a
-> (Excepts NukeEffects (ReaderT AppState m) a)
-> m (VEither NukeEffects a)
runNuke s' =
flip runReaderT s' . runE @NukeEffects

View File

@@ -5,6 +5,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
@@ -84,7 +85,7 @@ prefetchP = subparser
<$> (PrefetchGHCOptions
<$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
<*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
<*> optional (toolVersionArgument Nothing (Just GHC)) )
<*> ( optional (toolVersionArgument Nothing (Just GHC)) ))
( progDesc "Download GHC assets for installation")
)
<>
@@ -117,7 +118,7 @@ prefetchP = subparser
<>
command
"metadata"
(PrefetchMetadata <$ info
(const PrefetchMetadata <$> info
helper
( progDesc "Download ghcup's metadata, needed for various operations")
)
@@ -161,7 +162,7 @@ type PrefetchEffects = '[ TagNotFound
runPrefetch :: MonadUnliftIO m
=> (ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a))
-> Excepts PrefetchEffects (ResourceT (ReaderT AppState m)) a
-> (Excepts PrefetchEffects (ResourceT (ReaderT AppState m)) a)
-> m (VEither PrefetchEffects a)
runPrefetch runAppState =
runAppState
@@ -196,20 +197,20 @@ prefetch prefetchCommand runAppState runLogger =
if pfGHCSrc
then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir
else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do
PrefetchCabal (PrefetchOptions {pfCacheDir}) mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt Cabal
liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir
PrefetchHLS PrefetchOptions {pfCacheDir} mt -> do
PrefetchHLS (PrefetchOptions {pfCacheDir}) mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt HLS
liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir
PrefetchStack PrefetchOptions {pfCacheDir} mt -> do
PrefetchStack (PrefetchOptions {pfCacheDir}) mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt Stack
liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
PrefetchMetadata -> do
_ <- liftE getDownloadsF
_ <- liftE $ getDownloadsF
pure ""
) >>= \case
VRight _ -> do

View File

@@ -5,6 +5,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
@@ -131,7 +132,7 @@ type RmEffects = '[ NotInstalled ]
runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))
-> Excepts RmEffects (ReaderT env m) a
-> (Excepts RmEffects (ReaderT env m) a)
-> m (VEither RmEffects a)
runRm runAppState =
runAppState
@@ -151,7 +152,7 @@ rm :: ( Monad m
, MonadUnliftIO m
, MonadFail m
)
=> Either RmCommand RmOptions
=> (Either RmCommand RmOptions)
-> (ReaderT AppState m (VEither RmEffects (Maybe VersionInfo))
-> m (VEither RmEffects (Maybe VersionInfo)))
-> (ReaderT LeanAppState m () -> m ())

View File

@@ -2,6 +2,8 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
@@ -40,7 +42,6 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Data.Bifunctor (second)
import Control.Exception.Safe (MonadMask)
import GHCup.Types.Optics
@@ -186,7 +187,7 @@ type SetGHCEffects = '[ FileDoesNotExistError
, NoToolVersionSet]
runSetGHC :: (ReaderT env m (VEither SetGHCEffects a) -> m (VEither SetGHCEffects a))
-> Excepts SetGHCEffects (ReaderT env m) a
-> (Excepts SetGHCEffects (ReaderT env m) a)
-> m (VEither SetGHCEffects a)
runSetGHC runAppState =
runAppState
@@ -200,7 +201,7 @@ type SetCabalEffects = '[ NotInstalled
, NoToolVersionSet]
runSetCabal :: (ReaderT env m (VEither SetCabalEffects a) -> m (VEither SetCabalEffects a))
-> Excepts SetCabalEffects (ReaderT env m) a
-> (Excepts SetCabalEffects (ReaderT env m) a)
-> m (VEither SetCabalEffects a)
runSetCabal runAppState =
runAppState
@@ -214,7 +215,7 @@ type SetHLSEffects = '[ NotInstalled
, NoToolVersionSet]
runSetHLS :: (ReaderT env m (VEither SetHLSEffects a) -> m (VEither SetHLSEffects a))
-> Excepts SetHLSEffects (ReaderT env m) a
-> (Excepts SetHLSEffects (ReaderT env m) a)
-> m (VEither SetHLSEffects a)
runSetHLS runAppState =
runAppState
@@ -228,7 +229,7 @@ type SetStackEffects = '[ NotInstalled
, NoToolVersionSet]
runSetStack :: (ReaderT env m (VEither SetStackEffects a) -> m (VEither SetStackEffects a))
-> Excepts SetStackEffects (ReaderT env m) a
-> (Excepts SetStackEffects (ReaderT env m) a)
-> m (VEither SetStackEffects a)
runSetStack runAppState =
runAppState
@@ -242,18 +243,15 @@ runSetStack runAppState =
-------------------
set :: forall m env.
( Monad m
set :: forall m . ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
, HasDirs env
, HasLog env
)
=> Either SetCommand SetOptions
-> (forall eff . ReaderT AppState m (VEither eff GHCTargetVersion)
-> m (VEither eff GHCTargetVersion))
-> (forall eff. ReaderT env m (VEither eff GHCTargetVersion)
-> (forall eff . ReaderT LeanAppState m (VEither eff GHCTargetVersion)
-> m (VEither eff GHCTargetVersion))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode

View File

@@ -2,6 +2,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
@@ -45,7 +49,7 @@ type ToolRequirementsEffects = '[ NoCompatiblePlatform , DistroNotFound , NoTool
runToolRequirements :: (ReaderT env m (VEither ToolRequirementsEffects a) -> m (VEither ToolRequirementsEffects a))
-> Excepts ToolRequirementsEffects (ReaderT env m) a
-> (Excepts ToolRequirementsEffects (ReaderT env m) a)
-> m (VEither ToolRequirementsEffects a)
runToolRequirements runAppState =
runAppState

View File

@@ -2,6 +2,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -35,7 +36,6 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import GHCup.Types.Optics
@@ -72,7 +72,7 @@ data UnsetOptions = UnsetOptions
unsetParser :: Parser UnsetCommand
unsetParser =
subparser
(subparser
( command
"ghc"
( UnsetGHC
@@ -110,6 +110,7 @@ unsetParser =
)
)
)
)
where
unsetGHCFooter :: String
unsetGHCFooter = [s|Discussion:
@@ -155,7 +156,7 @@ type UnsetEffects = '[ NotInstalled ]
runUnsetGHC :: (ReaderT env m (VEither UnsetEffects a) -> m (VEither UnsetEffects a))
-> Excepts UnsetEffects (ReaderT env m) a
-> (Excepts UnsetEffects (ReaderT env m) a)
-> m (VEither UnsetEffects a)
runUnsetGHC runLeanAppState =
runLeanAppState
@@ -174,11 +175,9 @@ unset :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
, HasDirs env
, HasLog env
)
=> UnsetCommand
-> (ReaderT env m (VEither UnsetEffects ())
-> (ReaderT LeanAppState m (VEither UnsetEffects ())
-> m (VEither UnsetEffects ()))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode

View File

@@ -3,6 +3,9 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}

View File

@@ -5,6 +5,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
@@ -112,7 +113,7 @@ whereisP = subparser
<>
command
"ghcup"
(WhereisTool GHCup <$> info ( pure Nothing <**> helper ) ( progDesc "Get ghcup location" ))
(WhereisTool GHCup <$> info ( (pure Nothing) <**> helper ) ( progDesc "Get ghcup location" ))
) <|> subparser ( commandGroup "Directory locations:"
<>
command
@@ -265,7 +266,7 @@ whereis :: ( Monad m
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
Dirs{ .. } <- runReaderT getDirs leanAppstate
VRight Dirs{ .. } <- runAppState (VRight <$> getDirs)
case (whereisCommand, whereisOptions) of
(WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
runLeanWhereIs leanAppstate (do
@@ -282,7 +283,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
(WhereisTool tool whereVer, WhereisOptions{..}) -> do
(WhereisTool tool whereVer, WhereisOptions{..}) ->
runWhereIs runAppState (do
(v, _) <- liftE $ fromVersion whereVer tool
loc <- liftE $ whereIsTool tool v

View File

@@ -5,6 +5,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
@@ -111,7 +112,7 @@ plan_json = $( do
c <- B.readFile fp
(Just res) <- pure $ decodeStrict' @Value c
pure (fp, T.unpack $ decUTF8Safe' $ encodePretty res))
unless (null fp) $ qAddDependentFile fp
when (not . null $ fp ) $ qAddDependentFile fp
pure . LitE . StringL $ c)
@@ -123,7 +124,8 @@ main = do
void enableAnsiSupport
let versionHelp = infoOption
( "The GHCup Haskell installer, version " <> (head . lines $ describe_result)
( ("The GHCup Haskell installer, version " <>)
(head . lines $ describe_result)
)
(long "version" <> help "Show version" <> hidden)
let planJson = infoOption
@@ -168,7 +170,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(settings, keybindings) <- toSettings opt
-- logger interpreter
logfile <- runReaderT initGHCupFileLogging dirs
logfile <- flip runReaderT dirs initGHCupFileLogging
no_color <- isJust <$> lookupEnv "NO_COLOR"
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
@@ -202,7 +204,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
ghcupInfo <-
( flip runReaderT leanAppstate
. runE @'[DigestError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE getDownloadsF
$ liftE
$ getDownloadsF
)
>>= \case
VRight r -> pure r
@@ -212,7 +215,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
exitWith (ExitFailure 2)
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
race_ (liftIO $ runReaderT cleanupTrash s')
race_ (liftIO $ flip runReaderT s' cleanupTrash)
(threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
case optCommand of
@@ -226,11 +229,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Interactive -> pure ()
#endif
_ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runReaderT checkForUpdates s'
Nothing -> flip runReaderT s' checkForUpdates
Just _ -> pure ()
-- TODO: always run for windows
siletRunLogger (flip runReaderT s' $ runE ensureGlobalTools) >>= \case
(siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
VRight _ -> pure ()
VLeft e -> do
runLogger
@@ -248,7 +251,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
#endif
runAppState action' = do
s' <- liftIO appState
runReaderT action' s'
flip runReaderT s' action'
-----------------