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

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)