mirror of https://github.com/voidlizard/hbs2
83 lines
2.2 KiB
Haskell
83 lines
2.2 KiB
Haskell
{-# Language AllowAmbiguousTypes #-}
|
|
module HBS2.OrDie
|
|
( module HBS2.OrDie
|
|
) where
|
|
|
|
import Data.Kind
|
|
import Control.Monad.IO.Class
|
|
import System.Exit
|
|
import Prettyprinter
|
|
import UnliftIO
|
|
import Control.Monad.Except
|
|
|
|
class OrDie m a where
|
|
type family OrDieResult a :: Type
|
|
orDie :: m a -> String -> m (OrDieResult a)
|
|
|
|
orDieM :: (Monad m, OrDie m a) => a -> String -> m (OrDieResult a)
|
|
orDieM a msg = pure a `orDie` msg
|
|
|
|
instance MonadIO m => OrDie m (Maybe a) where
|
|
type instance OrDieResult (Maybe a) = a
|
|
orDie mv err = mv >>= \case
|
|
Nothing -> liftIO $ die err
|
|
Just x -> pure x
|
|
|
|
instance MonadIO m => OrDie m (Either a b) where
|
|
type instance OrDieResult (Either a b) = b
|
|
orDie mv err = mv >>= \case
|
|
Left{} -> liftIO $ die err
|
|
Right x -> pure x
|
|
|
|
instance MonadIO m => OrDie m ExitCode where
|
|
type instance OrDieResult ExitCode = ()
|
|
orDie mv err = mv >>= \case
|
|
ExitSuccess -> pure ()
|
|
ExitFailure{} -> liftIO $ die err
|
|
|
|
|
|
-- TODO: move-to-library
|
|
class OrThrow a where
|
|
type family OrThrowResult a :: Type
|
|
orThrow :: forall e m . (MonadIO m, Exception e) => e -> a -> m (OrThrowResult a)
|
|
|
|
|
|
instance OrThrow (Maybe a) where
|
|
type instance OrThrowResult (Maybe a) = a
|
|
orThrow e a = case a of
|
|
Nothing -> throwIO e
|
|
Just x -> pure x
|
|
|
|
instance OrThrow (Either b a) where
|
|
type instance OrThrowResult (Either b a) = a
|
|
orThrow e a = case a of
|
|
Left{} -> throwIO e
|
|
Right x -> pure x
|
|
|
|
class OrThrowError a where
|
|
type family OrThrowErrorResult a :: Type
|
|
orThrowError :: forall e m . (MonadError e m ) => e -> a -> m (OrThrowErrorResult a)
|
|
|
|
{- HLINT ignore "Eta reduce" -}
|
|
instance OrThrowError (Maybe a) where
|
|
type instance (OrThrowErrorResult (Maybe a)) = a
|
|
orThrowError e a = maybe (throwError e) pure a
|
|
|
|
instance OrThrowError (Either b a) where
|
|
type instance (OrThrowErrorResult (Either b a)) = a
|
|
orThrowError e a = either (const $ throwError e) pure a
|
|
|
|
orThrowUser :: (OrThrow a1, MonadIO m)
|
|
=> Doc ann
|
|
-> a1
|
|
-> m (OrThrowResult a1)
|
|
|
|
orThrowUser p = orThrow (userError (show p))
|
|
|
|
orThrowPassIO :: (MonadIO m, Exception e) => Either e a -> m a
|
|
orThrowPassIO = \case
|
|
Left e -> throwIO e
|
|
Right x -> pure x
|
|
|
|
|