hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Chores

Browse Source
This commit is contained in:
Julian Ospald
2021-03-11 17:03:51 +01:00
parent 910d660732
commit d5b5f1fddd
30 changed files with 490 additions and 434 deletions
Download Patch File Download Diff File Expand all files Collapse all files

20
lib/GHCup/Download.hs
View File

@@ -127,7 +127,7 @@ getDownloadsF urlSource = do
GHCupURL -> liftE getBase
(OwnSource url) -> do
bs <- reThrowAll DownloadFailed $ downloadBS url
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
(OwnSpec av) -> pure av
(AddSource (Left ext)) -> do
base <- liftE getBase
@@ -135,7 +135,7 @@ getDownloadsF urlSource = do
(AddSource (Right uri)) -> do
base <- liftE getBase
bsExt <- reThrowAll DownloadFailed $ downloadBS uri
ext <- lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bsExt)
ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt)
pure (mergeGhcupInfo base ext)
where
@@ -164,7 +164,7 @@ readFromCache = do
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
$ liftIO
$ readFile yaml_file
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
@@ -173,8 +173,8 @@ getBase =
handleIO (\_ -> readFromCache)
$ catchE @_ @'[JSONError, FileDoesNotExistError]
(\(DownloadFailed _) -> readFromCache)
$ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL)
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict))
(reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL)
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict))
where
-- First check if the json file is in the ~/.ghcup/cache dir
-- and check it's access time. If it has been accessed within the
@@ -312,8 +312,8 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
in fmap snd
. find
(\(mverRange, _) -> maybe
(mv' == Nothing)
(\range -> maybe False (flip versionRange range) mv')
(isNothing mv')
(\range -> maybe False (`versionRange` range) mv')
mverRange
)
. M.toList
@@ -365,7 +365,7 @@ download dli dest mfn
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e ->
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
liftIO (hideError doesNotExistErrorType $ deleteFile destFile)
>> (throwE . DownloadFailed $ e)
) $ do
lift getDownloader >>= \case
@@ -416,7 +416,7 @@ downloadCached dli mfn = do
if
| fileExists -> do
liftE $ checkDigest dli cachfile
pure $ cachfile
pure cachfile
| otherwise -> liftE $ download dli cacheDir mfn
False -> do
tmp <- lift withGHCupTmpDir
@@ -453,7 +453,7 @@ downloadBS uri'
= dl False
| scheme == "file"
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
$ (liftIO $ RD.readFile path)
(liftIO $ RD.readFile path)
| otherwise
= throwE UnsupportedScheme

16
lib/GHCup/Download/IOStreams.hs
View File

@@ -1,10 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
@@ -72,7 +68,7 @@ downloadBS' :: MonadIO m
, TooManyRedirs
]
m
(L.ByteString)
L.ByteString
downloadBS' https host path port = do
bref <- liftIO $ newIORef (mempty :: Builder)
let stepper bs = modifyIORef bref (<> byteString bs)
@@ -132,7 +128,7 @@ downloadInternal = go (5 :: Int)
if
| scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
| scode >= 300 && scode < 400 -> case getHeader r "Location" of
Just r' -> pure $ Just $ r'
Just r' -> pure $ Just r'
Nothing -> throwE NoLocationHeader
| otherwise -> throwE $ HTTPStatusError scode
)
@@ -151,7 +147,7 @@ downloadInternal = go (5 :: Int)
Nothing -> 0
mpb <- if progressBar
then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
then Just <$> liftIO (newProgressBar defStyle 10 (Progress 0 size ()))
else pure Nothing
outStream <- liftIO $ Streams.makeOutputStream
@@ -224,9 +220,9 @@ headInternal = go (5 :: Int)
if
| scode >= 200 && scode < 300 -> do
let headers = getHeaderMap r
pure $ Right $ headers
pure $ Right headers
| scode >= 300 && scode < 400 -> case getHeader r "Location" of
Just r' -> pure $ Left $ r'
Just r' -> pure $ Left r'
Nothing -> throwE NoLocationHeader
| otherwise -> throwE $ HTTPStatusError scode
)
@@ -243,7 +239,7 @@ withConnection' :: Bool
-> Maybe Int
-> (Connection -> IO a)
-> IO a
withConnection' https host port action = bracket acquire closeConnection action
withConnection' https host port = bracket acquire closeConnection
where
acquire = case https of

6
lib/GHCup/Download/Utils.hs
View File

@@ -1,10 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
@@ -55,7 +51,7 @@ uriToQuadruple URI {..} = do
let queryBS =
BS.intercalate "&"
. fmap (\(x, y) -> encodeQuery x <> "=" <> encodeQuery y)
$ (queryPairs uriQuery)
$ queryPairs uriQuery
port =
preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
fullpath = if BS.null queryBS then uriPath else uriPath <> "?" <> queryBS

3
lib/GHCup/Errors.hs
View File

@@ -1,12 +1,11 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-|

11
lib/GHCup/Platform.hs
View File

@@ -92,17 +92,16 @@ getPlatform = do
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
"darwin" -> do
ver <-
( either (const Nothing) Just
either (const Nothing) Just
. versioning
-- TODO: maybe do this somewhere else
. getMajorVersion
. decUTF8Safe
)
<$> getDarwinVersion
<$> getDarwinVersion
pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
"freebsd" -> do
ver <-
(either (const Nothing) Just . versioning . decUTF8Safe)
either (const Nothing) Just . versioning . decUTF8Safe
<$> getFreeBSDVersion
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
what -> throwE $ NoCompatiblePlatform what
@@ -157,7 +156,7 @@ getLinuxDistro = do
try_os_release :: IO (Text, Maybe Text)
try_os_release = do
Just (OsRelease { name = name, version_id = version_id }) <-
Just OsRelease{ name = name, version_id = version_id } <-
fmap osRelease <$> parseOsRelease
pure (T.pack name, fmap T.pack version_id)
@@ -174,7 +173,7 @@ getLinuxDistro = do
let nameRegex n =
makeRegexOpts compIgnoreCase
execBlank
(([s|\<|] <> fS n <> [s|\>|] :: ByteString)) :: Regex
([s|\<|] <> fS n <> [s|\>|] :: ByteString) :: Regex
let verRegex =
makeRegexOpts compIgnoreCase
execBlank

4
lib/GHCup/Requirements.hs
View File

@@ -49,8 +49,8 @@ getCommonRequirements pr tr =
in fmap snd
. find
(\(mverRange, _) -> maybe
(mv' == Nothing)
(\range -> maybe False (flip versionRange range) mv')
(isNothing mv')
(\range -> maybe False (`versionRange` range) mv')
mverRange
)
. M.toList

2
lib/GHCup/Types.hs
View File

@@ -365,7 +365,7 @@ pfReqToString (PlatformRequest arch plat ver) =
archToString arch ++ "-" ++ platformToString plat ++ pver
where
pver = case ver of
Just v' -> "-" ++ (T.unpack $ prettyV v')
Just v' -> "-" ++ T.unpack (prettyV v')
Nothing -> ""
instance Pretty PlatformRequest where

10
lib/GHCup/Types/JSON.hs
View File

@@ -148,7 +148,7 @@ instance FromJSONKey Platform where
$ "Unexpected failure in decoding LinuxDistro: "
<> show dstr
Nothing -> fail "Unexpected failure in Platform stripPrefix"
| otherwise -> fail $ "Failure in Platform (FromJSONKey)"
| otherwise -> fail "Failure in Platform (FromJSONKey)"
instance ToJSONKey Architecture where
toJSONKey = genericToJSONKey defaultJSONKeyOptions
@@ -272,7 +272,7 @@ verRangeToText (SimpleRange cmps) =
(versionCmpToText <$> NE.toList cmps)
in "( " <> inner <> " )"
verRangeToText (OrRange cmps range) =
let left = verRangeToText $ (SimpleRange cmps)
let left = verRangeToText (SimpleRange cmps)
right = verRangeToText range
in left <> " || " <> right
@@ -288,7 +288,7 @@ versionRangeP = go <* MP.eof
go =
MP.try orParse
<|> MP.try (fmap SimpleRange andParse)
<|> (fmap (SimpleRange . pure) versionCmpP)
<|> fmap (SimpleRange . pure) versionCmpP
orParse :: MP.Parsec Void T.Text VersionRange
orParse =
@@ -300,9 +300,7 @@ versionRangeP = go <* MP.eof
andParse =
fmap (\h t -> h :| t)
(MPC.space *> MP.chunk "(" *> MPC.space *> versionCmpP)
<*> ( MP.try
$ MP.many (MPC.space *> MP.chunk "&&" *> MPC.space *> versionCmpP)
)
<*> MP.try (MP.many (MPC.space *> MP.chunk "&&" *> MPC.space *> versionCmpP))
<* MPC.space
<* MP.chunk ")"
<* MPC.space

106
lib/GHCup/Utils.hs
View File

@@ -121,13 +121,13 @@ rmMinorSymlinks :: ( MonadReader AppState m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
rmMinorSymlinks tv@(GHCTargetVersion {..}) = do
rmMinorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> verToBS _tvVersion)
let fullF = (binDir </> f_xyz)
let fullF = binDir </> f_xyz
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
@@ -147,11 +147,11 @@ rmPlain target = do
forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do
let fullF = (binDir </> f)
let fullF = binDir </> f
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- old ghcup
let hdc_file = (binDir </> [rel|haddock-ghc|])
let hdc_file = binDir </> [rel|haddock-ghc|]
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
@@ -166,7 +166,7 @@ rmMajorSymlinks :: ( MonadReader AppState m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
rmMajorSymlinks tv@(GHCTargetVersion {..}) = do
rmMajorSymlinks tv@GHCTargetVersion{..} = do
AppState { dirs = Dirs {..} } <- lift ask
(mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi
@@ -174,7 +174,7 @@ rmMajorSymlinks tv@(GHCTargetVersion {..}) = do
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do
f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> E.encodeUtf8 v')
let fullF = (binDir </> f_xyz)
let fullF = binDir </> f_xyz
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
@@ -212,7 +212,7 @@ ghcSet mtarget = do
-- link destination is of the form ../ghc/<ver>/bin/ghc
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
link <- readSymbolicLink $ toFilePath ghcBin
Just <$> ghcLinkVersion link
@@ -256,7 +256,7 @@ getInstalledCabals = do
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
vs <- forM bins $ \f -> case fmap version (fmap decUTF8Safe . B.stripPrefix "cabal-" . toFilePath $ f) of
vs <- forM bins $ \f -> case fmap (version . decUTF8Safe) . B.stripPrefix "cabal-" . toFilePath $ f of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
@@ -267,8 +267,8 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed.
cabalInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
cabalInstalled ver = do
vers <- fmap rights $ getInstalledCabals
pure $ elem ver $ vers
vers <- fmap rights getInstalledCabals
pure $ elem ver vers
-- Return the currently set cabal version, if any.
@@ -279,7 +279,7 @@ cabalSet = do
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
if
| b -> do
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- isBrokenSymlink cabalbin
if broken
then pure Nothing
@@ -321,23 +321,20 @@ getInstalledHLSs = do
execBlank
([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
)
vs <- forM bins $ \f ->
forM bins $ \f ->
case
fmap
version
(fmap decUTF8Safe . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f)
fmap (version . decUTF8Safe) . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
pure $ vs
-- | Whether the given HLS version is installed.
hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
hlsInstalled ver = do
vers <- fmap rights $ getInstalledHLSs
pure $ elem ver $ vers
vers <- fmap rights getInstalledHLSs
pure $ elem ver vers
@@ -347,7 +344,7 @@ hlsSet = do
AppState {dirs = Dirs {..}} <- ask
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- isBrokenSymlink hlsBin
if broken
then pure Nothing
@@ -376,15 +373,13 @@ hlsGHCVersions = do
vers <- forM h $ \h' -> do
bins <- hlsServerBinaries h'
pure $ fmap
(\bin ->
version
. decUTF8Safe
. fromJust
. B.stripPrefix "haskell-language-server-"
. head
. B.split _tilde
. toFilePath
$ bin
(version
. decUTF8Safe
. fromJust
. B.stripPrefix "haskell-language-server-"
. head
. B.split _tilde
. toFilePath
)
bins
pure . rights . concat . maybeToList $ vers
@@ -421,7 +416,7 @@ hlsWrapperBinary ver = do
)
)
case wrapper of
[] -> pure $ Nothing
[] -> pure Nothing
[x] -> pure $ Just x
_ -> throwM $ UnexpectedListLength
"There were multiple hls wrapper binaries for a single version"
@@ -498,12 +493,8 @@ getLatestGHCFor :: Int -- ^ major version component
-> Int -- ^ minor version component
-> GHCupDownloads
-> Maybe (Version, VersionInfo)
getLatestGHCFor major' minor' dls = do
join
. fmap (lastMay . filter (\(v, _) -> matchMajor v major' minor'))
. preview (ix GHC % to Map.toDescList)
$ dls
getLatestGHCFor major' minor' dls =
preview (ix GHC % to Map.toDescList) dls >>= lastMay . filter (\(v, _) -> matchMajor v major' minor')
@@ -524,7 +515,7 @@ unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
#endif
] m ()
unpackToDir dest av = do
fp <- (decUTF8Safe . toFilePath) <$> basename av
fp <- decUTF8Safe . toFilePath <$> basename av
let dfp = decUTF8Safe . toFilePath $ dest
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
fn <- toFilePath <$> basename av
@@ -570,9 +561,9 @@ intoSubdir bdir tardir = case tardir of
let rs = splitOn "/" r
foldlM
(\y x ->
(fmap sort . handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= \case
(handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
[] -> throwE $ TarDirDoesNotExist tardir
(p : _) -> pure (y </> p)
(p : _) -> pure (y </> p)) . sort
)
bdir
rs
@@ -591,16 +582,15 @@ intoSubdir bdir tardir = case tardir of
getTagged :: Tag
-> AffineFold (Map.Map Version VersionInfo) (Version, VersionInfo)
getTagged tag =
( to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
to (Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
% to Map.toDescList
% _head
)
getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatest av tool = headOf (ix tool % getTagged Latest) $ av
getLatest av tool = headOf (ix tool % getTagged Latest) av
getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getRecommended av tool = headOf (ix tool % getTagged Recommended) $ av
getRecommended av tool = headOf (ix tool % getTagged Recommended) av
-- | Gets the latest GHC with a given base version.
@@ -671,10 +661,10 @@ ghcToolFiles ver = do
then pure id
else do
(Just symver) <-
(B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName)
<$> (liftIO $ readSymbolicLink $ toFilePath ghcbinPath)
B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName
<$> liftIO (readSymbolicLink $ toFilePath ghcbinPath)
when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
(throwIO $ userError "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x)
pure $ onlyUnversioned files
@@ -699,8 +689,8 @@ make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
-> Maybe (Path Abs)
-> m (Either ProcessError ())
make args workdir = do
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|])
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
let mymake = if has_gmake then "gmake" else "make"
execLogged mymake True args [rel|ghc-make|] workdir Nothing
@@ -715,13 +705,13 @@ applyPatches pdir ddir = do
patches <- liftIO $ getDirsFiles pdir
forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) [i|Applying patch #{patch'}|]
(fmap (either (const Nothing) Just) $ liftIO $ exec
"patch"
True
["-p1", "-i", toFilePath patch']
(Just ddir)
Nothing
)
fmap (either (const Nothing) Just)
(liftIO $ exec
"patch"
True
["-p1", "-i", toFilePath patch']
(Just ddir)
Nothing)
!? PatchFailed
@@ -767,8 +757,7 @@ runBuildAction bdir instdir action = do
(\es -> do
exAction
throwE (BuildFailed bdir es)
)
$ action
) action
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
bdir
@@ -800,14 +789,13 @@ getVersionInfo :: Version
-> Tool
-> GHCupDownloads
-> Maybe VersionInfo
getVersionInfo v' tool dls =
getVersionInfo v' tool =
headOf
( ix tool
% to (Map.filterWithKey (\k _ -> k == v'))
% to Map.elems
% _head
)
dls
-- Gathering monoidal values
@@ -816,4 +804,4 @@ traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
-- | Gathering monoidal values
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forFold = \t -> \f -> traverseFold f t
forFold = \t -> (`traverseFold` t)

6
lib/GHCup/Utils/Dirs.hs
View File

@@ -190,7 +190,7 @@ ghcupConfigFile = do
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
case bs of
Nothing -> pure defaultUserSettings
Just bs' -> lE' JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict $ bs'
Just bs' -> lE' JSONDecodeError . first show . Y.decodeEither' . L.toStrict $ bs'
-------------------------
@@ -228,7 +228,7 @@ parseGHCupGHCDir (toFilePath -> f) = do
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> "ghcup-")
tmp <- liftIO $ mkdtemp (tmpdir FP.</> "ghcup-")
parseAbs tmp
@@ -266,7 +266,7 @@ relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
cPrefix = drop (length common) d1
in joinPath (replicate (length cPrefix) "..")
<> joinPath ("/" : (drop (length common) d2))
<> joinPath ("/" : drop (length common) d2)

39
lib/GHCup/Utils/File.hs
View File

@@ -107,12 +107,14 @@ makeLenses ''CapturedProcess
-- PATH does.
findExecutable :: Path Rel -> IO (Maybe (Path Abs))
findExecutable ex = do
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
sPaths <- fmap (catMaybes . fmap parseAbs) getSearchPath
-- We don't want exceptions to mess up our result. If we can't
-- figure out if a file exists, then treat it as a negative result.
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
-- asum for short-circuiting behavior
(\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
asum $ fmap
(handleIO (\_ -> pure Nothing)
-- asum for short-circuiting behavior
. (\s' -> (isExecutable (s' </> ex) >>= guard) $> Just (s' </> ex))
)
sPaths
@@ -150,11 +152,12 @@ execLogged exe spath args lfile chdir env = do
void
$ forkIO
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip EX.finally (putMVar done ())
$ (if verbose
then tee fd stdoutRead
else printToRegion fd stdoutRead 6 pState
)
$ EX.finally
(if verbose
then tee fd stdoutRead
else printToRegion fd stdoutRead 6 pState
)
(putMVar done ())
-- fork the subprocess
pid <- SPPB.forkProcess $ do
@@ -203,7 +206,7 @@ execLogged exe spath args lfile chdir env = do
$ handle
(\(ex :: SomeException) -> do
ps <- liftIO $ takeMVar pState
when (ps == True) (forM_ rs (liftIO . closeConsoleRegion))
when ps (forM_ rs (liftIO . closeConsoleRegion))
throw ex
)
$ readTilEOF (lineAction rs) fdIn
@@ -247,7 +250,7 @@ execLogged exe spath args lfile chdir env = do
=> Fd -- ^ input file descriptor
-> ByteString -- ^ rest buffer (read across newline)
-> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
readLine fd = \inBs -> go inBs
readLine fd = go
where
go inBs = do
-- if buffer is not empty, process it first
@@ -275,7 +278,7 @@ execLogged exe spath args lfile chdir env = do
(bs, rest, eof) <- readLine fd' bs'
if eof
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
else (void $ action' bs) >> go rest
else void (action' bs) >> go rest
-- | Capture the stdout and stderr of the given action, which
@@ -329,7 +332,7 @@ captureOutStreams action = do
, _stdErr = stderr'
}
_ -> throwIO $ userError $ ("No such PID " ++ show pid)
_ -> throwIO $ userError ("No such PID " ++ show pid)
where
writeStds pout perr rout rerr = do
@@ -356,7 +359,7 @@ captureOutStreams action = do
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
actionWithPipes a =
createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
cleanup :: [Fd] -> IO ()
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
@@ -423,7 +426,7 @@ isShadowed :: Path Abs -> IO (Maybe (Path Abs))
isShadowed p = do
let dir = dirname p
fn <- basename p
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
if dir `elem` spaths
then do
let shadowPaths = takeWhile (/= dir) spaths
@@ -437,7 +440,7 @@ isInPath :: Path Abs -> IO Bool
isInPath p = do
let dir = dirname p
fn <- basename p
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
if dir `elem` spaths
then isJust <$> searchPath [dir] fn
else pure False
@@ -451,7 +454,7 @@ findFiles path regex = do
. S.toList
. S.filter (\(_, p) -> match regex p)
$ dirContentsStream dirStream
pure $ join $ fmap parseRel f
pure $ parseRel =<< f
findFiles' :: Path Abs -> MP.Parsec Void Text () -> IO [Path Rel]
@@ -464,7 +467,7 @@ findFiles' path parser = do
Left _ -> False
Right p' -> isJust $ MP.parseMaybe parser p')
$ dirContentsStream dirStream
pure $ join $ fmap parseRel f
pure $ parseRel =<< f
isBrokenSymlink :: Path Abs -> IO Bool

3
lib/GHCup/Utils/Logger.hs
View File

@@ -1,4 +1,3 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-|
@@ -51,7 +50,7 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
when (lcPrintDebug || (not lcPrintDebug && (level /= LevelDebug)))
$ colorOutter out
-- raw output

20
lib/GHCup/Utils/MegaParsec.hs
View File

@@ -15,7 +15,6 @@ module GHCup.Utils.MegaParsec where
import GHCup.Types
import Control.Applicative
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
@@ -61,9 +60,9 @@ ghcTargetBinP :: Text -> MP.Parsec Void Text (Maybe Text, Text)
ghcTargetBinP t =
(,)
<$> ( MP.try
(Just <$> (parseUntil1 (MP.chunk "-" *> MP.chunk t)) <* MP.chunk "-"
(Just <$> parseUntil1 (MP.chunk "-" *> MP.chunk t) <* MP.chunk "-"
)
<|> (flip const Nothing <$> mempty)
<|> ((\ _ x -> x) Nothing <$> mempty)
)
<*> (MP.chunk t <* MP.eof)
@@ -74,8 +73,8 @@ ghcTargetBinP t =
ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion
ghcTargetVerP =
(\x y -> GHCTargetVersion x y)
<$> (MP.try (Just <$> (parseUntil1 (MP.chunk "-" *> verP')) <* MP.chunk "-")
<|> (flip const Nothing <$> mempty)
<$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
<|> ((\ _ x -> x) Nothing <$> mempty)
)
<*> (version' <* MP.eof)
where
@@ -85,16 +84,15 @@ ghcTargetVerP =
let startsWithDigists =
and
. take 3
. join
. (fmap . fmap)
. concatMap
(map
(\case
(Digits _) -> True
(Str _) -> False
)
. fmap NE.toList
) . NE.toList)
. NE.toList
$ (_vChunks v)
if startsWithDigists && not (isJust (_vEpoch v))
$ _vChunks v
if startsWithDigists && isNothing (_vEpoch v)
then pure $ prettyVer v
else fail "Oh"

17
lib/GHCup/Utils/Prelude.hs
View File

@@ -1,10 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
@@ -131,7 +128,7 @@ lE' :: forall e' e es a m
=> (e' -> e)
-> Either e' a
-> Excepts es m a
lE' f = liftE . veitherToExcepts . fromEither . bimap f id
lE' f = liftE . veitherToExcepts . fromEither . first f
lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
lEM em = lift em >>= lE
@@ -141,7 +138,7 @@ lEM' :: forall e' e es a m
=> (e' -> e)
-> m (Either e' a)
-> Excepts es m a
lEM' f em = lift em >>= lE . bimap f id
lEM' f em = lift em >>= lE . first f
fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight
@@ -200,8 +197,8 @@ hideExcept :: forall e es es' a m
-> a
-> Excepts es m a
-> Excepts es' m a
hideExcept _ a action =
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
hideExcept _ a =
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a))
hideExcept' :: forall e es es' m
@@ -209,8 +206,8 @@ hideExcept' :: forall e es es' m
=> e
-> Excepts es m ()
-> Excepts es' m ()
hideExcept' _ action =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
hideExcept' _ =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ()))
reThrowAll :: forall e es es' a m
@@ -259,7 +256,7 @@ addToCurrentEnv :: MonadIO m
=> [(ByteString, ByteString)]
-> m [(ByteString, ByteString)]
addToCurrentEnv adds = do
cEnv <- liftIO $ getEnvironment
cEnv <- liftIO getEnvironment
pure (adds ++ cEnv)

4
lib/GHCup/Utils/Version/QQ.hs
View File

@@ -57,7 +57,7 @@ deriving instance Lift (NonEmpty Word)
qq :: (Text -> Q Exp) -> QuasiQuoter
qq quoteExp' = QuasiQuoter
{ quoteExp = (\s -> quoteExp' . T.pack $ s)
{ quoteExp = \s -> quoteExp' . T.pack $ s
, quotePat = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType = \_ ->
@@ -101,4 +101,4 @@ liftText :: T.Text -> Q Exp
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
liftDataWithText :: Data a => a -> Q Exp
liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)
liftDataWithText = dataToExpQ (fmap liftText . cast)