Jo

lib/GHCup/Utils/Dirs.hs

@@ -76,7 +76,6 @@ withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
 withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
 
 
-
     --------------
     --[ Others ]--
     --------------

lib/GHCup/Utils/File.hs

@@ -134,7 +134,7 @@ execLogged exe spath args lfile chdir env = do
 
 
     SPPB.getProcessStatus True True pid >>= \case
-      i@(Just (SPPB.Exited es)) -> pure $ toProcessError exe args i
+      i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
       i                         -> pure $ toProcessError exe args i
 
 

lib/GHCup/Utils/Logger.hs

@@ -4,6 +4,7 @@ module GHCup.Utils.Logger where
 
 import           GHCup.Utils
 
+import           Control.Monad
 import           Control.Monad.Logger
 import           HPath
 import           HPath.IO
@@ -28,15 +29,15 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
   mylogger _ _ level str' = do
     -- color output
     let l = case level of
-          LevelDebug -> if lcPrintDebug
-            then toLogStr (style Bold $ color Blue "[ Debug ]")
-            else mempty
+          LevelDebug   -> toLogStr (style Bold $ color Blue "[ Debug ]")
           LevelInfo    -> toLogStr (style Bold $ color Green "[ Info  ]")
           LevelWarn    -> toLogStr (style Bold $ color Yellow "[ Warn  ]")
           LevelError   -> toLogStr (style Bold $ color Red "[ Error ]")
           LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
     let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
-    colorOutter out
+
+    when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
+      $ colorOutter out
 
     -- raw output
     let lr = case level of

lib/GHCup/Utils/Prelude.hs

@@ -1,11 +1,12 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveLift #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveLift          #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE QuasiQuotes         #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
 
 module GHCup.Utils.Prelude where
 
@@ -23,6 +24,7 @@ import           Data.Versions
 import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
 import           System.IO.Error
+import           System.Posix.Env.ByteString    ( getEnvironment )
 
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Strict.Maybe             as S
@@ -136,17 +138,17 @@ fromEither :: Either a b -> VEither '[a] b
 fromEither = either (VLeft . V) VRight
 
 
-liftException :: ( MonadCatch m
-                 , MonadIO m
-                 , Monad m
-                 , e :< es'
-                 , LiftVariant es es'
-                 )
-              => IOErrorType
-              -> e
-              -> Excepts es m a
-              -> Excepts es' m a
-liftException errType ex =
+liftIOException' :: ( MonadCatch m
+                    , MonadIO m
+                    , Monad m
+                    , e :< es'
+                    , LiftVariant es es'
+                    )
+                 => IOErrorType
+                 -> e
+                 -> Excepts es m a
+                 -> Excepts es' m a
+liftIOException' errType ex =
   handleIO
       (\e ->
         if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
@@ -154,6 +156,19 @@ liftException errType ex =
     . liftE
 
 
+liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es')
+                => IOErrorType
+                -> e
+                -> m a
+                -> Excepts es' m a
+liftIOException errType ex =
+  handleIO
+      (\e ->
+        if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
+      )
+    . lift
+
+
 hideErrorDef :: IOErrorType -> a -> IO a -> IO a
 hideErrorDef err def =
   handleIO (\e -> if err == ioeGetErrorType e then pure def else ioError e)
@@ -174,6 +189,7 @@ hideExcept :: forall e es es' a m
 hideExcept _ a action =
   catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
 
+
 hideExcept' :: forall e es es' m
              . (Monad m, e :< es, LiftVariant (Remove e es) es')
             => e
@@ -183,6 +199,23 @@ hideExcept' _ action =
   catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
 
 
+reThrowAll :: forall e es es' a m
+            . (Monad m, e :< es')
+           => (V es -> e)
+           -> Excepts es m a
+           -> Excepts es' m a
+reThrowAll f = catchAllE (throwE . f)
+
+
+reThrowAllIO :: forall e es es' a m
+              . (MonadCatch m, Monad m, MonadIO m, e :< es')
+             => (V es -> e)
+             -> (IOException -> e)
+             -> Excepts es m a
+             -> Excepts es' m a
+reThrowAllIO f g = handleIO (throwE . g) . catchAllE (throwE . f)
+
+
 throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
 throwEither a = case a of
   Left  e -> throwM e
@@ -200,3 +233,11 @@ intToText = TL.toStrict . B.toLazyText . B.decimal
 removeLensFieldLabel :: String -> String
 removeLensFieldLabel str' =
   maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
+
+
+addToCurrentEnv :: MonadIO m
+                => [(ByteString, ByteString)]
+                -> m [(ByteString, ByteString)]
+addToCurrentEnv adds = do
+  cEnv <- liftIO $ getEnvironment
+  pure (adds ++ cEnv)