ghcup-hs/lib/GHCup/Utils/Prelude.hs

244 lines
6.5 KiB
Haskell
Raw Normal View History

2020-03-08 17:30:08 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
2020-02-24 13:56:13 +00:00
{-# LANGUAGE ScopedTypeVariables #-}
2020-03-08 17:30:08 +00:00
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
2020-01-14 21:55:34 +00:00
2020-03-03 00:59:19 +00:00
module GHCup.Utils.Prelude where
2020-01-14 21:55:34 +00:00
import Control.Applicative
2020-03-01 00:05:02 +00:00
import Control.Exception.Safe
2020-01-16 22:27:38 +00:00
import Control.Monad
2020-02-29 23:07:39 +00:00
import Control.Monad.IO.Class
2020-02-18 08:40:01 +00:00
import Control.Monad.Trans.Class ( lift )
2020-02-28 23:33:32 +00:00
import Data.Bifunctor
2020-02-24 13:56:13 +00:00
import Data.ByteString ( ByteString )
2020-01-14 21:55:34 +00:00
import Data.Monoid ( (<>) )
2020-01-16 22:27:38 +00:00
import Data.String
import Data.Text ( Text )
2020-02-22 18:21:10 +00:00
import Data.Versions
2020-02-29 23:07:39 +00:00
import Haskus.Utils.Types.List
2020-02-18 08:40:01 +00:00
import Haskus.Utils.Variant.Excepts
2020-03-01 00:05:02 +00:00
import System.IO.Error
2020-03-08 17:30:08 +00:00
import System.Posix.Env.ByteString ( getEnvironment )
2020-03-01 00:05:02 +00:00
import qualified Data.ByteString.Lazy as L
import qualified Data.Strict.Maybe as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Lazy.Encoding as TLE
2020-01-16 22:27:38 +00:00
2020-01-14 21:55:34 +00:00
2020-01-17 22:29:16 +00:00
fS :: IsString a => String -> a
2020-01-14 21:55:34 +00:00
fS = fromString
2020-01-17 22:29:16 +00:00
fromStrictMaybe :: S.Maybe a -> Maybe a
fromStrictMaybe = S.maybe Nothing Just
2020-01-14 21:55:34 +00:00
2020-01-17 22:29:16 +00:00
fSM :: S.Maybe a -> Maybe a
2020-01-16 22:27:38 +00:00
fSM = fromStrictMaybe
2020-01-17 22:29:16 +00:00
toStrictMaybe :: Maybe a -> S.Maybe a
toStrictMaybe = maybe S.Nothing S.Just
2020-01-14 21:55:34 +00:00
2020-01-17 22:29:16 +00:00
tSM :: Maybe a -> S.Maybe a
2020-01-16 22:27:38 +00:00
tSM = toStrictMaybe
2020-01-17 22:29:16 +00:00
internalError :: String -> IO a
internalError = fail . ("Internal error: " <>)
2020-01-14 21:55:34 +00:00
2020-01-17 22:29:16 +00:00
iE :: String -> IO a
iE = internalError
2020-01-14 21:55:34 +00:00
2020-02-22 18:21:10 +00:00
showT :: Show a => a -> Text
showT = fS . show
2020-01-14 21:55:34 +00:00
-- | Like 'when', but where the test can be monadic.
whenM :: Monad m => m Bool -> m () -> m ()
whenM ~b ~t = ifM b t (return ())
-- | Like 'unless', but where the test can be monadic.
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM ~b ~f = ifM b (return ()) f
-- | Like @if@, but where the test can be monadic.
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM ~b ~t ~f = do
b' <- b
if b' then t else f
2020-01-16 22:27:38 +00:00
whileM :: Monad m => m a -> (a -> m Bool) -> m a
whileM ~action ~f = do
a <- action
b' <- f a
if b' then whileM action f else pure a
2020-01-14 21:55:34 +00:00
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
2020-01-16 22:27:38 +00:00
whileM_ ~action = void . whileM action
guardM :: (Monad m, Alternative m) => m Bool -> m ()
2020-01-17 00:50:12 +00:00
guardM ~f = guard =<< f
2020-01-14 21:55:34 +00:00
2020-01-16 22:27:38 +00:00
lBS2sT :: L.ByteString -> Text
lBS2sT = TL.toStrict . TLE.decodeUtf8
2020-01-17 22:29:16 +00:00
2020-02-29 23:07:39 +00:00
handleIO' :: (MonadIO m, MonadCatch m)
=> IOErrorType
-> (IOException -> m a)
-> m a
-> m a
handleIO' err handler = handleIO
(\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e)
2020-01-17 22:29:16 +00:00
2020-02-18 08:40:01 +00:00
(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
(??) m e = maybe (throwE e) pure m
(!?) :: forall e es a m
. (Monad m, e :< es)
=> m (Maybe a)
-> e
-> Excepts es m a
(!?) em e = lift em >>= (?? e)
lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
lE = liftE . veitherToExcepts . fromEither
2020-02-28 23:33:32 +00:00
lE' :: forall e' e es a m
. (Monad m, e :< es)
=> (e' -> e)
-> Either e' a
-> Excepts es m a
lE' f = liftE . veitherToExcepts . fromEither . bimap f id
2020-02-18 08:40:01 +00:00
lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
lEM em = lift em >>= lE
2020-02-28 23:33:32 +00:00
lEM' :: forall e' e es a m
. (Monad m, e :< es)
=> (e' -> e)
-> m (Either e' a)
-> Excepts es m a
lEM' f em = lift em >>= lE . bimap f id
2020-02-18 08:40:01 +00:00
fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight
2020-02-22 18:21:10 +00:00
2020-02-29 23:07:39 +00:00
2020-03-08 17:30:08 +00:00
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 =
2020-02-29 23:07:39 +00:00
handleIO
(\e ->
if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
)
. liftE
2020-03-08 17:30:08 +00:00
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
2020-03-03 00:59:19 +00:00
hideErrorDef :: IOErrorType -> a -> IO a -> IO a
hideErrorDef err def =
handleIO (\e -> if err == ioeGetErrorType e then pure def else ioError e)
hideErrorDefM :: IOErrorType -> IO a -> IO a -> IO a
hideErrorDefM err def =
handleIO (\e -> if err == ioeGetErrorType e then def else ioError e)
2020-02-29 23:07:39 +00:00
-- TODO: does this work?
2020-02-24 13:56:13 +00:00
hideExcept :: forall e es es' a m
. (Monad m, e :< es, LiftVariant (Remove e es) es')
=> e
-> a
-> Excepts es m a
-> Excepts es' m a
2020-02-29 23:07:39 +00:00
hideExcept _ a action =
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
2020-02-24 13:56:13 +00:00
2020-03-08 17:30:08 +00:00
2020-03-03 00:59:19 +00:00
hideExcept' :: forall e es es' m
2020-03-04 22:35:53 +00:00
. (Monad m, e :< es, LiftVariant (Remove e es) es')
=> e
-> Excepts es m ()
-> Excepts es' m ()
2020-03-03 00:59:19 +00:00
hideExcept' _ action =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
2020-03-08 17:30:08 +00:00
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)
2020-02-28 23:33:32 +00:00
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
throwEither a = case a of
Left e -> throwM e
Right r -> pure r
verToBS :: Version -> ByteString
verToBS = E.encodeUtf8 . prettyVer
intToText :: Integral a => a -> T.Text
intToText = TL.toStrict . B.toLazyText . B.decimal
2020-03-05 17:02:59 +00:00
removeLensFieldLabel :: String -> String
removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
2020-03-08 17:30:08 +00:00
addToCurrentEnv :: MonadIO m
=> [(ByteString, ByteString)]
-> m [(ByteString, ByteString)]
addToCurrentEnv adds = do
cEnv <- liftIO $ getEnvironment
pure (adds ++ cEnv)